apm-xml-procs.tcl

Does not contain a contract.

Location:
/packages/acs-tcl/tcl/apm-xml-procs.tcl
File Contents

ad_library {

    Functions that APM uses to parse and generate XML.

    @author Bryan Quinn (bquinn@arsdigita.com)
    @author Ben Adida (ben@mit.edu)
    @author Bart Teeuwisse (bart.teeuwisse@thecodemill.biz)
    @creation-date Fri Oct  6 21:47:39 2000
    @cvs-id $Id: apm-xml-procs.tcl,v 1.35 2024/09/11 06:15:48 gustafn Exp $
}

ad_proc -public apm_required_attribute_value { element attribute } {

    Returns an attribute of an XML element, throwing an error if the attribute
    is not set.

} {
    set value [apm_attribute_value $element $attribute]
    if { $value eq "" } {
        error "Required attribute \"$attribute\" missing from <[xml_node_get_name $element]>"
    }
    return $value
}

d_proc -public apm_attribute_value {
    {-default ""}
    element attribute
} {

    Parses the XML element to return the value for the specified attribute.

} {
    ns_log Debug "apm_attribute_value $element $attribute $default --> [xml_node_get_attribute $element $attribute $default]"
    return [xml_node_get_attribute $element $attribute $default]
}

d_proc -private apm_tag_value {
    {-default ""}
    root property_name
} {
    Parses the XML element and returns the associated property name if it exists.
} {
    ns_log Debug "apm_tag_value [$root nodeName] $property_name"
    set node [xml_node_get_first_child_by_name $root $property_name]

    if { $node ne "" } {
        return [xml_node_get_content $node]
    }
    ns_log Debug "apm_tag_value $root $property_name $default --> $default"
    return $default
}

ad_proc -public apm_generate_package_spec { version_id } {

    Generates an XML-formatted specification for a version of a package.

} {
    set spec {}

    db_1row package_version_select {}

    apm_log APMDebug "APM: Writing Package Specification for $pretty_name $version_name"
    set auto_mount_tag [expr {$auto_mount ne "" ? "    <auto-mount>$auto_mount</auto-mount>\n" : ""}]
    append spec "<?xml version=\"1.0\"?>
<!-- Generated by the OpenACS Package Manager -->

<package key=\"[ns_quotehtml $package_key]\" url=\"[ns_quotehtml $package_uri]\" type=\"$package_type\">
    <package-name>[ns_quotehtml $pretty_name]</package-name>
    <pretty-plural>[ns_quotehtml $pretty_plural]</pretty-plural>
    <initial-install-p>$initial_install_p</initial-install-p>
    <singleton-p>$singleton_p</singleton-p>
    <implements-subsite-p>$implements_subsite_p</implements-subsite-p>
    <inherit-templates-p>$inherit_templates_p</inherit-templates-p>
${auto_mount_tag}
    <version name=\"$version_name\" url=\"[ns_quotehtml $version_uri]\">\n"

    db_foreach owner_info {} {
        append spec "        <owner"
        if { $owner_uri ne "" } {
            append spec " url=\"[ns_quotehtml $owner_uri]\""
        }
        append spec ">[ns_quotehtml $owner_name]</owner>\n"
    }

    apm_log APMDebug "APM: Writing Version summary and description"
    if { $summary ne "" } {
        append spec "        <summary>[ns_quotehtml $summary]</summary>\n"
    }
    if { $release_date ne "" } {
        append spec "        <release-date>[ns_quotehtml [string range $release_date 0 9]]</release-date>\n"
    }
    if { $vendor ne "" || $vendor_uri ne "" } {
        append spec "        <vendor"
        if { $vendor_uri ne "" } {
            append spec " url=\"[ns_quotehtml $vendor_uri]\""
        }
        append spec ">[ns_quotehtml $vendor]</vendor>\n"
    }
    if { $description ne "" } {
        append spec "        <description"
        if { $description_format ne "" } {
            append spec " format=\"[ns_quotehtml $description_format]\""
        }
        append spec ">[ns_quotehtml $description]</description>\n"
    }

    append spec [apm::package_version::attributes::generate_xml \
                     -version_id $version_id \
                     -indentation "        "]

    append spec "\n"

    apm_log APMDebug "APM: Writing Dependencies."
    db_foreach dependency_info {} {
        append spec "        <$dependency_type url=\"[ns_quotehtml $service_uri]\" version=\"[ns_quotehtml $service_version]\"/>\n"
    } else {
        append spec "        <!-- No dependency information -->\n"
    }

    append spec "\n        <callbacks>\n"
    apm_log APMDebug "APM: Writing callbacks"
    db_foreach callback_info {} {
        append spec "            <callback type=\"[ns_quotehtml $type]\" \
                                           proc=\"[ns_quotehtml $proc]\"/>\n"
    }
    append spec "        </callbacks>"
    append spec "\n        <parameters>\n"
    apm_log APMDebug "APM: Writing parameters"

    set parent_package_keys [lrange [apm_one_package_inherit_order $package_key] 0 end-1]

    db_foreach parameter_info {} {
        append spec "            <parameter scope=\"[ns_quotehtml $scope]\" datatype=\"[ns_quotehtml $datatype]\" \
            min_n_values=\"[ns_quotehtml $min_n_values]\" \
            max_n_values=\"[ns_quotehtml $max_n_values]\" \
            name=\"[ns_quotehtml $parameter_name]\" "
        if { $default_value ne "" } {
            append spec " default=\"[ns_quotehtml $default_value]\""
        }

        if { $description ne "" } {
            append spec " description=\"[ns_quotehtml $description]\""
        }

        if { $section_name ne "" } {
            append spec " section_name=\"[ns_quotehtml $section_name]\""
        }

        append spec "/>\n"
    } if_no_rows {
        append spec "        <!-- No version parameters -->\n"
    }

    append spec "        </parameters>\n\n"


    append spec "    </version>
</package>
"
    apm_log APMDebug "APM: Finished writing spec."
    return $spec
}


ad_proc -public apm_read_package_info_file { path } {

    Reads a .info file, returning an array containing the following items:

    <ul>
    <li><code>path</code>: a path to the file read
    <li><code>mtime</code>: the mtime of the file read
    <li><code>provides</code>, <code>embeds</code>, <code>extends</code>,
      and <code>requires</code>: <p>
      lists of dependency information, containing elements of the form
      <code>[list $url $version]</code>
    <li><code>owners</code>: a list of owners containing elements of the form
    <code>[list $url $name]</code>
    <li><code>files</code>: a list of files in the package,
    containing elements of the form <code>[list $path
    $type]</code> NOTE: Files are no longer stored in info files but are always retrieved
    directly from the filesystem. This element in the array will always be the empty list.
    <li><code>callbacks</code>: an array list of callbacks of the package
    on the form <code>[list callback_type1 proc_name1 callback_type2 proc_name2 ...]</code>
    <li>Element and attribute values directly from the XML specification:
    <code>package.key</code>,
    <code>package.url</code>,
    <code>package.type</code>
    <code>package-name</code>,
    <code>pretty-plural</code>
    <code>initial-install-p</code>
    <code>singleton-p</code>
    <code>auto-mount</code>
    <code>name</code> (the version name, e.g., <code>3.3a1</code>),
    <code>url</code> (the version URL),
    <code>option</code>,
    <code>summary</code>,
    <code>description</code>,
    <code>release-date</code>,
    <code>vendor</code>,
    <code>group</code>,
    <code>vendor.url</code>, and
    <code>description.format</code>,
    <code>maturity</code>,
    <code>maturity_text</code>.

    </ul>

    This routine will typically be called like so:

    <blockquote><pre>array set version_properties [apm_read_package_info_file $path]</pre></blockquote>

    to populate the <code>version_properties</code> array.

    <p>If the .info file cannot be read or parsed, this routine throws a
    descriptive error.

} {
    # If the .info file hasn't changed since last read (i.e., has the same
    # mtime), return the cached info list.
    set mtime [ad_file mtime $path]
    if { [nsv_exists apm_version_properties $path] } {
        set cached_version [nsv_get apm_version_properties $path]
        if { [lindex $cached_version 0] == $mtime } {
            return [lindex $cached_version 1]
        }
    }

    # Set the path and mtime in the array.
    set properties(path) $path
    set properties(mtime) $mtime

    apm_log APMDebug "Reading specification file at $path"

    set file [open $path]
    set xml_data [read $file]
    close $file

    if {[catch {set tree [xml_parse -persist $xml_data]} errorMsg]} {
        ns_log error "parsing XML file $path lead to error: $errorMsg"
        return -code error "file: $path\n$errorMsg"
    }

    set root_node [xml_doc_get_first_node $tree]
    apm_log APMDebug "XML: root node is [xml_node_get_name $root_node]"
    set package $root_node

    set root_name [xml_node_get_name $package]

    # Debugging Children
    set root_children [xml_node_get_children $root_node]

    apm_log APMDebug "XML - there are [llength $root_children] child nodes"
    foreach child $root_children {
        apm_log APMDebug "XML - one root child: [xml_node_get_name $child]"
    }

    if { $root_name ne "package" } {
        apm_log APMDebug "XML: the root name is $root_name"
        error "Expected <package> as root node"
    }
    set properties(package.key)          [apm_required_attribute_value $package key]
    set properties(package.url)          [apm_required_attribute_value $package url]
    set properties(package.type)         [apm_attribute_value -default "apm_application" $package type]
    set properties(package-name)         [apm_tag_value $package package-name]
    set properties(initial-install-p)    [apm_tag_value -default "f" $package initial-install-p]
    set properties(auto-mount)           [apm_tag_value -default "" $package auto-mount]
    set properties(singleton-p)          [apm_tag_value -default "f" $package singleton-p]
    set properties(implements-subsite-p) [apm_tag_value -default "f" $package implements-subsite-p]
    set properties(inherit-templates-p)  [apm_tag_value -default "t" $package inherit-templates-p]
    set properties(pretty-plural)        [apm_tag_value -default "$properties(package-name)s" $package pretty-plural]

    set versions [xml_node_get_children_by_name $package version]
    if { [llength $versions] != 1 } {
        error "Package must contain exactly one <version> node"
    }
    set version [lindex $versions 0]

    set properties(name) [apm_required_attribute_value $version name]
    set properties(url)  [apm_required_attribute_value $version url]

    # Set an entry in the properties array for each of these tags.
    set properties(maturity) ""
    foreach property_name { summary description release-date vendor maturity } {
        set properties($property_name) [apm_tag_value $version $property_name]
    }
    set properties(maturity_text) [apm::package_version::attributes::maturity_int_to_text $properties(maturity)]

    apm::package_version::attributes::parse_xml \
        -parent_node $version \
        -array properties

    # Set an entry in the properties array for each of these attributes:
    #
    #   <vendor url="...">           -> vendor.url
    #   <description format="...">   -> description.format

    foreach { property_name attribute_name } {
        vendor url
        license url
        description format
    } {
        set node [xml_node_get_first_child_by_name $version $property_name]
        if { $node ne "" } {
            set properties($property_name.$attribute_name) [apm_attribute_value $node $attribute_name]
        } else {
            set properties($property_name.$attribute_name) ""
        }
    }

    # Build a list of packages to install additionally

    set properties(install) [list]
    foreach node [xml_node_get_children_by_name $version install] {
        set install [apm_attribute_value $node package]
        lappend properties(install) $install
    }

    # We're done constructing the properties array - save the properties into the
    # moby array which we're going to return.

    set properties(properties) [array get properties]

    # Build lists of the services provided by and required by the package.

    set properties(provides) [list]
    set properties(requires) [list]
    set properties(embeds) [list]
    set properties(extends) [list]

    foreach dependency_type { provides requires embeds extends } {
        set dependency_types [xml_node_get_children_by_name $version $dependency_type]

        foreach node $dependency_types {
            set service_uri [apm_required_attribute_value $node url]
            set service_version [apm_required_attribute_value $node version]
            # Package always provides itself, we'll add that below, so don't add it here
            if { $dependency_type ne "provides" || $service_uri ne $properties(package.key) } {
                lappend properties($dependency_type) [list $service_uri $service_version]
            }
        }
    }
    # Package provides itself always
    lappend properties(provides) [list $properties(package.key) $properties(name)]

    set properties(files) [list]

    # Build a list of package callbacks
    array set callback_array {}

    set callbacks_node_list [xml_node_get_children_by_name $version callbacks]
    foreach callbacks_node $callbacks_node_list {

        set callback_node_list [xml_node_get_children_by_name $callbacks_node callback]
        foreach callback_node $callback_node_list {

            set type [apm_attribute_value $callback_node type]
            set proc [apm_attribute_value $callback_node proc]

            if { [llength [array get callback_array $type]] != 0 } {
                # A callback proc of this type already found in the XML file
                ns_log Error "package info file $path contains more than one callback proc of type $type"
                continue
            }

            if {$type ni [apm_supported_callback_types]} {
                #
                # The callback type is not supported.  Report an error
                # unelss when this happens in the regression test,
                # where the error condition is tested.
                #
                set severity [expr {[aa_test_running_p] ? "warning" : "error"}]
                ns_log $severity "package info file $path contains an unsupported" \
                    "callback type '$type' - ignoring. Valid values are" \
                    [apm_supported_callback_types]
                continue
            }

            set callback_array($type) $proc
        }
    }

    set properties(callbacks) [array get callback_array]


    # Build a list of the package's owners (if any).

    set properties(owners) [list]
    foreach node [xml_node_get_children_by_name $version owner] {
        set url [apm_attribute_value $node url]
        set name [xml_node_get_content $node]
        lappend properties(owners) [list $name $url]
    }

    # Build a list of the packages parameters (if any)

    set properties(parameters) [list]
    apm_log APMDebug "APM: Reading Parameters"

    foreach node [xml_node_get_children_by_name $version parameters] {
        set parameter_nodes [xml_node_get_children_by_name $node parameter]

        foreach parameter_node $parameter_nodes {
            set default_value [apm_attribute_value $parameter_node default]
            set min_n_values [apm_attribute_value $parameter_node min_n_values]
            set max_n_values [apm_attribute_value $parameter_node max_n_values]
            set description [apm_attribute_value $parameter_node description]
            set section_name [apm_attribute_value $parameter_node section_name]
            set datatype [apm_attribute_value $parameter_node datatype]
            set name [apm_attribute_value $parameter_node name]
            set scope [apm_attribute_value $parameter_node scope]

            if { $scope eq "" } {
                set scope instance
            }

            apm_log APMDebug "APM: Reading parameter $name with default $default_value"
            lappend properties(parameters) [list $name $description $section_name $scope \
                $datatype $min_n_values $max_n_values $default_value]
        }
    }

    # Release the XML tree
    xml_doc_free $tree

    # Serialize the array into a list.
    set return_value [array get properties]

    # Cache the property info based on $mtime.
    nsv_set apm_version_properties $path [list $mtime $return_value]

    return $return_value
}

# Local variables:
#    mode: tcl
#    tcl-indent-level: 4
#    indent-tabs-mode: nil
# End:
apm-xml-procs.tcl

Related Files

File Contents
