Loading package .info files ... this will take a few minutes
" +ns_write "
+Loading package .info files - this will take a few minutes. + +
+ +This might really take a few minutes, depending on your machine. Have a cup of coffee or beer or whatever and be patient. Thanks. + +
+ +... + +" + # Preload all the .info files so the next page is snappy. apm_dependency_check -initial_install [apm_scan_packages -new [file join [acs_root_dir] packages]] Index: openacs-4/packages/acs-bootstrap-installer/installer/packages-install.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-bootstrap-installer/installer/Attic/packages-install.tcl,v diff -u -N -r1.3 -r1.3.4.1 --- openacs-4/packages/acs-bootstrap-installer/installer/packages-install.tcl 29 Aug 2001 21:22:48 -0000 1.3 +++ openacs-4/packages/acs-bootstrap-installer/installer/packages-install.tcl 5 Mar 2003 14:41:49 -0000 1.3.4.1 @@ -16,13 +16,23 @@ where package_key = 'acs-kernel' } -default 0] } else { - return 0 + return 0 } } ns_write "[install_header 200 "Installing OpenACS Core Services"] " +# Load the acs-tcl init files that might be needed when installing, instantiating and mounting packages +# We shouldn't source request-processor-init.tcl as it might interfere with the installer request handler +foreach { init_file } { utilities-init.tcl site-nodes-init.tcl } { + ns_log Notice "Loading acs-tcl init file $init_file" + apm_source "[acs_package_root_dir acs-tcl]/tcl/$init_file" +} +apm_bootstrap_load_libraries -procs acs-subsite +apm_bootstrap_load_queries acs-subsite +install_redefine_ad_conn + # Attempt to install all packages. set dependency_results [apm_dependency_check -initial_install [apm_scan_packages -new [file join [acs_root_dir] packages]]] set dependencies_satisfied_p [lindex $dependency_results 0] @@ -32,12 +42,24 @@ # Complete the initial install. if { ![ad_acs_admin_node] } { - ns_write "
+ ns_write "
"
+
+ # Mount the main site
cd [file join [acs_root_dir] packages acs-kernel sql [db_type]]
db_source_sql_file -callback apm_ns_write_callback acs-install.sql
+
+ # Make sure the site-node cache is updated with the main site
+ site_node::init_cache
+
+ # We need to redefine ad_conn again since apm_package_install resourced the real ad_conn
+ install_redefine_ad_conn
+
+ # Mount and set permissions for core packages
+ apm_mount_core_packages
+
ns_write ".tcl are considered Tcl utility script files (normally
found only in the bootstrap installer).
+ .xml in the directory catalog are
+ considered message catalog files.
+ + Returns all files, or files of a certain types, belonging to an APM + package. Ignores files based on proc apm_include_file_p and determines file type + of files with proc apm_guess_file_type. Only returns file with no db type or a + db type matching that of the system. +
+ ++ Goes directly to the filesystem to find + files instead of using a file listing in the package info file or the database. +
+ + @param package_key The key of the package to return file paths for + @param file_types The type of files to return. If not provided files of all types + recognized by the APM are returned. + + @return The paths, relative to the root dir of the package, of matching files. + + @author Peter Marklund + + @see apm_include_file_p + @see apm_guess_file_type + @see apm_guess_db_type +} { + set package_path [acs_package_root_dir $package_key] + set files [lsort [ad_find_all_files -check_file_func apm_include_file_p $package_path]] + + set matching_files [list] + foreach file $files { + set rel_path [string range $file [expr [string length $package_path] + 1] end] + set file_type [apm_guess_file_type $package_key $rel_path] + set file_db_type [apm_guess_db_type $package_key $rel_path] + + set type_match_p [expr [empty_string_p $file_types] || [lsearch $file_types $file_type] != -1] + set db_match_p [expr [empty_string_p $file_db_type] || [string equal $file_db_type [db_type]]] + + if { $type_match_p && $db_match_p } { + lappend matching_files $rel_path + } + } + + return $matching_files +} + ad_proc -private apm_guess_db_type { package_key path } { Guesses and returns the database type key corresponding to a particular path @@ -194,9 +249,33 @@ return "" } + +ad_proc apm_package_supports_rdbms_p { + {-package_key:required} +} { + Returns 1 if the given package supports the rdbms of the system and 0 otherwise. + The package is considedered to support the given rdbms if there is at least one + file in the package of matching db_type. FIXME: this check will fail if a package + doesn't have any db files (no sql create scripts and no db specific xql files). + @author Peter Marklund +} { + set system_db_type [db_type] + + return 1 + foreach file [apm_get_package_files -all_db_types -package_key $package_key] { + if { [string equal $system_db_type [apm_guess_db_type $package_key $file]] } { + return 1 + } + } + + return 0 +} + ad_proc apm_source { __file } { Sources $__file in a clean environment, returning 1 if successful or 0 if not. + Records that the file has been sourced and stores its mtime in the nsv array + apm_library_mtime } { if { ![file exists $__file] } { ns_log "Error" "Unable to source $__file: file does not exist." @@ -210,6 +289,8 @@ return 0 } + nsv_set apm_library_mtime [ad_make_relative_path $__file] [file mtime $__file] + return 1 } @@ -221,11 +302,12 @@ set relative_path [string range $file \ [expr { [string length "$root_directory/packages"] + 1 }] end] ns_log "Notice" "Loading packages/$relative_path..." + apm_source $file - nsv_set apm_library_mtime packages/$relative_path [file mtime $file] } ad_proc apm_bootstrap_load_libraries { + {-load_tests:boolean 0} {-init:boolean} {-procs:boolean} package_key @@ -268,8 +350,14 @@ ([string equal $file_type tcl_procs] && $procs_p || [string equal $file_type tcl_init] && $init_p)} { - apm_bootstrap_load_file $root_directory $file + # Don't source acs-automated-testing tests before that package has been + # loaded + if { ! $load_tests_p && [regexp {tcl/test/[^/]+$} $file match] } { + continue + } + apm_bootstrap_load_file $root_directory $file + # Call db_release_unused_handles, only if the library defining it # (10-database-procs.tcl) has been sourced yet. if { [llength [info procs db_release_unused_handles]] != 0 } { Index: openacs-4/packages/acs-bootstrap-installer/tcl/40-db-query-dispatcher-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-bootstrap-installer/tcl/40-db-query-dispatcher-procs.tcl,v diff -u -N -r1.27.2.3 -r1.27.2.4 --- openacs-4/packages/acs-bootstrap-installer/tcl/40-db-query-dispatcher-procs.tcl 16 Feb 2003 20:27:05 -0000 1.27.2.3 +++ openacs-4/packages/acs-bootstrap-installer/tcl/40-db-query-dispatcher-procs.tcl 5 Mar 2003 14:42:01 -0000 1.27.2.4 @@ -415,6 +415,7 @@ } else { db_qd_log Debug "NO FULLQUERY FOR $statement_name --> using default SQL" if { [empty_string_p $sql] } { + # The default SQL is empty, that implies a bug somewhere in the code. error "No fullquery for $statement_name and default SQL empty - query for statement missing" } } @@ -567,7 +568,7 @@ # Check if it's compatible at all! if {![db_rdbms_compatible_p [db_fullquery_get_rdbms $fullquery] [db_current_rdbms]]} { - db_qd_log Debug "Query [db_fullquery_get_name $fullquery] is *NOT* compatible" + ns_log Error "Query [db_fullquery_get_name $fullquery] is *NOT* compatible" return } Index: openacs-4/packages/acs-tcl/acs-tcl.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/acs-tcl.info,v diff -u -N -r1.23.2.1 -r1.23.2.2 --- openacs-4/packages/acs-tcl/acs-tcl.info 9 Dec 2002 14:30:51 -0000 1.23.2.1 +++ openacs-4/packages/acs-tcl/acs-tcl.info 5 Mar 2003 14:40:28 -0000 1.23.2.2 @@ -7,7 +7,7 @@Installed $version(package-name), version $version(name).
" } { - apm_callback_and_log $callback "
Failed to install $version(package-name), version $version(name). The following error was generated: + apm_callback_and_log -severity Error $callback "
Failed to install $version(package-name), version $version(name). The following error was generated:
" return 0 } - if {![string compare $package_type "apm_service"] && ![string compare $singleton_p "t"]} { - # This is a singleton package. Instantiate it automatically. - if {[catch { - db_exec_plsql package_instantiate_mount { - declare - instance_id apm_packages.package_id%TYPE; - begin - instance_id := apm_package.new( - instance_name => :package_name, - package_key => :package_key, - context_id => acs.magic_object_id('default_context') - ); - end; - } - } errmsg]} { - apm_callback_and_log $callback "[string totitle $package_key] not instantiated.[ad_quotehtml $errmsg]
Error: -
" - } else { - apm_callback_and_log $callback "[string totitle $package_key] instantiated as $package_key.[ad_quotehtml $errmsg]
" - } + + # Source Tcl procs and queries to be able + # to invoke any Tcl callbacks after mounting and instantiation. Note that this reloading + # is only done in the Tcl interpreter of this particular request. + apm_load_libraries -procs -force_reload -packages $package_key + apm_load_queries -packages $package_key + + if { $upgrade_p } { + # Run before-upgrade + apm_invoke_callback_proc -version_id $version_id -type before-upgrade -arg_list [list from_version_name $upgrade_from_version_name to_version_name $version(name)] + } else { + # Run before-install + apm_invoke_callback_proc -version_id $version_id -type before-install } + + if { $load_data_model_p } { + apm_package_install_data_model -callback $callback -data_model_files $data_model_files $spec_file_path + } + + # Enable the package + if { $enable_p } { + nsv_set apm_enabled_package $package_key 1 + + apm_version_enable -callback $callback $version_id + } + + # Instantiating, mounting, and after-install callback only invoked on initial install + if { ! $upgrade_p } { + # After install Tcl proc callback + apm_invoke_callback_proc -version_id $version_id -type after-install + + set priority_mount_path [ad_decode $version(auto-mount) "" $mount_path $version(auto-mount)] + if { ![empty_string_p $priority_mount_path] } { + # This is a package that should be auto mounted + + set parent_id [site_node::get_node_id -url "/"] + + if { [catch { + db_transaction { + set node_id [site_node::new -name $priority_mount_path -parent_id $parent_id] + } + } error] } { + # There is already a node with that path, check if there is a package mounted there + array set node [site_node::get -url "/${priority_mount_path}"] + 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 { + # Don't unmount already mounted packages + set node_id "" + } + } + + if { ![empty_string_p $node_id] } { + + ns_log Notice "Mounting new instance of package $package_key at /${priority_mount_path}" + site_node::instantiate_and_mount \ + -node_id $node_id \ + -node_name $priority_mount_path \ + -package_name $version(package-name) \ + -package_key $package_key + + apm_callback_and_log $callback "
Mounted an instance of the package at /${priority_mount_path}
" + } { + # Another package is mounted at the path so we cannot mount + global errorInfo + set error_text "Package $version(package-name) could not be mounted at /$version(auto-mount) , there may already me a package mounted there, the error is: $error" + ns_log Error "$error_text \n\n$errorInfo" + apm_callback_and_log $callback "$error_text
" + } + + } elseif { [string equal $package_type "apm_service"] && [string equal $singleton_p "t"] } { + # This is a singleton package. Instantiate it automatically, but don't mount. + + # Using empty context_id + ns_log Notice "Creating singleton instance of package $package_key" + apm_package_instance_new $version(package-name) "" $package_key + } + } else { + # After upgrade Tcl proc callback + apm_invoke_callback_proc -version_id $version_id -type after-upgrade -arg_list [list from_version_name $upgrade_from_version_name to_version_name $version(name)] + } + + # Flush the installed_p cache + util_memoize_flush [list apm_package_installed_p_not_cached $package_key] + return $version_id } ad_proc -private apm_package_install_version { - { - -callback apm_dummy_callback - -version_id "" - } - package_key version_name version_uri summary description description_format vendor vendor_uri {release_date ""} + {-callback apm_dummy_callback} + {-version_id ""} + package_key version_name version_uri summary description description_format vendor vendor_uri auto_mount {release_date ""} } { - Installs a version of a package into the ACS. + Installs a version of a package. + @return The assigned version id. } { if { [empty_string_p $version_id] } { @@ -422,24 +562,11 @@ set release_date [db_null] } - return [db_exec_plsql version_insert { - begin - :1 := apm_package_version.new( - version_id => :version_id, - package_key => :package_key, - version_name => :version_name, - version_uri => :version_uri, - summary => :summary, - description_format => :description_format, - description => :description, - release_date => :release_date, - vendor => :vendor, - vendor_uri => :vendor_uri, - installed_p => 't', - data_model_loaded_p => 't' - ); - end; - }] + return [db_exec_plsql version_insert {}] + + # Every package provides by default the service that is the package itself + # This spares the developer from having to visit the dependency page + apm_interface_add $version_id $package_key $version_name } @@ -506,13 +633,14 @@ end; } # Remove the files from the filesystem - if {$remove_files_p == 1} { + if {$remove_files_p==1} { if { [catch { file delete -force [acs_package_root_dir $package_key] } error] } { apm_callback_and_log $callback "Done." } @@ -563,7 +691,7 @@ set data_model_files [apm_data_model_scripts_find \ -upgrade_from_version_name $upgrade_from_version_name \ -upgrade_to_version_name $upgrade_to_version_name \ - $package_key $version(files)] + $package_key] } if { ![empty_string_p $data_model_files] } { @@ -753,40 +881,23 @@ } } -ad_proc -private apm_package_install_queries { +ad_proc -private apm_package_install_callbacks { {-callback apm_dummy_callback} - package_key - files + callback_list + version_id } { - Given a spec file, reads in the data model files to load from it. + Install the Tcl proc callbacks for the package version. - @param package_key The package key from the .info file. - @param files List of files for this package from the package's .info file - @author Don Baccus (dhogaza@pacifier.com) - - This replaces the brute-force version originally provided by - Ben, which manually searched the package directories rather than - use the package information file. - + @author Peter Marklund } { - set path "[acs_package_root_dir $package_key]" + db_dml delete_all_callbacks { + delete from apm_package_callbacks + where version_id = :version_id + } - - ns_log Notice "APM/QD = loading up package query files for $package_key" - set ul_p 0 - - foreach query_file [apm_query_files_find $package_key $files] { - ns_log Debug "APM/QD: Now processing query file $query_file" - if { !$ul_p } { - apm_callback_and_log $callback "
Package disabled." } - ad_proc -public apm_package_register { - package_key pretty_name pretty_plural package_uri package_type initial_install_p singleton_p {spec_file_path ""} {spec_file_mtime ""} + {-spec_file_path ""} + {-spec_file_mtime ""} + package_key + pretty_name + pretty_plural + package_uri + package_type + initial_install_p + singleton_p } { Register the package in the system. } { @@ -903,35 +1021,9 @@ } if { ![string compare $package_type "apm_application"] } { - db_exec_plsql application_register { - begin - apm.register_application ( - package_key => :package_key, - package_uri => :package_uri, - pretty_name => :pretty_name, - pretty_plural => :pretty_plural, - initial_install_p => :initial_install_p, - singleton_p => :singleton_p, - spec_file_path => :spec_file_path, - spec_file_mtime => :spec_file_mtime - ); - end; - } + db_exec_plsql application_register {} } elseif { ![string compare $package_type "apm_service"] } { - db_exec_plsql service_register { - begin - apm.register_service ( - package_key => :package_key, - package_uri => :package_uri, - pretty_name => :pretty_name, - pretty_plural => :pretty_plural, - initial_install_p => :initial_install_p, - singleton_p => :singleton_p, - spec_file_path => :spec_file_path, - spec_file_mtime => :spec_file_mtime - ); - end; - } + db_exec_plsql service_register {} } else { error "Unrecognized package type: $package_type" } @@ -941,31 +1033,16 @@ { -callback apm_dummy_callback } - version_id version_name version_uri summary description description_format vendor vendor_uri {release_date ""} + version_id version_name version_uri summary description description_format vendor vendor_uri auto_mount {release_date ""} } { Update a version in the system to new information. } { if { [empty_string_p $release_date] } { set release_date [db_null] } - return [db_exec_plsql apm_version_update { - begin - :1 := apm_package_version.edit( - version_id => :version_id, - version_name => :version_name, - version_uri => :version_uri, - summary => :summary, - description_format => :description_format, - description => :description, - release_date => :release_date, - vendor => :vendor, - vendor_uri => :vendor_uri, - installed_p => 't', - data_model_loaded_p => 't' - ); - end; - }] + + return [db_exec_plsql apm_version_update {}] } @@ -976,8 +1053,6 @@ } { Loads the data model, installs, enables, instantiates, and mounts all of the packages in pkg_list. - Each package is mounted at /package-key. - } { foreach pkg_info $pkg_info_list { @@ -988,58 +1063,17 @@ set version_id [apm_version_enable -callback $callback \ [apm_package_install -callback $callback $spec_file]] } errmsg] } { - apm_callback_and_log $callback "
[string totitle $package_key] not installed. + global errorInfo + apm_callback_and_log -severity Error $callback "
[string totitle $package_key] not installed.
Error: -
" +[ad_quotehtml $errmsg]
" } } } -ad_proc -private apm_package_instantiate_and_mount { - { - -callback apm_dummy_callback - } package_key} { - - Automatically instantiate and mount a package of the indicated type. - -} { -# Instantiate and mount the package. - if { [catch { - db_exec_plsql package_instantiate_and_mount { - declare - main_site_id site_nodes.node_id%TYPE; - instance_id apm_packages.package_id%TYPE; - node_id site_nodes.node_id%TYPE; - begin - main_site_id := site_node.node_id('/'); - - instance_id := apm_package.new( - package_key => :package_key, - context_id => main_site_id - ); - - node_id := site_node.new( - parent_id => main_site_id, - name => :package_key, - directory_p => 't', - pattern_p => 't', - object_id => instance_id - ); - end; - } - } errmsg]} { - apm_callback_and_log $callback "[string totitle $package_key] not mounted.[ad_quotehtml $errmsg][ad_quotehtml $errorInfo]
Error: -
" - } else { - apm_callback_and_log $callback "[string totitle $package_key] mounted at /$package_key/.[ad_quotehtml $errmsg]
" - } -} - ad_proc -private apm_package_upgrade_p {package_key version_name} { - @return 1 if a version of the indicated package_key of version lower than version_name \ is already installed in the system, 0 otherwise. - } { return [db_string apm_package_upgrade_p { select apm_package_version.version_name_greater(:version_name, version_name) upgrade_p @@ -1049,6 +1083,22 @@ } -default 0] } +ad_proc -private apm_package_upgrade_from { package_key version_name } { + @param package_key The package you're installing + @param version_name The version of the package you're installing + @return the version of the package currently installed, which we're upgrading from, if it's + different from the version_name passed in. If this is not an upgrade, returns the empty string. +} { + return [db_string apm_package_upgrade_from { + select version_name + from apm_package_versions + where package_key = :package_key + and version_id = apm_package.highest_version(:package_key) + and version_name != :version_name + } -default ""] +} + + ad_proc -private apm_version_upgrade {version_id} { Upgrade a package to a locally maintained later version. @@ -1116,7 +1166,7 @@ ad_proc -private apm_data_model_scripts_find { {-upgrade_from_version_name ""} {-upgrade_to_version_name ""} - package_key file_list + package_key } { @param version_id What version the files belong to. @param upgrade Set this switch if you want the scripts for upgrading. @@ -1130,10 +1180,10 @@ } set data_model_list [list] set upgrade_file_list [list] - foreach file $file_list { - set path [lindex $file 0] - set file_type [lindex $file 1] - set file_db_type [lindex $file 2] + set file_list [apm_get_package_files -file_types $types_to_retrieve -package_key $package_key] + foreach path $file_list { + set file_type [apm_guess_file_type $package_key $path] + set file_db_type [apm_guess_db_type $package_key $path] apm_log APMDebug "APM: Checking \"$path\" of type \"$file_type\" and db_type \"$file_db_type\"." # DRB: we return datamodel files which match the given database type or for which no db_type @@ -1158,6 +1208,7 @@ } set file_list [concat [apm_order_upgrade_scripts $upgrade_file_list] $data_model_list] apm_log APMDebug "APM: Data model scripts for $package_key: $file_list" + ns_log Notice "pm debug APM: Data model scripts for $package_key: $file_list" return $file_list } @@ -1189,3 +1240,185 @@ ns_log Notice "APM: Query files for $package_key: $query_file_list" return $query_file_list } + +ad_proc -private apm_mount_core_packages {} { +
+ Mount, and set permissions for a number of packages + part of the OpenACS core. The packages are singletons that have + already been instantiated during installation. The main site + needs to have been set up prior to invoking this proc. +
+ ++ The reason mounting is done here and not via the auto-mount + feature of the APM is that there is a circular dependency between + acs-subsite and acs-content-repository. The package acs-subsite + requires acs-content-repository and so we cannot install acs-subsite + before acs-content-repository in order to be able to mount acs-content-repository. +
+ + @author Peter Marklund +} { + ns_log Notice "Starting instantiation and mounting of core packages" + + # Mount acs-admin + ns_log Notice "Mounting acs-admin" + site_node::instantiate_and_mount -package_key acs-admin + + # Mount acs-service-contract + ns_log Notice "Mounting acs-service-contract" + site_node::instantiate_and_mount -package_key acs-service-contract + + # Mount the acs-content-repository + ns_log Notice "Mounting acs-content-repository" + site_node::instantiate_and_mount -package_key acs-content-repository + + # Mount acs-core-docs + ns_log Notice "Mounting acs-core-docs" + site_node::instantiate_and_mount -node_name doc \ + -package_key acs-core-docs + + # Mount the acs-api-browser + ns_log Notice "Mounting acs-api-browser" + set api_browser_id \ + [site_node::instantiate_and_mount -node_name api-doc \ + -package_key acs-api-browser] + # Only registered users should have permission to access the + # api-browser + permission::grant -party_id [acs_magic_object registered_users] \ + -object_id $api_browser_id \ + -privilege read + permission::set_not_inherit -object_id $api_browser_id + + ns_log Notice "Core packages instantiated and mounted" +} + +ad_proc -private apm_version_name_compare { + version_name_1 + version_name_2 +} { + Compare two version names (e.g. '1.2d3' and '3.5b') as for which comes before which. The example here would return -1. + @param version_name_1 the first version name + @param version_name_2 the second version name + @return 1 if version_name_1 comes after version_name_2, 0 if they are the same, -1 if version_name_1 comes before version_name_2. + @author Lars Pind +} { + db_1row select_sortable_versions {} + return [string compare $sortable_version_1 $sortable_version_2] +} + +ad_proc -public apm_version_names_compare { + version_name_1 + version_name_2 +} { + Compare two version names (e.g. '1.2d3' and '3.5b') as for which comes before which. The example here would return -1. + @param version_name_1 the first version name + @param version_name_2 the second version name + @return 1 if version_name_1 comes after version_name_2, 0 if they are the same, -1 if version_name_1 comes before version_name_2. + + @author Lars Pind +} { + db_1row select_sortable_versions {} + return [string compare $sortable_version_1 $sortable_version_2] +} + +ad_proc -private apm_upgrade_logic_compare { + from_to_key_1 + from_to_key_2 +} { + Compare the from-versions in two of apm_upgrade_logic's array entries on the form 'from_version_name,to_version_name'. + + @param from_to_key the key from the array in apm_upgrade_logic + @return 1 if 1 comes after 2, 0 if they are the same, -1 if 1 comes before 2. + + @author Lars Pind +} { + return [apm_version_names_compare [lindex [split $from_to_key_1 ","] 0] [lindex [split $from_to_key_2 ","] 0]] +} + +ad_proc -public apm_upgrade_logic { + {-from_version_name:required} + {-to_version_name:required} + {-spec:required} +} { + Logic to help upgrade a package. + The spec contains a list on the form \{ from_version to_version code_chunk from_version to_version code_chunk ... \}. + The list is compared against the from_version_name and to_version_name parameters supplied, and the code_chunks that + fall within the from_version_name and to_version_name it'll get executed in the caller's namespace, ordered by the from_version. + ++ + Example: + +
+
+ apm_upgrade_logic \
+ -from_version_name $from \
+ -to_version_name $to \
+ -spec {
+ 1.1 1.2 {
+ ...
+ }
+ 1.2 1.3 {
+ ...
+ }
+ 1.4d 1.4d1 {
+ ...
+ }
+ 2.1 2.3 {
+ ...
+ }
+ 2.3 2.4 {
+ ...
+ }
+ }
+
+ Saves a list of files that have changed (and thus marked to be reloaded) in
- the variable named $file_info_var, if provided. Each element
- of this list is of the form:
+ @param file_list A list of paths relative to acs_root_dir
+ @param force_reload Mark the files for reload even if their modification
+ time in the nsv cache doesn't differ from the one
+ in the filesystem.
-
+ @return The list of files marked for reload. + @author Peter Marklund } { - if { ![empty_string_p $file_info_var] } { - upvar $file_info_var file_info - } - - db_1row package_key_select "select package_key from apm_package_version_info where version_id = :version_id" - set changed_files [list] - set file_info [list] + foreach relative_path $file_list { + set full_path "[acs_root_dir]/$relative_path" - db_foreach file_info { - select file_id, path - from apm_package_files - where version_id = :version_id - and file_type in ('tcl_procs', 'query_file') - and (db_type is null or db_type = '[db_type]') - order by path - } { - set full_path "[acs_package_root_dir $package_key]/$path" - set relative_path "packages/$package_key/$path" - # If the file exists, and either has never been loaded or has an mtime # which differs the mtime it had when last loaded, mark to be loaded. if { [file isfile $full_path] } { set mtime [file mtime $full_path] - if { ![nsv_exists apm_library_mtime $relative_path] || \ - [nsv_get apm_library_mtime $relative_path] != $mtime } { + if { $force_reload_p || (![nsv_exists apm_library_mtime $relative_path] || \ + [nsv_get apm_library_mtime $relative_path] != $mtime) } { + lappend changed_files $relative_path - lappend file_info [list $file_id $path $relative_path] - nsv_set apm_library_mtime $relative_path $mtime } - } + } } if { [llength $changed_files] > 0 } { set reload [nsv_incr apm_properties reload_level] nsv_set apm_reload $reload $changed_files } + + return $changed_files } +ad_proc -private apm_mark_version_for_reload { version_id { changed_files_var "" } } { + + Examines all tcl_procs files in package version $version_id; if any have + changed since they were loaded, marks (in the apm_reload array) that + they must be reloaded by each Tcl interpreter (using the + apm_load_any_changed_libraries procedure). + +[list $file_id $path]
Saves a list of files that have changed (and thus marked to be reloaded) in
+ the variable named $file_info_var, if provided. Each element
+ of this list is the path of a reloaded file, relative to the web server root
+ (e.g., packages/package-key/tcl/foo-procs.tcl)
+} {
+ if { ![empty_string_p $changed_files_var] } {
+ upvar $changed_files_var changed_files
+ }
+
+ set package_key [apm_package_key_from_version_id $version_id]
+
+ set changed_files [list]
+
+ set file_types [list tcl_procs query_file]
+ if { [apm_load_tests_p] } {
+ lappend file_types test_procs
+ }
+
+ foreach path [apm_get_package_files -package_key $package_key -file_types $file_types] {
+
+ set full_path "[acs_package_root_dir $package_key]/$path"
+ set relative_path "packages/$package_key/$path"
+
+ set reload_file [apm_mark_files_for_reload $relative_path]
+ if { [llength $reload_file] > 0 } {
+ # The file marked for reload
+ lappend changed_files $relative_path
+ }
+ }
+}
+
ad_proc -private apm_version_load_status { version_id } {
If a version needs to be reloaded (i.e., a -procs.tcl has changed
@@ -212,13 +238,12 @@
return "never_loaded"
}
- db_1row package_key_select {
- select package_key
- from apm_package_version_info
- where version_id = :version_id
+ set package_key [apm_package_key_from_version_id $version_id]
+ set procs_types [list tcl_procs]
+ if { [apm_load_tests_p] } {
+ lappend procs_types test_procs
}
-
- foreach file [apm_version_file_list -type "tcl_procs" -db_type [db_type] $version_id] {
+ foreach file [apm_get_package_files -package_key $package_key -file_types $procs_types] {
# If $file has never been loaded, i.e., it has been added to the version
# since the version was initially loaded, return needs_reload.
if { ![nsv_exists apm_library_mtime "packages/$package_key/$file"] } {
@@ -234,7 +259,7 @@
}
}
- foreach file [apm_version_file_list -type "query_file" -db_type [db_type] $version_id] {
+ foreach file [apm_get_package_files -package_key $package_key -file_types "query_file"] {
# If $file has never been loaded, i.e., it has been added to the version
# since the version was initially loaded, return needs_reload.
if { ![nsv_exists apm_library_mtime "packages/$package_key/$file"] } {
@@ -254,9 +279,13 @@
}
ad_proc -private apm_load_libraries {
+ {-force_reload:boolean 0}
+ {-packages {}}
{-callback apm_dummy_callback}
{-procs:boolean}
{-init:boolean}
+ {-test_procs:boolean}
+ {-test_init:boolean}
} {
Loads all -procs.tcl (if $procs_or_init is "procs") or -init.tcl (if $procs_or_init is
@@ -266,16 +295,10 @@
to in *all* active interpreters).
} {
-
- # DRB: query extractor's dumb about repeated query
- # names so I changed these to be unique. We should
- # really be sharing these at some level rather than
- # duping them anyway.
- set packages [db_list apm_enabled_packages_l {
- select distinct package_key
- from apm_package_versions
- where enabled_p='t'
- }]
+
+ if { [empty_string_p $packages] } {
+ set packages [apm_enabled_packages]
+ }
# Scan the package directory for files to source.
set files [list]
@@ -297,8 +320,16 @@
set paths [concat $paths [glob -nocomplain "$dir/*init.tcl"]]
set paths [concat $paths [glob -nocomplain "$dir/*init-[db_type].tcl"]]
}
+ if {$test_procs_p} {
+ set paths [concat $paths [glob -nocomplain "$dir/test/*procs.tcl"]]
+ set paths [concat $paths [glob -nocomplain "$dir/test/*procs-[db_type].tcl"]]
+ }
+ if {$test_init_p} {
+ set paths [concat $paths [glob -nocomplain "$dir/test/*init.tcl"]]
+ set paths [concat $paths [glob -nocomplain "$dir/test/*init-[db_type].tcl"]]
+ }
}
-
+
foreach path [lsort $paths] {
set rel_path [string range $path $base_len end]
lappend files [list $package $rel_path]
@@ -308,23 +339,91 @@
# Release all outstanding database handles (since the file we're sourcing
# might be using the ns_db database API as opposed to the new db_* API).
db_release_unused_handles
- apm_files_load -callback $callback $files
+ apm_files_load -force_reload=$force_reload_p -callback $callback $files
}
-# OpenACS query loading (ben@mit.edu)
-# Load up the queries for all packages
-#
-# This follows the pattern of the load_libraries proc,
-# but is only loading query information
+ad_proc -public apm_load_tests_p {} {
+ Determine whether to load acs-automated-testing tests
+ for packages.
+
+ @return 1 if tests should be loaded and 0 otherwise
+
+ @author Peter Marklund
+} {
+ return [apm_package_enabled_p "acs-automated-testing"]
+}
+
+ad_proc -public apm_load_packages {
+ {-force_reload:boolean 0}
+ {-load_libraries_p 1}
+ {-load_queries_p 1}
+ {-packages {}}
+} {
+ Load Tcl libraries and queries for the packages with given keys. Only
+ loads procs into the current interpreter. Will
+ load Tcl tests if the acs-automated-testing package is enabled.
+
+ @param force_reload Reload Tcl libraries even if they are already loaded.
+ @param load_libraries Switch to indicate if Tcl libraries in (-procs.tcl and -init.tcl)
+ files should be loaded. Defaults to true.
+ @param load_queries Switch to indicate if xql query files should be loaded. Default true.
+ @param packages A list of package_keys for packages to be loaded. Defaults to
+ all enabled packages
+
+ @see apm_mark_version_for_reload
+
+ @author Peter Marklund
+} {
+ if { [empty_string_p $packages] } {
+ set packages [apm_enabled_packages]
+ }
+
+ # Should acs-automated-testing tests be loaded?
+ set load_tests_p [apm_load_tests_p]
+
+ # Load *-procs.tcl files
+ if { $load_libraries_p } {
+ apm_load_libraries -force_reload=$force_reload_p -packages $packages -procs
+ }
+
+ # Load up the Queries (OpenACS, ben@mit.edu)
+ if { $load_queries_p } {
+ apm_load_queries -packages $packages
+ }
+
+ # Load up the Automated Tests and associated Queries if necessary
+ if {$load_tests_p} {
+ apm_load_libraries -force_reload=$force_reload_p -packages $packages -test_procs
+ apm_load_queries -packages $packages -test_queries
+ }
+
+ if { $load_libraries_p } {
+ apm_load_libraries -force_reload=$force_reload_p -init -packages $packages
+ }
+
+ # Load up the Automated Tests initialisation scripts if necessary
+ if {$load_tests_p} {
+ apm_load_libraries -force_reload=$force_reload_p -packages $packages -test_init
+ }
+}
+
ad_proc -private apm_load_queries {
+ {-packages {}}
{-callback apm_dummy_callback}
+ {-test_queries:boolean}
} {
- set packages [db_list apm_enabled_packages_q {
- select distinct package_key
- from apm_package_versions
- where enabled_p='t'
- }]
+ Load up the queries for all enabled packages
+ (or all specified packages). Follows the pattern
+ of the load_libraries proc, but only loads query information
+ @param packages Optional list of keys for packages to load queries for.
+
+ @author ben@mit.edu
+} {
+ if { [empty_string_p $packages] } {
+ set packages [apm_enabled_packages]
+ }
+
# Scan the package directory for files to source.
set files [list]
foreach package $packages {
@@ -334,12 +433,33 @@
ns_log Error "apm_load_queries: Unable to locate [acs_root_dir]/packages/$package/*. when scanning for SQL queries to load."
}
+ set testdir "[acs_root_dir]/packages/$package/tcl/test"
+ set testlength [string length $testdir]
+
foreach file [lsort $files] {
set file_db_type [apm_guess_db_type $package $file]
set file_type [apm_guess_file_type $package $file]
- if {[string equal $file_type query_file] &&
+ if {![string compare -length $testlength $testdir $file]} {
+ set is_test_file_p 1
+ } else {
+ set is_test_file_p 0
+ }
+
+ #
+ # Note this exclusive or represents the following:
+ # test_queries_p - Load normal xql files or load test xql files
+ # is_test_file_p - Current file is a test file or not.
+ #
+ # !(test_queries_p ^ is_test_file_p) = Load it or not?
+ # !( 0 ^ 0 ) = Yep
+ # !( 0 ^ 1 ) = Nope
+ # !( 1 ^ 0 ) = Nope
+ # !( 1 ^ 1 ) = Yep
+ #
+ if {![expr $test_queries_p ^ $is_test_file_p] &&
+ [string equal $file_type query_file] &&
([empty_string_p $file_db_type] || [string equal $file_db_type [db_type]])} {
db_qd_load_query_file $file
}
@@ -454,7 +574,6 @@
query_file { db_qd_load_query_file [acs_root_dir]/$file }
}
- nsv_set apm_library_mtime $file [file mtime $file_path]
set reloaded_files($file) 1
}
}
@@ -503,25 +622,45 @@
package_key
} {
Returns 1 if there is an installed package version corresponding to the package_key,
- 0 otherwise
+ 0 otherwise. Uses a cached value for performance.
} {
- return [db_string apm_package_installed_p {
- select 1 from apm_package_versions
- where package_key = :package_key
- and installed_p = 't'
- } -default 0]
+ if { [util_memoize_initialized_p] } {
+ return [util_memoize [list apm_package_installed_p_not_cached $package_key]]
+ } else {
+ return [apm_package_installed_p_not_cached $package_key]
+ }
}
+ad_proc -private apm_package_installed_p_not_cached {
+ package_key
+} {
+ return [db_string apm_package_installed_p {} -default 0]
+}
+
+ad_proc -public apm_package_enabled_p {
+ package_key
+} {
+ Returns 1 if there is an enabled package version corresponding to the package_key
+ and 0 otherwise.
+} {
+ return [db_string apm_package_enabled_p {} -default 0]
+}
+
+ad_proc -public apm_enabled_packages {} {
+ Returns a list of package_key's for all enabled packages.
+
+ @author Peter Marklund
+} {
+ return [db_list enabled_packages {}]
+}
+
+
ad_proc -public apm_version_installed_p {
version_id
} {
@return Returns 1 if the specified version_id is installed, 0 otherwise.
} {
- return [db_string apm_version_installed_p {
- select 1 from apm_package_versions
- where version_id = :version_id
- and installed_p = 't'
- } -default 0]
+ return [db_string apm_version_installed_p {} -default 0]
}
ad_proc -public apm_highest_version {package_key} {
@@ -759,6 +898,23 @@
}
#
+# package_id -> instance_name
+#
+
+ad_proc -public apm_instance_name_from_id {package_id} {
+ @return The name of the instance.
+} {
+ return [util_memoize "apm_instance_name_from_id_mem $package_id"]
+}
+
+proc apm_instance_name_from_id_mem {package_id} {
+ return [db_string apm_package_key_from_id {
+ select instance_name from apm_packages where package_id = :package_id
+ } -default ""]
+}
+
+
+#
# package_key -> package_id
#
@@ -813,6 +969,44 @@
return [apm_package_url_from_id $package_id]
}
+#
+# package_key -> version_id
+#
+
+ad_proc -public apm_version_id_from_package_key { package_key } {
+ Return the id of the enabled version of the given package_key.
+ If no such version id can be found, returns the empty string.
+
+ @author Peter Marklund
+} {
+ return [db_string get_id {} -default ""]
+}
+
+#
+# version_id -> package_key
+#
+
+ad_proc -public apm_package_key_from_version_id {version_id} {
+ Returns the package_key for the given APM package version id. Goes to the database
+ the first time called and then uses a cached value. Calls the proc apm_package_key_from_version_id_mem.
+
+ @author Peter Marklund (peter@collaboraid.biz)
+} {
+ return [util_memoize "apm_package_key_from_version_id_mem $version_id"]
+
+}
+
+ad_proc -private apm_package_key_from_version_id_mem {version_id} {
+ Returns the package_key for the given APM package version id. Goes to the database
+ everytime called.
+
+ @author Peter Marklund (peter@collaboraid.biz)
+} {
+ return [db_string apm_package_id_from_key {
+ select package_key from apm_package_version_info where version_id = :version_id
+ } -default 0]
+}
+
ad_proc -public apm_version_info {version_id} {
Sets a set of common package information in the caller's environment.
@@ -832,23 +1026,15 @@
@return 1 if the indiciated package version is installed, 0 otherwise.
} {
- return [db_string apm_package_version_installed_p {
- select decode(count(*), 0, 0, 1) from apm_package_versions
- where package_key = :package_key
- and version_name = :version_name
- } -default 0]
+ return [db_string apm_package_version_installed_p {}]
}
ad_proc -public apm_package_version_enabled_p {version_id} {
@return 1 if the indiciated package version is installed, 0 otherwise.
} {
- return [db_string apm_package_version_installed_p {
- select decode(count(*), 0, 0, 1) from apm_package_versions
- where version_id = :version_id
- and enabled_p = 't'
- } -default 0]
+ return [db_string apm_package_version_enabled_p {}]
}
@@ -874,76 +1060,339 @@
}
-ad_proc -public apm_package_create_instance {
- {
- -package_id 0
+ad_proc -public -deprecated -warn apm_package_create_instance {
+ {-package_id 0}
+ instance_name
+ context_id
+ package_key
+} {
+ Creates a new instance of a package. Deprecated - please use
+ apm_package_instance_new instead.
+
+ @see apm_package_instance_new
+} {
+ return [apm_package_instance_new -package_id $package_id \
+ $instance_name \
+ $context_id \
+ $package_key]
+}
+
+ad_proc -public apm_set_callback_proc {
+ {-version_id ""}
+ {-package_key ""}
+ {-type:required}
+ proc
+} {
+ Set the name of an APM Tcl procedure callback for a certain package version.
+ Checks if the callback already exists and updates if it does.
+ If version_id is not supplied the id of the currently enabled version
+ of the package will be used.
+
+ @see apm_supported_callback_types
+
+ @author Peter Marklund
+} {
+ apm_assert_callback_type_supported $type
+
+ if { [empty_string_p $version_id] } {
+ if { [empty_string_p $package_key] } {
+ error "apm_set_package_callback_proc: Invoked with both version_id and package_key empty. You must supply either of these"
+ }
+
+ set version_id [apm_version_id_from_package_key $package_key]
}
- instance_name context_id package_key
+
+ set current_proc [apm_get_callback_proc -type $type -version_id $version_id]
+
+ if { [empty_string_p $current_proc] } {
+ # We are adding
+ db_dml insert_proc {}
+ } else {
+ # We are editing
+ db_dml update_proc {}
+ }
+}
+
+ad_proc -public apm_get_callback_proc {
+ {-type:required}
+ {-package_key ""}
+ {-version_id ""}
} {
+ Return Tcl procedure name for the callback of a certain
+ type for the given package. If no callback proc for the
+ given type is present returns the empty string.
- Creates a new instance of a package.
+ @see apm_supported_callback_types
+ @author Peter Marklund
} {
- if {$package_id == 0} {
- set package_id [db_null]
- }
+ apm_assert_callback_type_supported $type
- set package_id [db_exec_plsql apm_package_instance_new {
- begin
- :1 := apm_package.new(
- package_id => :package_id,
- instance_name => :instance_name,
- package_key => :package_key,
- context_id => :context_id
- );
- end;
+ if { [empty_string_p $version_id] } {
+ set version_id [apm_version_id_from_package_key $package_key]
+ }
+
+ return [db_string select_proc {} -default ""]
+}
+
+ad_proc -public apm_remove_callback_proc {
+ {-type:required}
+ {-package_key:required}
+} {
+ Remove the callback of a certain type for the given package.
+
+ @author Peter Marklund
+} {
+ apm_assert_callback_type_supported $type
+
+ return [db_dml delete_proc {}]
+}
+
+ad_proc -public apm_unused_callback_types {
+ {-version_id:required}
+} {
+ Get a list enumerating the supported callback types
+ that are not used by the given package version.
+} {
+ set used_callback_types [db_list used_callback_types {
+ select distinct type
+ from apm_package_callbacks
+ where version_id = :version_id
}]
-
- apm_parameter_sync $package_key $package_id
+
+ set supported_types [apm_supported_callback_types]
+
+ set unused_types [list]
+ foreach supported_type $supported_types {
+ if { [lsearch -exact $used_callback_types $supported_type] < 0 } {
+ lappend unused_types $supported_type
+ }
+ }
+
+ return $unused_types
+}
+
+ad_proc -public apm_invoke_callback_proc {
+ {-version_id ""}
+ {-package_key ""}
+ {-arg_list {}}
+ {-type:required}
+} {
+ Invoke the Tcl callback proc of a given type
+ for a given package version. Any errors during
+ invocation are logged.
+
+ @return 1 if invocation
+ was carried out successfully, 0 if no proc to invoke could
+ be found. Will propagate any error thrown by the callback.
+
+ @author Peter Marklund
+} {
+ array set arg_array $arg_list
+
+ set proc_name [apm_get_callback_proc \
+ -version_id $version_id \
+ -package_key $package_key \
+ -type $type]
- return $package_id
+ if { [empty_string_p $proc_name] } {
+ if { [string equal $type "after-instantiate"] } {
+ # We check for the old proc on format: package_key_post_instantiation package_id
+ if { [empty_string_p $package_key] } {
+ set package_key [apm_package_key_from_version_id $version_id]
+ }
+ set proc_name [apm_post_instantiation_tcl_proc_from_key $package_key]
+ if { [empty_string_p $proc_name] } {
+ # No callback and no old-style callback proc - no options left
+ return 0
+ }
+
+ $proc_name $arg_array(package_id)
+
+ return 1
+
+ } else {
+ # No other callback procs to fall back on
+ return 0
+ }
+ }
+
+ # We have a non-empty name of a callback proc to invoke
+ # Form the full command including arguments
+ set command "${proc_name} [apm_callback_format_args -type $type -arg_list $arg_list]"
+
+ # We are ready for invocation
+ ns_log Notice "Invoking callback $type with command $command"
+ eval $command
+
+ return 1
}
+ad_proc -public apm_assert_callback_type_supported { type } {
+ Throw an error if the given callback type is not supported.
-ad_proc -public apm_package_call_post_instantiation_proc {
- package_id
- package_key
+ @author Peter Marklund
} {
+ if { ![apm_callback_type_supported_p $type] } {
+ error "The supplied callback type $type is not supported. Supported types are: [apm_supported_callback_types]"
+ }
+}
- Call the package-specific post instantiation proc, if any
+ad_proc -public apm_callback_type_supported_p { type } {
+ Return 1 if the given type of callback is supported and 0
+ otherwise.
+ @author Peter Marklund
} {
+ return [expr [lsearch -exact [apm_supported_callback_types] $type] >= 0]
+}
- # Check for a post-instantiation TCL procedure
- set procedure_name [apm_post_instantiation_tcl_proc_from_key $package_key]
- if { ![empty_string_p $procedure_name] } {
- with_catch errmsg {
- $procedure_name $package_id
- } {
- ns_log Error "APM: Post-instantiation procedure, $procedure_name, failed: $errmsg"
- }
+ad_proc -public apm_callback_format_args {
+ {-version_id ""}
+ {-package_key ""}
+ {-type:required}
+ {-arg_list {}}
+} {
+ Return a string on format -arg_name1 arg_value1 -arg_name2 arg_value2 ...
+ for the callback proc of given type.
+
+ @author Peter Marklund
+} {
+ array set args_array $arg_list
+
+ set arg_string ""
+ set provided_arg_names [array names args_array]
+ foreach required_arg_name [apm_arg_names_for_callback_type -type $type] {
+ if { [lsearch -exact $provided_arg_names $required_arg_name] < 0 } {
+ error "required argument $required_arg_name not supplied to callback proc of type $type"
+ }
+
+ append arg_string " -${required_arg_name} $args_array($required_arg_name)"
}
-
+
+ return $arg_string
}
-ad_proc -public apm_package_instance_new {
- {
- -package_id 0
+ad_proc -public apm_arg_names_for_callback_type {
+ {-type:required}
+} {
+ Return the list of required argument names for the given callback type.
+
+ @author Peter Marklund
+} {
+ array set arguments {
+ after-instantiate {
+ package_id
+ }
+ before-uninstantiate {
+ package_id
+ }
+ before-unmount {
+ package_id
+ node_id
+ }
+ after-mount {
+ package_id
+ node_id
+ }
+ before-upgrade {
+ from_version_name
+ to_version_name
+ }
+ after-upgrade {
+ from_version_name
+ to_version_name
+ }
}
- instance_name context_id package_key
+
+ if { [info exists arguments($type)] } {
+ return $arguments($type)
+ } else {
+ return {}
+ }
+}
+
+ad_proc -public apm_supported_callback_types {} {
+ Gets the list of package callback types
+ that are supported by the system.
+ Each callback type represents a certain event or time
+ when a Tcl procedure should be invoked, such as after-install
+
+ @author Peter Marklund
} {
+ return [list before-install after-install after-instantiate after-mount before-uninstantiate before-uninstall before-unmount before-upgrade after-upgrade]
+}
+ad_proc -private apm_callback_has_valid_args {
+ {-type:required}
+ {-proc_name:required}
+} {
+ Returns 1 if the specified callback proc of a certain
+ type has a valid argument list in its definition and 0
+ otherwise. Assumes that the callback proc is defined with
+ ad_proc.
+
+ @author Peter Marklund
+} {
+
+ if { [empty_string_p [info procs ::${proc_name}]] } {
+ return 0
+ }
+
+ set test_arg_list ""
+ foreach arg_name [apm_arg_names_for_callback_type -type $type] {
+ append test_arg_list " -${arg_name} value"
+ }
+
+ if { [empty_string_p $test_arg_list] } {
+ # The callback proc should take no args
+ return [empty_string_p [info args ::${proc_name}]]
+ }
+
+ # The callback proc should have required arg switches. Check
+ # that the ad_proc arg parser doesn't throw an error with
+ # test arg list
+ if { [catch {
+ set args $test_arg_list
+ ::${proc_name}__arg_parser
+ } errmsg] } {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+ad_proc -public apm_package_instance_new {
+ {-package_id 0}
+ instance_name
+ context_id
+ package_key
+} {
+
Creates a new instance of a package and call the post instantiation proc, if any.
- DRB: I split out the subpieces into two procs because the subsite post instantiation proc
- needs to be able to find the package's node in the site node map, which results in a
- cart-before-the-horse scenario. The code can't update the site node map until after the
- package is created yet the original code called the post instantiation proc before the
- site node code could update the table.
+ @param instance_name The name of the package instance, defaults to the pretty name of the
+ package type.
+ @return The id of the instantiated package
} {
- set package_id [apm_package_create_instance -package_id $package_id $instance_name $context_id $package_key]
- apm_package_call_post_instantiation_proc $package_id $package_key
+ if { [empty_string_p $instance_name] } {
+ set instance_name [db_string pretty_name_from_key {select pretty_name
+ from apm_enabled_package_versions
+ where package_key = :package_key}]
+ }
+
+ if {$package_id == 0} {
+ set package_id [db_null]
+ }
+
+ set package_id [db_exec_plsql invoke_new {}]
+
+ apm_parameter_sync $package_key $package_id
+
+ apm_invoke_callback_proc -package_key $package_key -type "after-instantiate" -arg_list [list package_id $package_id]
+
+ return $package_id
}
ad_proc apm_parameter_sync {package_key package_id} {
@@ -972,7 +1421,11 @@
package_id
} {
Deletes an instance of a package
-} {
+} {
+ apm_invoke_callback_proc -package_key [apm_package_key_from_id $package_id] \
+ -type before-uninstantiate \
+ -arg_list [list package_id $package_id]
+
db_exec_plsql apm_package_instance_delete {}
}
Index: openacs-4/packages/acs-tcl/tcl/apm-procs.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/apm-procs.xql,v
diff -u -N -r1.5.2.1 -r1.5.2.2
--- openacs-4/packages/acs-tcl/tcl/apm-procs.xql 16 Oct 2002 00:36:09 -0000 1.5.2.1
+++ openacs-4/packages/acs-tcl/tcl/apm-procs.xql 5 Mar 2003 14:40:42 -0000 1.5.2.2
@@ -1,22 +1,14 @@
+ NOTE: This proc doesn't do anything anymore. +
+ ++ Loads XML packages into the running interpreter, if they're not + already there. We need to load these packages once per connection, + since AOLserver doesn't seem to deal with packages very well. +
+ +} { + global ad_conn + if { ![info exists ad_conn(xml_loaded_p)] } { + # ns_xml needs to be loaded + +# foreach file [glob "[acs_package_root_dir acs-tcl]/tcl/xml-*-procs.tcl"] { +# apm_source $file +# } + set ad_conn(xml_loaded_p) 1 + } + +# package require xml 1.9 +} + ad_proc -private apm_required_attribute_value { element attribute } { Returns an attribute of an XML element, throwing an error if the attribute @@ -68,15 +94,12 @@ Generates an XML-formatted specification for a version of a package. } { - set spec "" - db_1row package_version_select { - select t.package_key, t.package_uri, t.pretty_name, t.pretty_plural, t.package_type, - t.initial_install_p, t.singleton_p, v.* - from apm_package_versions v, apm_package_types t - where v.version_id = :version_id - and v.package_key = t.package_key - } + 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 "" "" "files: a list of files in the package,
containing elements of the form [list $path
$type]
+ callbacks: an array list of callbacks of the package
+ on the form [list callback_type1 proc_name1 callback_type2 proc_name2 ...]
Element and attribute values directly from the XML specification:
package.key,
package.url,
package.type
pretty-plural
initial-install-p
singleton-p
+ auto-mount
name (the version name, e.g., 3.3a1,
url (the version URL),
package-name,
@@ -296,6 +311,7 @@
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(singleton-p) [apm_tag_value -default "f" $package singleton-p]
+ set properties(auto-mount) [apm_tag_value -default "" $package auto-mount]
set properties(pretty-plural) [apm_tag_value -default "$properties(package-name)s" $package pretty-plural]
@@ -383,7 +399,7 @@
# Validate the file type: it must be null (unknown type) or
# some value in [apm_file_type_keys].
if { ![empty_string_p $type] && [lsearch -exact [apm_file_type_keys] $type] < 0 } {
- error "Invalid file type \"$type\""
+ ns_log Warning "Unrecognized file type \"$type\" of file $file_path"
}
# Validate the database type: it must be null (unknown type) or
# some value in [apm_db_type_keys].
@@ -394,6 +410,38 @@
}
}
+ # 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 { [lsearch -exact [apm_supported_callback_types] $type] < 0 } {
+ # 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]
Index: openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl,v
diff -u -N -r1.16.2.8 -r1.16.2.9
--- openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl 16 Feb 2003 23:59:08 -0000 1.16.2.8
+++ openacs-4/packages/acs-tcl/tcl/form-processing-procs.tcl 5 Mar 2003 14:40:42 -0000 1.16.2.9
@@ -149,6 +149,10 @@
being served.
+ -cancel_url
+
The URL the cancel button should take you to. If this is specified, a cancel button will show up.
+
+
-html
The given html will be added to the "form" tag when page is rendered. This is commonly used to
define multipart file handling forms.
@@ -179,9 +183,16 @@
-edit_request
A code block which sets the values for each element of the form meant to be modifiable by the user. Use
- this when a single query to grab database values is insufficient.
+ this when a single query to grab database values is insufficient. You just need to set the values as local
+ variables in the code block, and they'll get fetched and used as element values for you.
+ -new_request
+
A code block which initializes elements for a new row. Use this to set default values.
+ You just need to set the values as local
+ variables in the code block, and they'll get fetched and used as element values for you.
+
+
-confirm_template
The name of a confirmation template to be called before any on_submit, new_data or edit_data block. When
the user confirms input control will be passed to the appropriate submission block. The confirmation
@@ -320,11 +331,11 @@
- start_date:date,to_sql(sql_date),from_html(sql_date),optional
+ start_date:date,to_sql(sql_date),to_html(sql_date),optional
Define the optional element "start_date" of type "date", get the sql_date property before executing
- any new_date, edit_date or on_submit block, set the sql_date property after performing any
+ any new_data, edit_data or on_submit block, set the sql_date property after performing any
select_query.
@@ -349,9 +360,9 @@
return -code error "No arguments to ad_form"
}
- set valid_args { form method action html name select_query select_query_name new_data on_refresh
+ set valid_args { form method action mode html name select_query select_query_name new_data on_refresh
edit_data validate on_submit after_submit confirm_template new_request edit_request
- export};
+ export cancel_url cancel_label has_edit actions };
ad_arg_parser $valid_args $args
@@ -389,7 +400,7 @@
# and validation block to be extended, for now at least until I get more experience
# with this ...
- if { [lsearch { name form method action html validate export } $valid_arg ] == -1 } {
+ if { [lsearch { name form method action html validate export mode cancel_url has_edit actions } $valid_arg ] == -1 } {
set af_parts(${form_name}__extend) ""
}
}
@@ -425,6 +436,10 @@
array set af_element_parameters [list]
if { [info exists form] } {
+
+ # Remove comment lines in form section (DanW)
+ regsub -all -line -- {^\s*\#.*$} $form "" form
+
foreach element $form {
set element_name_part [lindex $element 0]
@@ -470,16 +485,20 @@
set af_validate_elements($form_name) [list]
if { [info exists validate] } {
+
+ # Remove comment lines in validate section (DanW)
+ regsub -all -line -- {^\s*\#.*$} $validate "" validate
+
foreach validate_element $validate {
if { [llength $validate_element] != 3 } {
return -code error "Validate block must have three arguments: element name, expression, error message"
}
- if { [lsearch $af_element_names($form_name) [lindex $validate_element 0]] == -1 } {
- return -code error "Element \"[lindex $validate_element 0]\" is not a form element"
+ if { [lsearch $af_element_names($form_name) [lindex $validate_element 0]] == -1 } {
+ return -code error "Element \"[lindex $validate_element 0]\" is not a form element"
}
lappend af_validate_elements($form_name) $validate_element
- }
+ }
}
if { !$extend_p } {
@@ -493,10 +512,30 @@
lappend create_command "-method" $method
}
+ if { [info exists mode] } {
+ lappend create_command "-mode" $mode
+ }
+
+ if { [info exists cancel_url] } {
+ lappend create_command "-cancel_url" $cancel_url
+ }
+
+ if { [info exists cancel_label] } {
+ lappend create_command "-cancel_label" $cancel_label
+ }
+
if { [info exists html] } {
lappend create_command "-html" $html
}
+ if { [info exists has_edit] } {
+ lappend create_command "-has_edit" $has_edit
+ }
+
+ if { [info exists actions] } {
+ lappend create_command "-actions" $actions
+ }
+
# Create the form
eval $create_command
@@ -624,9 +663,14 @@
help_text -
label -
format -
+ mode -
value -
+ section -
before_html -
- after_html {
+ after_html -
+ result_datatype -
+ search_query -
+ search_query_name {
if { [llength $extra_arg] > 2 || [llength $extra_arg] == 1 } {
return -code error "element $element_name: \"$extra_arg\" requires exactly one argument"
}
@@ -692,16 +736,16 @@
return -code error "Edit request block conflicts with select query"
}
ad_page_contract_eval uplevel #$level $edit_request
-
- # set form vars from edit_request block
+ # set form vars from edit_request block
foreach element_name $af_element_names($form_name) {
if { [llength $element_name] == 1 } {
if { [uplevel \#$level [list info exists $element_name]] } {
set values($element_name) [uplevel \#$level [list set $element_name]]
}
}
- }
+ }
+
} else {
# The key exists, grab the existing values if we have an select_query clause
@@ -752,6 +796,14 @@
if { [info exists new_request] } {
ad_page_contract_eval uplevel #$level $new_request
+ # LARS: Set form values based on local vars in the new_request block
+ foreach element_name $af_element_names($form_name) {
+ if { [llength $element_name] == 1 } {
+ if { [uplevel \#$level [list info exists $element_name]] } {
+ set values($element_name) [uplevel \#$level [list set $element_name]]
+ }
+ }
+ }
}
}
Index: openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl,v
diff -u -N -r1.4 -r1.4.2.1
--- openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 16 Sep 2002 22:30:46 -0000 1.4
+++ openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 5 Mar 2003 14:40:42 -0000 1.4.2.1
@@ -136,6 +136,14 @@
}
}
+ad_proc -public util_memoize_initialized_p {} {
+ Return 1 if the util_memoize cache has been initialized
+ and is ready to be used and 0 otherwise.
+
+ @author Peter Marklund
+} {
+ return [ad_decode [catch {ns_cache set util_memoize __util_memoize_installed_p 1} error] 0 1 0]
+}
ad_proc -public util_memoize_flush_regexp {
-log:boolean
Index: openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl,v
diff -u -N -r1.7.2.3 -r1.7.2.4
--- openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl 27 Feb 2003 15:41:23 -0000 1.7.2.3
+++ openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl 5 Mar 2003 14:40:42 -0000 1.7.2.4
@@ -93,7 +93,8 @@
set context [list]
if {[ad_conn user_id] != 0 && ![string match /pvt/home* [ad_conn url]]} {
- lappend context [list "[ad_pvt_home]" "[ad_pvt_home_name]"]
+ # LARS: Removed for collaboraid.biz
+ #lappend context [list "[ad_pvt_home]" "[ad_pvt_home_name]"]
}
Index: openacs-4/packages/acs-tcl/tcl/site-node-apm-integration-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/site-node-apm-integration-procs.tcl,v
diff -u -N -r1.4 -r1.4.2.1
--- openacs-4/packages/acs-tcl/tcl/site-node-apm-integration-procs.tcl 10 Sep 2002 22:22:14 -0000 1.4
+++ openacs-4/packages/acs-tcl/tcl/site-node-apm-integration-procs.tcl 5 Mar 2003 14:40:42 -0000 1.4.2.1
@@ -11,29 +11,23 @@
namespace eval site_node_apm_integration {
- ad_proc -public new_site_node_and_package {
+ ad_proc -public -deprecated -warn new_site_node_and_package {
{-name:required}
{-parent_id:required}
{-package_key:required}
{-instance_name:required}
{-context_id:required}
} {
- create site node, instantiate package, mount package at new site node
- } {
- db_transaction {
- set node_id [site_node::new -name $name -parent_id $parent_id]
+ Create site node, instantiate package, mount package at new site node. Deprecated -
+ please use site_node::instantiate_and_mount instead.
- set package_id [apm_package_create_instance $instance_name $context_id $package_key]
-
- site_node::mount -node_id $node_id -object_id $package_id
-
- site_node::update_cache -node_id $node_id
-
- # call post instantiation proc for the package
- apm_package_call_post_instantiation_proc $package_id $package_key
- }
-
- return $package_id
+ @see site_node::instantiate_and_mount
+ } {
+ return [site_node::instantiate_and_mount -parent_node_id $parent_id \
+ -node_name $name \
+ -package_name $instance_name \
+ -context_id $context_id \
+ -package_key $package_key]
}
ad_proc -public delete_site_nodes_and_package {
Index: openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl,v
diff -u -N -r1.17.2.4 -r1.17.2.5
--- openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 2 Feb 2003 21:19:26 -0000 1.17.2.4
+++ openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 5 Mar 2003 14:40:42 -0000 1.17.2.5
@@ -49,13 +49,81 @@
} {
db_dml mount_object {}
update_cache -node_id $node_id
+
+ apm_invoke_callback_proc -package_key [apm_package_key_from_id $object_id] -type "after-mount" -arg_list [list node_id $node_id package_id $object_id]
}
+ ad_proc -public instantiate_and_mount {
+ {-node_id ""}
+ {-parent_node_id ""}
+ {-node_name ""}
+ {-package_name ""}
+ {-context_id ""}
+ {-package_key:required}
+ } {
+ Instantiate and mount a package of given type.
+
+ @param node_id The id of the node in the site map where the package should be mounted.
+ If not specified a new node under the main site will be created.
+ @param parent_node_id If no node_id is specified this will be the parent node under which the
+ new node is created. Defaults to the main site node id.
+ @param node_name If node_id is not specified then this will be the name of the
+ new site node that is created. Defaults to package_key.
+ @param package_name The name of the new package instance. Defaults to pretty name of package type.
+ @param context_id The context_id of the package. Defaults to the package_id at the parent
+ node in the site map. If there is no such package then context_id will be the
+ id of the parent node itself.
+ @param package_key The key of the package type to instantiate.
+
+ @return The id of the instantiated package
+
+ @author Peter Marklund
+ } {
+ # Create a new node if none was provided
+ if { [empty_string_p $node_id] } {
+ if { [empty_string_p $parent_node_id ] } {
+ set parent_node_id [site_node::get_node_id -url "/"]
+ }
+
+ # Default node_name to package_key
+ set node_name [ad_decode $node_name "" $package_key $node_name]
+
+ set node_id [site_node::new -name $node_name -parent_id $parent_node_id]
+ }
+
+ # Get the context_id of the new package
+ if {[empty_string_p $context_id]} {
+ # Attempt to use the package_id at the parent node
+ if { [empty_string_p $parent_node_id] } {
+ set parent_node_id [site_node::get_parent_id -node_id $node_id]
+ }
+ array set node [site_node::get -node_id $parent_node_id]
+ set context_id $node(object_id)
+
+ if {[empty_string_p $context_id]} {
+ # No package at parent node, so use the id of the node itself instead
+ # Should we use default_context here instead?
+ set context_id $parent_node_id
+ }
+ }
+
+ # Instantiate the package
+ set package_id [apm_package_instance_new $package_name $context_id $package_key]
+
+ # Mount the package
+ site_node::mount -node_id $node_id -object_id $package_id
+
+ return $package_id
+ }
+
ad_proc -public unmount {
{-node_id:required}
} {
unmount an object from the site node
} {
+ set package_id [get_object_id -node_id $node_id]
+ apm_invoke_callback_proc -package_key [apm_package_key_from_id $package_id] -type before-unmount -arg_list [list package_id $package_id node_id $node_id]
+
db_dml unmount_object {}
update_cache -node_id $node_id
}
@@ -114,7 +182,7 @@
either url or node_id is required, if both are passed url is ignored
The array elements are: package_id, package_key, object_type, directory_p,
- instance_namem, pattern_p, parent_id, node_id, object_id, url.
+ instance_name, pattern_p, parent_id, node_id, object_id, url.
} {
if {[empty_string_p $url] && [empty_string_p $node_id]} {
error "site_node::get \"must pass in either url or node_id\""
@@ -276,9 +344,16 @@
return $node(object_id)
}
+
}
-ad_proc -deprecated site_node_create {
+##############
+#
+# Deprecated Procedures
+#
+#############
+
+ad_proc -deprecated -warn site_node_create {
{-new_node_id ""}
{-directory_p "t"}
{-pattern_p "t"}
@@ -297,7 +372,7 @@
]
}
-ad_proc -deprecated site_node_create_package_instance {
+ad_proc -deprecated -warn site_node_create_package_instance {
{ -package_id 0 }
{ -sync_p "t" }
node_id
@@ -306,26 +381,19 @@
package_key
} {
Creates a new instance of the specified package and flushes the
- in-memory site map (if sync_p is t).
+ in-memory site map (if sync_p is t). This proc is deprecated, please use
+ site_node::instantiate_and_mount instead.
- DRB: I've modified this so it doesn't call the package's post instantiation proc until
- after the site node map is updated. Delaying the call in this way allows the package to
- find itself in the map. The code that mounts a subsite, in particular, needs to be able
- to do this so it can find the nearest parent node that defines an application group (the
- code in aD ACS 4.2 was flat-out broken).
-
@author Michael Bryzek (mbryzek@arsdigita.com)
+ @see site_node::instantiate_and_mount
@creation-date 2001-02-05
@return The package_id of the newly mounted package
} {
- set package_id [apm_package_create_instance $instance_name $context_id $package_key]
-
- site_node::mount -node_id $node_id -object_id $package_id
-
- apm_package_call_post_instantiation_proc $package_id $package_key
-
- return $package_id
+ return [site_node::instantiate_and_mount -node_id $node_id \
+ -package_name $instance_name \
+ -context_id $context_id \
+ -package_key $package_key]
}
ad_proc -public site_node_delete_package_instance {
@@ -343,7 +411,7 @@
}
}
-ad_proc -public site_node_mount_application {
+ad_proc -public -deprecated -warn site_node_mount_application {
{-sync_p "t"}
{-return "package_id"}
parent_node_id
@@ -352,7 +420,8 @@
instance_name
} {
Creates a new instance of the specified package and mounts it
- beneath parent_node_id.
+ beneath parent_node_id. Deprecated - please use the proc
+ site_node::instantiate_and_mount instead.
@author Michael Bryzek (mbryzek@arsdigita.com)
@creation-date 2001-02-05
@@ -367,24 +436,14 @@
@param instance_name The name we want to give the package we are
mounting (used for the context bar string etc).
+ @see site_node::instantiate_and_mount
+
@return The package id of the newly mounted package
} {
- # if there is an object mounted at the parent_node_id then use that
- # object_id, instead of the parent_node_id, as the context_id
- array set node [site_node::get -node_id $parent_node_id]
- set context_id $node(object_id)
-
- if {[empty_string_p $context_id]} {
- set context_id $parent_node_id
- }
-
- return [site_node_apm_integration::new_site_node_and_package \
- -name $url_path_component \
- -parent_id $parent_node_id \
- -package_key $package_key \
- -instance_name $instance_name \
- -context_id $context_id \
- ]
+ return [site_node::instantiate_and_mount -parent_node_id $parent_node_id \
+ -node_name $url_path_component
+ -package_name $instance_name \
+ -package_key $package_key]
}
ad_proc -public site_map_unmount_application {
@@ -412,7 +471,7 @@
}
}
-ad_proc -deprecated site_node {url} {
+ad_proc -deprecated -warn site_node {url} {
Returns an array in the form of a list. This array contains
url, node_id, directory_p, pattern_p, and object_id for the
given url. If no node is found then this will throw an error.
Index: openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl,v
diff -u -N -r1.9.2.4 -r1.9.2.5
--- openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl 27 Jan 2003 10:30:57 -0000 1.9.2.4
+++ openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl 5 Mar 2003 14:40:42 -0000 1.9.2.5
@@ -16,12 +16,17 @@
ad_proc -public ad_text_to_html {
-no_links:boolean
+ -no_lines:boolean
+ -no_quote:boolean
text
} {
Converts plaintext to html. Also translates any recognized
email addresses or URLs into a hyperlink.
@param no_links will prevent it from highlighting
+ @param no_quote will prevent it from HTML-quoting output, so this can be run on
+ semi-HTML input and preserve that formatting. This will also cause spaces/tabs to not be
+ replaced with nbsp's, because this can too easily mess up HTML tags.
@author Branimir Dolicki (branimir@arsdigita.com)
@author Lars Pind (lars@pinds.com)
@@ -39,11 +44,14 @@
# (bd) The only purpose of thiese sTaRtUrL and
# eNdUrL markers is to get rid of trailing dots,
# commas and things like that. Note that there
- # is a TAB before and after each marker.
+ # is a \x001 special char before and after each marker.
- regsub -nocase -all {([^a-zA-Z0-9]+)(http://[^\(\)"<>\s]+)} $text "\\1\tsTaRtUrL\\2eNdUrL\t" text
- regsub -nocase -all {([^a-zA-Z0-9]+)(https://[^\(\)"<>\s]+)} $text "\\1\tsTaRtUrL\\2eNdUrL\t" text
- regsub -nocase -all {([^a-zA-Z0-9]+)(ftp://[^\(\)"<>\s]+)} $text "\\1\tsTaRtUrL\\2eNdUrL\t" text
+ regsub -nocase -all {([^a-zA-Z0-9]+)(http://[^\(\)"<>\s]+)} $text "\\1\x001sTaRtUrL\\2eNdUrL\x001" text
+ regsub -nocase -all {([^a-zA-Z0-9]+)(https://[^\(\)"<>\s]+)} $text "\\1\x001sTaRtUrL\\2eNdUrL\x001" text
+ regsub -nocase -all {([^a-zA-Z0-9]+)(ftp://[^\(\)"<>\s]+)} $text "\\1\x001sTaRtUrL\\2eNdUrL\x001" text
+
+ # Don't dress URLs that are already links
+ regsub -nocase -all {(href\s*=\s*['"]?)\x001sTaRtUrL([^\x001]*)eNdUrL\x001} $text {\1\2} text
# email links have the form xxx@xxx.xxx
# JCD: don't treat things =xxx@xxx.xxx as email since most
@@ -52,50 +60,81 @@
# work correctly). It's all quite ugly.
regsub -nocase -all {([^a-zA-Z0-9=]+)(mailto:)?([^=\(\)\s:;,@<>]+@[^\(\)\s.:;,@<>]+[.][^\(\)\s:;,@<>]+)} $text \
- "\\1\tsTaRtEmAiL\\3eNdEmAiL\t" text
-
-
+ "\\1\x001sTaRtEmAiL\\3eNdEmAiL\x001" text
}
# At this point, before inserting some of our own <, >, and "'s
# we quote the ones entered by the user:
- set text [ad_quotehtml $text]
+ if { !$no_quote_p } {
+ set text [ad_quotehtml $text]
+ }
- # Convert _single_ CRLF's to
's to preserve line breaks
- regsub -all {\r*\n} $text "
\n" text
+ # Convert line breaks
+ if { !$no_lines_p } {
+ set text [util_convert_line_breaks_to_html $text]
+ }
- # Convert every two spaces to an nbsp
- regsub -all { } $text "\\\ " text
-
- # turn CRLFCRLF into
- if { [regsub -all {\r\n\s*\r\n} $text "
" text] == 0 } {
- # try LFLF
- if { [regsub -all {\n\s*\n} $text "
" text] == 0 } {
- # try CRCR
- regsub -all {\r\s*\r} $text "
" text
- }
+ if { !$no_quote_p } {
+ # Convert every two spaces to an nbsp
+ regsub -all { } $text "\\\ " text
+
+ # Convert tabs to four nbsp's
+ regsub -all {\t} $text {\ \ \ \ } text
}
-
+
if { !$no_links_p } {
+ # Move the end of the link before any punctuation marks at the end of the URL
+ regsub -all {([]!?.:;,<>\(\)\}"'-]+)(eNdUrL\x001)} $text {\2\1} text
+ regsub -all {([]!?.:;,<>\(\)\}"'-]+)(eNdEmAiL\x001)} $text {\2\1} text
+
# Dress the links and emails with A HREF
- regsub -all {([]!?.:;,<>\(\)\}"'-]+)(eNdUrL\t)} $text {\2\1} text
- regsub -all {([]!?.:;,<>\(\)\}"'-]+)(eNdEmAiL\t)} $text {\2\1} text
- regsub -all {\tsTaRtUrL([^\t]*)eNdUrL\t} $text {\1} text
- regsub -all {\tsTaRtEmAiL([^\t]*)eNdEmAiL\t} $text {\1} text
+ regsub -all {\x001sTaRtUrL([^\x001]*)eNdUrL\x001} $text {\1} text
+ regsub -all {\x001sTaRtEmAiL([^\x001]*)eNdEmAiL\x001} $text {\1} text
set text [string trimleft $text]
}
- # Convert every tab to 4 nbsp's
- regsub -all {\t} $text {\ \ \ \ } text
-
# JCD: Remove all the eNd sTaRt stuff and warn if we do it since its bad
# to have these left (means something is broken in our regexps above)
- if {[regsub -all {(sTaRtUrL|eNdUrL|sTaRtEmAiL|eNdEmAiL)} $text {} text]} {
+ if {[regsub -all {(\x001sTaRtUrL|eNdUrL\x001|\x001sTaRtEmAiL|eNdEmAiL\x001)} $text {} text]} {
ns_log warning "Replaced sTaRt/eNd magic tags in ad_text_to_html"
}
+
return $text
}
+ad_proc -public util_convert_line_breaks_to_html {
+ text
+} {
+ Convert line breaks to
and
tags, respectively.
+} {
+ # Remove any leading or trailing whitespace
+ regsub {^[\s]*} $text {} text
+ regsub {[\s]*$} $text {} text
+
+ # Make sure all line breaks are single \n's
+ regsub -all {\r\n} $text "\n" text
+ regsub -all {\r} $text "\n" text
+
+ # Remove whitespace around \n's
+ regsub -all {\s+\n\s+} $text "\n" text
+
+ # Wrap P's around paragraphs
+ set text "
$text
"
+ regsub -all {([^\n\s])\n\n([^\n\s])} $text {\1\2} text
+
+ # Convert _single_ CRLF's to
's to preserve line breaks
+ # Lars: This must be done after we've made P tags, because otherwise the line
+ # breaks will already have been converted into BR's.
+ regsub -all {\n} $text "
\n" text
+
+ # Add line breaks to P tags
+ regsub -all {
} $text "\n" text
+
+ return $text
+}
+
+
+
ad_proc -public ad_quotehtml { arg } {
Quotes ampersands, double-quotes, and angle brackets in $arg.
@@ -1156,8 +1195,9 @@
####################
ad_proc -public ad_html_text_convert {
- {-from text}
- {-to html}
+ {-from text/plain}
+ {-to text/html}
+ {-maxlen 70}
text
} {
Converts a chunk of text from text/html to text/html.
@@ -1174,46 +1214,91 @@
@author Lars Pind (lars@pinds.com)
@creation-date 19 July 2000
} {
+ set valid_froms { text/enhanced text/plain text/fixed-width text/html }
+ set valid_tos { text/plain text/html }
+
+ # Validate procedure input
+ set from [ad_decode $from "html" "text/html" "text" "text/plain" "plain" "text/plain" $from]
+ if { [lsearch $valid_froms $from] == -1 } {
+ error "Unknown text input format, '$from'. Valid formats are $valid_froms."
+ }
+
+ set to [ad_decode $to "html" "text/html" "text" "text/plain" "plain" "text/plain" $to]
+ if { [lsearch $valid_tos $to] == -1 } {
+ error "Unknown text input format, '$to'. Valid formats are $valid_tos."
+ }
+
+ # Do the conversion
switch $from {
- text/html -
- html {
+ text/enhanced {
switch $to {
- text/html -
- html {
- ad_html_security_check $text
- return [util_close_html_tags $text]
+ text/html {
+ set text [ad_enhanced_text_to_html $text]
}
- text/plain -
- text {
- return [ad_html_to_text -- $text]
+ text/plain {
+ set text [ad_enhanced_text_to_plain_text $text]
}
- default {
- return -code error "Can only convert to text or html"
+ }
+ }
+ text/plain {
+ switch $to {
+ text/html {
+ set text [ad_text_to_html -- $text]
}
+ text/plain {
+ set text [wrap_string $text $maxlen]
+ }
}
- }
- text/plain -
- text {
+ }
+ text/fixed-width {
switch $to {
- text/html -
- html {
- return [ad_text_to_html -- $text]
+ text/html {
+ set text "[ad_text_to_html -no_lines -- $text]
"
}
- text/plain -
- text {
- return [wrap_string $text 70]
+ text/plain {
+ set text [wrap_string $text $maxlen]
}
- default {
- return -code error "Can only convert to text or html"
+ }
+ }
+ text/html {
+ switch $to {
+ text/html {
+ set text [util_close_html_tags $text]
}
+ text/plain {
+ set text [ad_html_to_text -maxlen $maxlen -- $text]
+ }
}
}
- default {
- return -code error "Can only convert from text or html"
- }
}
+
+ return $text
}
+ad_proc -public ad_enhanced_text_to_html {
+ text
+} {
+ Converts enhanced text format to normal HTML.
+ @author Lars Pind (lars@pinds.com)
+ @creation-date 2003-01-27
+} {
+ return [ad_text_to_html -no_quote -- [util_close_html_tags $text]]
+}
+
+ad_proc -public ad_enhanced_text_to_plain_text {
+ {-maxlen 70}
+ text
+} {
+ Converts enhanced text format to normal plaintext format.
+ @author Lars Pind (lars@pinds.com)
+ @creation-date 2003-01-27
+} {
+ # Convert the HTML version to plaintext.
+ return [ad_html_to_text -maxlen $maxlen -- [ad_enhanced_text_to_html $text]]
+}
+
+
+
ad_proc -public ad_convert_to_html {
{-html_p f}
text
Index: openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl,v
diff -u -N -r1.19.2.6 -r1.19.2.7
--- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 20 Feb 2003 16:17:13 -0000 1.19.2.6
+++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 5 Mar 2003 14:40:42 -0000 1.19.2.7
@@ -612,9 +612,10 @@
-form:boolean
-url:boolean
-quotehtml:boolean
+ -entire_form:boolean
{-exclude {}}
{-override {}}
- vars
+ {vars {}}
} {
Exports variables either in URL or hidden form variable format. It should replace
[export_vars -override { { sort_by $column } } $my_vars]
, and sorting will be done according to
the new value of column.
+
+ + + If the variable name contains a colon (:), that colon must be escaped with a backslash, + so for example "form:id" becomes "form\:id". Sorry. @param sign Sign all variables. @param url Export in URL format. This is the default. @param form Export in form format. You can't specify both URL and form format. + @param quotehtml HTML quote the entire resulting string. This is an interim solution + while we're waiting for the templating system to do the quoting for us. + + @param entire_form Export the entire form from the GET query string or the POST. + @author Lars Pind (lars@pinds.com) @creation-date December 7, 2000 } { @@ -748,6 +759,21 @@ set url_p 1 } + if { $entire_form_p } { + set the_form [ns_getform] + if { ![empty_string_p $the_form] } { + set form_var_list [list] + for {set i 0} {$i<[ns_set size $the_form]} {incr i} { + set varname [ns_set key $the_form $i] + set varvalue [ns_set value $the_form $i] + lappend form_var_list [list $varname $varvalue] + } + # We simply prepend this to the existing vars list. + # That way, the -exclude and -override arguments will still work + set vars [concat $form_var_list $vars] + } + } + ##### # # Parse the arguments @@ -771,7 +797,15 @@ if { [llength $var_spec] > 2 } { return -code error "A varspec must have either one or two elements." } + + # Hide escaped colons for below split + regsub -all {\\:} $var_spec "!!cOlOn!!" var_spec + set name_spec [split [lindex $var_spec 0] ":"] + + # Replace escaped colons with single colon + regsub -all {!!cOlOn!!} $name_spec ":" name_spec + set name [lindex $name_spec 0] # If we've already encountered this varname, ignore it @@ -1267,9 +1301,25 @@ +ad_proc -public util_get_current_url {} { + Returns a URL for re-issuing the current request, with query variables. + If a form submission is present, that is converted into query vars as well. + @return URL for the current page + @author Lars Pind (lars@pinds.com) + @creation-date February 11, 2003 +} { + set url [ad_conn url] + set query [ns_getform] + if { $query != "" } { + append url "?[export_entire_form_as_url_vars]" + } + + return $url +} + proc with_catch {error_var body on_error} { upvar 1 $error_var $error_var global errorInfo errorCode @@ -1520,6 +1570,19 @@ return [expr { [info exists var] && ![empty_string_p $var] }] } +ad_proc -public exists_and_equal { varname value } { + Returns 1 if the variable name exists in the caller's envirnoment + and is equal to the given value. + + @see exists_and_not_null + + @author Peter Marklund +} { + upvar 1 $varname var + + return [expr { [info exists var] && [string equal $var $value] } ] +} + ad_proc -public ad_httpget { -url {-headers ""}