Index: openacs-4/contrib/packages/cop-base/tcl/cop-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/packages/cop-base/tcl/cop-procs.tcl,v diff -u -r1.1 -r1.2 --- openacs-4/contrib/packages/cop-base/tcl/cop-procs.tcl 28 Mar 2004 21:17:14 -0000 1.1 +++ openacs-4/contrib/packages/cop-base/tcl/cop-procs.tcl 31 Mar 2004 21:15:22 -0000 1.2 @@ -12,7 +12,7 @@ namespace eval cop::util {} ad_proc -public cop::util::url { - {-subsite_id {}} + {-node_id {}} } { Returns the cop-ui URL for a given subsite. @@ -23,9 +23,211 @@ @author Jeff Davis davis@xarg.net @creation-date 2003-10-30 } { - if {[empty_string_p $subsite_id]} { - set subsite_id [ad_conn subsite_id] + if {[empty_string_p $node_id]} { + set node_id [site_node::closest_ancestor_package -package_key acs-subsite -node_id [ad_conn node_id] -include_self -element node_id] } - return [lindex [site_node::get_children -node_id $subsite_id -package_key cop-ui -all] 0] -} \ No newline at end of file + return [lindex [site_node::get_children -node_id $node_id -package_key cop-ui -all] 0] +} + +ad_proc -public cop::util::package_id { + {-node_id {}} +} { + Returns the first cop-ui package under node_id, node_id defaults to the nearest + + @param subsite_id the subsite for which to find the cop-ui package_id + + @return a url for the cop-ui package + + @author Jeff Davis davis@xarg.net + @creation-date 2003-10-30 +} { + if {[empty_string_p $node_id]} { + set node_id [site_node::closest_ancestor_package -package_key acs-subsite -node_id [ad_conn node_id] -include_self -element node_id] + } + + return [lindex [site_node::get_children -element package_id -node_id $node_id -package_key cop-ui -all] 0] +} + + +ad_proc -private cop::load_install_xml {filename binds} { + Loads an install file and returns the root node. + errors out if the file is not there. + + substitutes variables before parsing so you can provide interpolated values. + + @param filename relative to serverroot, leading slash needed. + @param binds list of {variable value variable value ...} + + @return root_node of the parsed xml file. + + @author Jeff Davis +} { + # Abort if there is no install.xml file + set filename [acs_root_dir]$filename + + if { ![file exists $filename] } { + error "File $filename not found" + } + + # Read the whole file + set file [open $filename] + set __the_body__ [read $file] + close $file + # Interpolate the vars. + if {![empty_string_p binds]} { + foreach {var val} $binds { + set $var $val + } + if {[catch {set __the_body__ [subst -nobackslashes -nocommands ${__the_body__}]} err]} { + error $err + } + } + + set root_node [xml_doc_get_first_node [xml_parse -persist ${__the_body__}]] + return $root_node +} + +ad_proc -private cop::install {filename binds} { + install a CoP subsite from an xml definition. + + @parameter filename path to the xml file defining the CoP relative to serverroot. + @param binds list of {variable value variable value ...} + + @return list of messages + + @author Jeff Davis (swiped from acs-bootstrap-installer though) +} { + set root_node [cop::load_install_xml $filename $binds] + + set acs_application(name) [apm_required_attribute_value $root_node name] + set acs_application(pretty_name) [apm_attribute_value -default $acs_application(name) $root_node pretty-name] + + lappend out "Loading packages for the $acs_application(pretty_name) application." + + set actions [xml_node_get_children_by_name $root_node actions] + + if { [llength $actions] != 1 } { + ns_log Error "Error in \"$filename\": only one action node is allowed, found: [llength $actions]" + error "Error in \"$filename\": only one action node is allowed" + } + + set actions [xml_node_get_children [lindex $actions 0]] + + foreach action $actions { + switch -exact [xml_node_get_name $action] { + text {} + + install { + set install_spec_files [list] + foreach install_spec_file [glob -nocomplain "[acs_root_dir]/packages/[apm_required_attribute_value $action package]/*.info"] { + if { [catch { array set package [apm_read_package_info_file $install_spec_file] } errmsg] } { + # Unable to parse specification file. + error "install: $install_spec_file could not be parsed correctly. The error: $errmsg" + return + } + + if { [apm_package_supports_rdbms_p -package_key $package(package.key)] + && ![apm_package_installed_p $package(package.key)] } { + lappend install_spec_files $install_spec_file + } + } + + set pkg_info_list [list] + foreach spec_file [glob -nocomplain "[acs_root_dir]/packages/*/*.info"] { + # Get package info, and find out if this is a package we should install + if { [catch { array set package [apm_read_package_info_file $spec_file] } errmsg] } { + # Unable to parse specification file. + error "install: $spec_file could not be parsed correctly. The error: $errmsg" + } + + if { [apm_package_supports_rdbms_p -package_key $package(package.key)] + && ![apm_package_installed_p $package(package.key)] } { + # Save the package info, we may need it for dependency satisfaction later + lappend pkg_info_list [pkg_info_new $package(package.key) $spec_file \ + $package(provides) $package(requires) ""] + } + } + + if { [llength $install_spec_files] > 0 } { + set dependency_results [apm_dependency_check -pkg_info_all $pkg_info_list $install_spec_files] + if { [lindex $dependency_results 0] == 1 } { + apm_packages_full_install -callback apm_ns_write_callback [lindex $dependency_results 1] + } else { + foreach package_spec [lindex $dependency_results 1] { + if { [string is false [pkg_info_dependency_p $package_spec]] } { + append err_out "install: package \"[pkg_info_key $package_spec]\"[join [pkg_info_comment $package_spec] ","]\n" + } + } + error $err_out + } + } + } + + mount { + + set package_key [apm_required_attribute_value $action package] + set instance_name [apm_required_attribute_value $action instance-name] + set mount_point [apm_required_attribute_value $action mount-point] + + regexp {(.*)/([^/]*)$} $mount_point match parent_url mount_point + if {$parent_url eq ""} { + set parent_url / + } + set parent_id [site_node::get_node_id -url $parent_url] + + if { [catch { + db_transaction { + set node_id [site_node::new -name $mount_point -parent_id $parent_id] + } + } error] } { + # There is already a node with that path, check if there is a package mounted there + error $error + array set node [site_node::get -url "/$mount_point"] + if { [empty_string_p $node(object_id)] } { + # There is no package mounted there so go ahead and mount the new package + set node_id $node(node_id) + } else { + error "A package is already mounted at \"$mount_point\"" + } + } + + if { ![empty_string_p $node_id] } { + lappend out "Mounting new instance of package $package_key at /$mount_point" + site_node::instantiate_and_mount \ + -node_id $node_id \ + -node_name $mount_point \ + -package_name $instance_name \ + -package_key $package_key + + } + + } + + set-parameter { + set name [apm_required_attribute_value $action name] + set value [apm_required_attribute_value $action value] + set package_key [apm_attribute_value -default "" $action package] + set url [apm_attribute_value -default "" $action url] + + if { ![string equal $package_key ""] && ![string equal $url ""] } { + error "set-parameter: Can't specify both package and url for $url and $package_key" + } elseif { ![string equal $package_key ""] } { + parameter::set_from_package_key -package_key $package_key -parameter $name -value $value + } else { + parameter::set_value \ + -package_id [site_node::get_object_id -node_id [site_node::get_node_id -url $url]] \ + -parameter $name \ + -value $value + } + } + + default { + error "Error in \"$filename\": got bad node \"[xml_node_get_name $action]\"" + } + + } + + } + return $out +}