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.33 2018/07/25 01:39:50 gustafn Exp $
}
ad_proc -private 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
}
ad_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]
}
ad_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 -private 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 [ad_decode $auto_mount "" "" "$auto_mount\n"]
append spec "
[ns_quotehtml $pretty_name]
[ns_quotehtml $pretty_plural]
$initial_install_p
$singleton_p
$implements_subsite_p
$inherit_templates_p
${auto_mount_tag}
\n"
db_foreach owner_info {} {
append spec " [ns_quotehtml $owner_name]\n"
}
apm_log APMDebug "APM: Writing Version summary and description"
if { $summary ne "" } {
append spec " [ns_quotehtml $summary]\n"
}
if { $release_date ne "" } {
append spec " [ns_quotehtml [string range $release_date 0 9]]\n"
}
if { $vendor ne "" || $vendor_uri ne "" } {
append spec " [ns_quotehtml $vendor]\n"
}
if { $description ne "" } {
append spec " [ns_quotehtml $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 " \n"
}
append spec "\n \n"
apm_log APMDebug "APM: Writing callbacks"
db_foreach callback_info {} {
append spec " \n"
}
append spec " "
append spec "\n \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 " \n"
} if_no_rows {
append spec " \n"
}
append spec " \n\n"
append spec "
"
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:
This routine will typically be called like so:
array set version_properties [apm_read_package_info_file $path]
to populate the version_properties
array.
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 [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 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 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
# -> 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
ns_log Error "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: