Index: openacs-4/packages/acs-tcl/tcl/apm-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/apm-procs.tcl,v
diff -u -r1.115 -r1.116
--- openacs-4/packages/acs-tcl/tcl/apm-procs.tcl 12 Feb 2019 17:12:18 -0000 1.115
+++ openacs-4/packages/acs-tcl/tcl/apm-procs.tcl 3 Sep 2024 15:37:34 -0000 1.116
@@ -151,7 +151,7 @@
ns_log $severity [ad_html_to_text -maxlen 140 -- $message]
}
-ad_proc apm_one_package_descendents {
+ad_proc -private apm_one_package_descendents {
package_key
} {
@@ -265,7 +265,7 @@
lappend ::apm_package_inherit_order $package_key
}
-ad_proc apm_one_package_load_libraries_dependencies {
+ad_proc -private apm_one_package_load_libraries_dependencies {
package_key
} {
@@ -349,7 +349,6 @@
return [nsv_get apm_package_url_resolution $package_key]
}
-
ad_proc apm_package_load_libraries_order {
package_key
} {
@@ -358,6 +357,19 @@
return [nsv_get apm_package_load_libraries_order $package_key]
}
+ad_proc -private apm_package_singleton_p {
+ package_key
+} {
+ @return boolean telling whether a package is a singleton or not
+} {
+ return [acs::per_thread_cache eval -key acs-tcl.apm-singleton-$package_key {
+ db_string check_singleton {
+ select singleton_p from apm_package_types
+ where package_key = :package_key
+ } -default f
+ }]
+}
+
ad_proc -public apm_version_loaded_p { version_id } {
Returns 1 if a version of a package has been loaded and initialized, or 0 otherwise.
@@ -366,7 +378,7 @@
return [nsv_exists apm_version_init_loaded_p $version_id]
}
-ad_proc -private apm_mark_files_for_reload {
+ad_proc -public apm_mark_files_for_reload {
{-force_reload:boolean}
file_list
} {
@@ -389,8 +401,8 @@
# 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 { [ad_file isfile $full_path] } {
+ set mtime [ad_file mtime $full_path]
if { $force_reload_p
|| (![nsv_exists apm_library_mtime $relative_path]
|| [nsv_get apm_library_mtime $relative_path] != $mtime
@@ -412,7 +424,7 @@
proc ::foo0 {} {return 0}
-ad_proc -private apm_mark_version_for_reload {
+ad_proc -public apm_mark_version_for_reload {
version_id
{ changed_files_var "" }
} {
@@ -453,7 +465,7 @@
return $changed_files
}
-ad_proc -private apm_version_load_status { version_id } {
+ad_proc -public apm_version_load_status { version_id } {
If a version needs to be reloaded (i.e., a -procs.tcl
has changed
or been added since the version was loaded), returns "needs_reload".
@@ -481,8 +493,8 @@
set full_path "[acs_package_root_dir $package_key]/$file"
# If $file had a different mtime when it was last loaded, return
# needs_reload. (If the file should exist but doesn't, just skip it.)
- if { [file exists $full_path]
- && [file mtime $full_path] ne [nsv_get apm_library_mtime "packages/$package_key/$file"]
+ if { [ad_file exists $full_path]
+ && [ad_file mtime $full_path] ne [nsv_get apm_library_mtime "packages/$package_key/$file"]
} {
return "needs_reload"
}
@@ -498,8 +510,8 @@
set full_path "[acs_package_root_dir $package_key]/$file"
# If $file had a different mtime when it was last loaded, return
# needs_reload. (If the file should exist but doesn't, just skip it.)
- if { [file exists $full_path]
- && [file mtime $full_path] ne [nsv_get apm_library_mtime "packages/$package_key/$file"]
+ if { [ad_file exists $full_path]
+ && [ad_file mtime $full_path] ne [nsv_get apm_library_mtime "packages/$package_key/$file"]
} {
return "needs_reload"
}
@@ -521,8 +533,8 @@
Loads all -procs.tcl (if $procs_or_init is "procs") or -init.tcl files into the
current interpreter for installed, enabled packages. Only loads
files which have not yet been loaded. This is intended to be called only during server
- initialization (since it loads libraries only into the running interpreter, as opposed
- to in *all* active interpreters).
+ initialization, since it loads libraries only into the running interpreter, as opposed
+ to in *all* active interpreters.
} {
set file_types [list]
@@ -577,32 +589,35 @@
{-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.
+ Load Tcl libraries and queries for the packages with given
+ keys into the current interpreter. Will load Tcl
+ tests when the acs-automated-testing package is enabled.
@param force_reload Reload Tcl libraries even if they are already loaded.
@param load_libraries_p Switch to indicate if Tcl libraries in (-procs.tcl and -init.tcl)
- files should be loaded. Defaults to true.
+ files should be loaded. Defaults to true.
@param load_queries_p 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. These packages, along with the packages
- they depend on, will be loaded in dependency-order using the
- information provided in the packages' "provides" and "requires"
- attributes.
+ all enabled packages. These packages, along with the packages
+ they depend on, will be loaded in dependency-order using the
+ information provided via the "provides" and "requires" definitions.
@see apm_mark_version_for_reload
@author Peter Marklund
} {
+ set enabled_packages [apm_enabled_packages]
if { $packages eq "" } {
- set packages [apm_enabled_packages]
+ set packages $enabled_packages
}
set packages_to_load [list]
foreach package_key $packages {
foreach package_to_load [::apm_package_load_libraries_order $package_key] {
- if {$package_to_load ni $packages_to_load} {
+ #
+ # Never add packages, which are not enabled.
+ #
+ if {$package_to_load ni $packages_to_load && $package_to_load in $enabled_packages} {
lappend packages_to_load $package_to_load
}
}
@@ -715,18 +730,17 @@
} {
set dirs [list]
lappend dirs $path
- foreach subdir [glob -nocomplain -type d [file join $path *]] {
+ foreach subdir [glob -nocomplain -type d [ad_file join $path *]] {
lappend dirs {*}[apm_subdirs $subdir]
}
return $dirs
}
-ad_proc -private apm_pretty_name_for_file_type { type } {
+ad_proc -public apm_pretty_name_for_file_type { type } {
Returns the pretty name corresponding to a particular file type key
@see apm_file_type_names
- @see apm_file_type_keys
@author Peter Marklund
} {
@@ -746,9 +760,9 @@
set path "$::acs::rootdir/$file"
ns_log Debug "APM: File being watched: $path"
- if { [file exists $path]
+ if { [ad_file exists $path]
&& (![nsv_exists apm_library_mtime $file]
- || [file mtime $path] ne [nsv_get apm_library_mtime $file])
+ || [ad_file mtime $path] ne [nsv_get apm_library_mtime $file])
} {
lappend files_to_reload $file
}
@@ -799,7 +813,7 @@
}
if {[llength $files] > 0} {
ns_log notice "### blueprint_reloading: [llength $files] files $files"
-
+ #::xo::broadcast send {ns_ictl markfordelete}
#
# Transform files into reload-cmds
#
@@ -808,9 +822,37 @@
# Execute these cmds in a fresh interp to produce a new
# blueprint.
#
- ns_log notice "### blueprint_reloading: cmds:\n[join $cmds \;\n]"
+ set before [list epoch [ns_ictl epoch] size [string length [ns_ictl get]]]
+ ns_log notice "### blueprint_reloading: before $before cmds:\n[join $cmds \;\n]"
ns_eval [join $cmds \;]
+ #
+ # The current thread has still the old blueprint. If we
+ # would modify the naviserver sources, it would be simple
+ # the show the diffs. here, it is more involved. The see
+ # the effect in size on the blueprint, we have to run the
+ # change statistics in a fresh thread. Let us hope that
+ # the ns_job thread update is not deferred by "ns_ictl
+ # maxconcurrentupdates", so we report as well the
+ # epoch. If there is a new epoch shown, one can be sure
+ # that we see the updated size. Otherwise, one will see
+ # this on the next reload in the log file.
+ #
+ ns_job queue ns_eval_q:[ns_info server] [subst -nocommands {
+ #
+ # Warning: Avoid dollar-substitution here, unless
+ # wanted at job registration time.
+ #
+ set blueprint [ns_ictl get]
+ set after [list epoch [ns_ictl epoch] size [string length [set blueprint]]]
+ set diff [expr {[dict get [set after] size] - [dict get {$before} size]}]
+ ns_log notice "### blueprint_reloading: after [set after] diff [set diff]"
+ if {0 && [set diff] != 0} {
+ set F [open /tmp/__blueprint.[clock seconds] w]
+ puts [set F] [set blueprint]
+ close [set F]
+ }
+ }]
}
}
@@ -876,7 +918,7 @@
ad_proc -private apm_package_reload_cmds {files} {
- Map file names into reloading cmds. For every file, a loading
+ Map filenames into reloading cmds. For every file, a loading
command is appended to the result. The command might be empty.
@return list of Tcl cmds to be executed to load these files.
@@ -895,7 +937,7 @@
if { ![info exists reloaded_files($file)] } {
# File is usually of form packages/package_key
set file_path "$::acs::rootdir/$file"
- set file_ext [file extension $file_path]
+ set file_ext [ad_file extension $file_path]
switch -- $file_ext {
.tcl {
# Make sure this is not a -init.tcl file as those should only be sourced on server startup
@@ -925,7 +967,7 @@
Returns a CVS release tag for a particular package key and version name.
} {
- regsub -all {\.} [string toupper "$package_key-$version_name"] "-" release_tag
+ regsub -all -- {\.} [string toupper "$package_key-$version_name"] "-" release_tag
return $release_tag
}
@@ -967,10 +1009,10 @@
Returns 0 otherwise.
} {
### Query the database for the indicated package_key
- return [db_string apm_package_registered_p {
+ return [db_0or1row apm_package_registered_p {
select 1 from apm_package_types
where package_key = :package_key
- } -default 0]
+ }]
}
ad_proc -public apm_package_installed_p {
@@ -979,30 +1021,28 @@
Returns 1 if there is an installed package version corresponding to the package_key,
0 otherwise. Uses a cached value for performance.
} {
- 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]
+ acs::try_cache ::acs::misc_cache eval apm_package_installed-$package_key {
+ db_0or1row apm_package_installed_p {
+ select 1 from apm_package_versions
+ where package_key = :package_key
+ and installed_p = 't'
+ }
}
}
-ad_proc -private apm_package_installed_p_not_cached {
- package_key
-} {
- return [db_string apm_package_installed_p {
- select exists (select 1 from apm_package_versions
- where package_key = :package_key
- and installed_p) from dual
- }]
-}
-
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]
+ acs::try_cache ::acs::misc_cache eval -per_request apm_package_enabled-$package_key {
+ db_0or1row apm_package_enabled_p {
+ select 1 from apm_package_versions
+ where package_key = :package_key
+ and enabled_p = 't'
+ }
+ }
}
ad_proc -public apm_enabled_packages {} {
@@ -1026,7 +1066,7 @@
Return the highest version of the indicated package.
@return the version_id of the highest installed version of a package.
} {
- return [db_exec_plsql apm_highest_version {}]
+ return [acs::dc call apm_package highest_version -package_key $package_key]
}
ad_proc -public apm_highest_version_name {package_key} {
@@ -1112,26 +1152,49 @@
apm_copy_param_to_descendents $package_key $parameter_name
}
- # Update the cache.
- db_foreach apm_parameter_cache_update {} {
- ad_parameter_cache -set $attr_value $package_id $parameter_name
- }
return $parameter_id
}
ad_proc -public apm_parameter_unregister {
{-callback apm_dummy_callback}
{-package_key ""}
{-parameter ""}
- parameter_id
+ {-parameter_id ""}
+ {parameter_id_legacy ""}
} {
Unregisters a parameter from the system.
+
+ @param parameter_id_legacy DEPRECATED: previous versions of this
+ proc would specify parameter_id as an
+ unnamed argument. This has now be
+ changed to a flag, but the old syntax
+ is still tolerated in old code. This
+ will generate a warning though and will
+ be dropped in future versions.
} {
+ # Transitional code to support legacy definition of parameter_id
+ # specified as an unnamed argument.
+ if {$parameter_id_legacy ne "" &&
+ $parameter_id eq ""
+ } {
+ set parameter_id $parameter_id_legacy
+ ns_log warning "apm_parameter_unregister: use of unnamed argument is deprecated for this proc, please use -parameter_id flag"
+ }
+
if { $parameter_id eq "" } {
- set parameter_id [db_string select_parameter_id {}]
+ set parameter_id [db_string select_parameter_id {
+ select parameter_id
+ from apm_parameters
+ where package_key = :package_key
+ and parameter_name = :parameter
+ }]
}
- db_1row get_scope_and_name {}
+ db_1row get_scope_and_name {
+ select scope, parameter_name
+ from apm_parameters
+ where parameter_id = :parameter_id
+ }
ns_log Debug "apm_parameter_unregister: Unregistering parameter $parameter_id."
@@ -1221,19 +1284,13 @@
ad_proc -public apm_package_key_from_id {package_id} {
@return The package key of the instance.
} {
- set key ::acs::apm_package_key_from_id($package_id)
- if {[info exists $key]} {return [set $key]}
- set $key [apm_package_key_from_id_not_cached $package_id]
+ return [acs::per_thread_cache eval -key acs-tcl.apm_package_key_from_id($package_id) {
+ db_string apm_package_key_from_id {
+ select package_key from apm_packages where package_id = :package_id
+ } -default ""
+ }]
}
-ad_proc -private apm_package_key_from_id_not_cached {package_id} {
- unmemoized version of apm_package_key_from_id
-} {
- return [db_string apm_package_key_from_id {
- select package_key from apm_packages where package_id = :package_id
- } -default ""]
-}
-
#
# package_id -> instance_name
#
@@ -1271,8 +1328,17 @@
return $result
}
+ad_proc -public apm_flush_package_id_cache {package_key} {
+ Flush the package id cache for this package at least in the
+ current thread. TODO: should be refactored together with the
+ 2level cache (per thread and util_memoize).
+} {
+ unset -nocomplain ::apm::package_id_from_key($package_key)
+ util_memoize_flush [list apm_package_id_from_key_not_cached $package_key]
+}
+
ad_proc -private apm_package_id_from_key_not_cached {package_key} {
- unmemoized version of apm_package_id_from_key
+ DB accessing version of apm_package_id_from_key.
} {
return [db_string apm_package_id_from_key {
select package_id from apm_packages where package_key = :package_key
@@ -1436,8 +1502,8 @@
} {
set procedure_name [string tolower "[string trim $package_key]_post_instantiation"]
# Change all "-" to "_" to mimic our Tcl standards
- regsub -all {\-} $procedure_name "_" procedure_name
- if { [info commands ::$procedure_name] eq "" } {
+ regsub -all -- {\-} $procedure_name "_" procedure_name
+ if { [namespace which ::$procedure_name] eq "" } {
# No such procedure exists...
return ""
}
@@ -1619,7 +1685,7 @@
}
}
- # We have a non-empty name of a callback proc to invoke
+ # We have a nonempty name of a callback proc to invoke
# Form the full command including arguments
set command [list {*}$proc_name {*}[apm_callback_format_args -type $type -arg_list $arg_list]]
@@ -1735,7 +1801,7 @@
}
}
-ad_proc -private apm_callback_has_valid_args {
+ad_proc -public apm_callback_has_valid_args {
{-type:required}
{-proc_name:required}
} {
@@ -1747,7 +1813,7 @@
@author Peter Marklund
} {
- if { [info commands ::$proc_name] eq "" } {
+ if { [namespace which ::$proc_name] eq "" } {
return 0
}
@@ -1763,7 +1829,7 @@
return [expr {[info args ::$proc_name] eq ""}]
}
- if {[info commands ::nsf::cmd::info] ne ""} {
+ if {[namespace which ::nsf::cmd::info] ne ""} {
#
# We can compare the signature of via nsf procs
#
@@ -1813,16 +1879,30 @@
set instance_name "$p_name"
}
}
+ #
+ # Do not do anything for already instantiated singleton packages
+ #
+ if {![db_0or1row instantiated_singleton_p {
+ select package_id
+ from apm_package_types t,
+ apm_packages p
+ where t.singleton_p = 't'
+ and t.package_key = p.package_key
+ and t.package_key = :package_key}]
+ } {
+ #
+ # Instantiate package
+ #
+ set package_id [db_exec_plsql invoke_new {}]
- set package_id [db_exec_plsql invoke_new {}]
+ apm_parameter_sync $package_key $package_id
- apm_parameter_sync $package_key $package_id
-
- foreach inherited_package_key [nsv_get apm_package_inherit_order $package_key] {
- apm_invoke_callback_proc \
- -package_key $inherited_package_key \
- -type after-instantiate \
- -arg_list [list package_id $package_id]
+ foreach inherited_package_key [nsv_get apm_package_inherit_order $package_key] {
+ apm_invoke_callback_proc \
+ -package_key $inherited_package_key \
+ -type after-instantiate \
+ -arg_list [list package_id $package_id]
+ }
}
return $package_id
@@ -1936,7 +2016,7 @@
}
}
-ad_proc -private apm_application_new_checkbox {} {
+ad_proc -public apm_application_new_checkbox {} {
Return an HTML checkbox of package_key and package names
for applications that can be mounted in the site-map. Excludes
singletons that are already instantiated.
@@ -1947,8 +2027,9 @@
db_foreach package_types {
select package_key, pretty_name
from apm_package_types t
- where not (singleton_p and exists (select 1 from apm_packages
- where package_key = t.package_key))
+ where not (singleton_p = 't'
+ and exists (select 1 from apm_packages
+ where package_key = t.package_key))
order by pretty_name
} {
lappend options [subst {}]
@@ -1977,19 +2058,19 @@
}
ad_proc -public apm::metrics {
- -package_key
- -file_type
+ -package_key:required
+ -file_type:required
-array
} {
Return some code metrics about the files in package $package_key. This
- will return an array of 3 items:
+ will return an array or dict containing at least the following items:
Valid file_type's: