Index: openacs-4/packages/acs-lang/acs-lang.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/acs-lang.info,v
diff -u -N -r1.64.2.8 -r1.64.2.9
--- openacs-4/packages/acs-lang/acs-lang.info 3 May 2020 17:22:20 -0000 1.64.2.8
+++ openacs-4/packages/acs-lang/acs-lang.info 18 May 2020 21:13:20 -0000 1.64.2.9
@@ -9,7 +9,7 @@
f
t
-
+
Peter Marklund
OpenACS Internationalization Support.
2017-08-06
@@ -20,9 +20,9 @@
GPL
3
-
+
-
+
Index: openacs-4/packages/acs-lang/tcl/lang-util-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/tcl/lang-util-procs.tcl,v
diff -u -N -r1.54.2.3 -r1.54.2.4
--- openacs-4/packages/acs-lang/tcl/lang-util-procs.tcl 1 Jul 2019 16:55:43 -0000 1.54.2.3
+++ openacs-4/packages/acs-lang/tcl/lang-util-procs.tcl 18 May 2020 21:13:20 -0000 1.54.2.4
@@ -368,10 +368,9 @@
@param locale Name of a locale, as language_COUNTRY using ISO 639 and ISO 3166
@return IANA MIME character set name
} {
- # DRB: cache this now that ad_conn tracks it
- set key ::lang::util::charset_for_locale($locale)
- if {[info exists $key]} {return [set $key]}
- set $key [db_string -cache_key ad_lang_mime_charset_$locale charset_for_locale {}]
+ return [acs::per_thread_cache eval -key acs-lang:charset_for_locale($locale) {
+ db_string -cache_key ad_lang_mime_charset_$locale charset_for_locale {}
+ }]
}
ad_proc -private lang::util::default_locale_from_lang_not_cached {
Index: openacs-4/packages/acs-lang/tcl/locale-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/tcl/locale-procs.tcl,v
diff -u -N -r1.51.2.5 -r1.51.2.6
--- openacs-4/packages/acs-lang/tcl/locale-procs.tcl 20 Jan 2020 10:44:35 -0000 1.51.2.5
+++ openacs-4/packages/acs-lang/tcl/locale-procs.tcl 18 May 2020 21:13:20 -0000 1.51.2.6
@@ -205,12 +205,13 @@
@author Peter Marklund
} {
- #set key ::__per_request(lang::system::get_locales_not_cached)
- set key ::lang::system_get_locales_not_cached
- if {![info exists $key]} {
- set $key [util_memoize lang::system::get_locales_not_cached]
- }
- return [set $key]
+ return [acs::per_thread_cache eval -key acs-lang:system_get_locales {
+ db_list select_system_locales {
+ select locale
+ from ad_locales
+ where enabled_p = 't'
+ }
+ }]
}
ad_proc -public lang::system::get_locale_options {} {
@@ -234,24 +235,13 @@
db_dml set_enabled_p { update ad_locales set enabled_p = :enabled_p where locale = :locale }
# Flush caches
- unset -nocomplain ::lang::system_get_locales_not_cached
+ unset -nocomplain ::acs::cache::acs-lang:system_get_locales
util_memoize_flush_regexp {^lang::util::default_locale_from_lang_not_cached}
util_memoize_flush_regexp {^lang::system::get_locales}
util_memoize_flush_regexp {^lang::system::get_locale_options}
}
-ad_proc -private lang::system::get_locales_not_cached {} {
- Return all enabled locales in the system.
- @author Peter Marklund
-} {
- return [db_list select_system_locales {
- select locale
- from ad_locales
- where enabled_p = 't'
- }]
-}
-
ad_proc -private lang::system::get_locale_options_not_cached {} {
Return all enabled locales in the system in a format suitable for the options argument of a form.
Index: openacs-4/packages/acs-lang/tcl/localization-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-lang/tcl/localization-procs.tcl,v
diff -u -N -r1.29.2.10 -r1.29.2.11
--- openacs-4/packages/acs-lang/tcl/localization-procs.tcl 16 Dec 2019 12:41:54 -0000 1.29.2.10
+++ openacs-4/packages/acs-lang/tcl/localization-procs.tcl 18 May 2020 21:13:20 -0000 1.29.2.11
@@ -373,11 +373,9 @@
# Keep the results of lc_time_fmt_compile in the per-thread cache
# (namespaced variable)
#
- set key ::acs::lc_time_fmt_compile($fmt,$locale)
- if {![info exists $key]} {
- set $key [lc_time_fmt_compile $fmt $locale]
- }
- return [subst [set $key]]
+ return [subst [acs::per_thread_cache eval -key acs-lang:lc_time_fmt_compile($fmt,$locale) {
+ lc_time_fmt_compile $fmt $locale
+ }]]
}
ad_proc -public lc_time_fmt_compile {
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.95.2.10 -r1.95.2.11
--- openacs-4/packages/acs-tcl/acs-tcl.info 13 May 2020 10:28:38 -0000 1.95.2.10
+++ openacs-4/packages/acs-tcl/acs-tcl.info 18 May 2020 21:13:20 -0000 1.95.2.11
@@ -9,7 +9,7 @@
f
t
-
+
OpenACS
The Kernel Tcl API library.
2017-08-06
@@ -18,7 +18,7 @@
GPL version 2
3
-
+
Index: openacs-4/packages/acs-tcl/tcl/01-database-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/01-database-procs.tcl,v
diff -u -N -r1.1.2.9 -r1.1.2.10
--- openacs-4/packages/acs-tcl/tcl/01-database-procs.tcl 13 May 2020 08:07:28 -0000 1.1.2.9
+++ openacs-4/packages/acs-tcl/tcl/01-database-procs.tcl 18 May 2020 21:13:20 -0000 1.1.2.10
@@ -120,7 +120,6 @@
# ::acs::default_database
# ::acs::db_pools($dbn) (used in db_available_pools)
# ::acs::db_pool_to_dbn($pool) (used for caching access to nsv db_pool_to_dbn)
-# ::acs::db_driverkey($dbn) (used for caching access to nsv db_driverkey)
#
# Per-thread Tcl global variables:
# One Tcl Array per Database Name:
@@ -194,75 +193,45 @@
@author Andrew Piskorski (atp@piskorski.com)
@creation-date 2003/04/08
} {
- if { $handle_p } {
- #
- # In the case, the passed "dbn" is actually a
- # handle. Determine from the handle the "pool" and from the
- # "pool" the "dbn".
- #
- set handle $dbn
- set pool [ns_db poolname $handle]
- set key ::acs::db_pool_to_dbn($pool)
- if {[info exists $key]} {
- #
- # First, try to get the variable from the per-thread
- # variable (which is part of the blueprint).
- #
- set dbn [set $key]
- } elseif { [nsv_exists db_pool_to_dbn $pool] } {
- #
- # Fallback to nsv (old style), when for whatever
- # reasons, the namespaced variable is not available.
- #
- ns_log notice "db_driverkey $handle_p dbn <$dbn> VIA NSV"
- set dbn [nsv_get db_pool_to_dbn $pool]
- } else {
- #
- # db_pool_to_dbn_init runs on startup, so other than some
- # broken code deleting the nsv key (very unlikely), the
- # only way this could happen is for someone to call this
- # proc with a db handle from a pool which is not part of
- # any dbn.
+ return [acs::per_thread_cache eval -key acs-tcl:db_driverkey_${handle_p}_$dbn {
- error "No database name (dbn) found for pool '$pool'. Check the 'ns/server/[ns_info server]/acs/database' section of your config file."
- }
- }
-
- set key ::acs::db_driverkey($dbn)
- if {[info exists $key]} {
- return [set $key]
- }
-
- if { ![nsv_exists db_driverkey $dbn] } {
- # This ASSUMES that any overriding of this default value via
- # "ns_param driverkey_dbn" has already been done:
-
if { $handle_p } {
- set driver [ns_db driver $handle]
- } else {
- db_with_handle -dbn $dbn handle {
+ set handle $dbn
+ set pool [ns_db poolname $handle]
+ set dbn $::acs::db_pool_to_dbn($pool)
+ }
+
+ if { ![nsv_exists db_driverkey $dbn] } {
+ #
+ # This ASSUMES that any overriding of this default value via
+ # "ns_param driverkey_dbn" has already been done:
+ #
+ if { $handle_p } {
set driver [ns_db driver $handle]
+ } else {
+ db_with_handle -dbn $dbn handle {
+ set driver [ns_db driver $handle]
+ }
}
- }
- # These are the default driverkey values, if they are not set
- # in the config file:
+ # These are the default driverkey values, if they are not set
+ # in the config file:
- if { [string match "Oracle*" $driver] } {
- set driverkey {oracle}
- } elseif { $driver eq "PostgreSQL" } {
- set driverkey "postgresql"
- } elseif { $driver eq "ODBC" } {
- set driverkey "nsodbc"
- } else {
- set driverkey {}
- ns_log Error "db_driverkey: Unknown driver '$driver'."
- }
+ if { [string match "Oracle*" $driver] } {
+ set driverkey {oracle}
+ } elseif { $driver eq "PostgreSQL" } {
+ set driverkey "postgresql"
+ } elseif { $driver eq "ODBC" } {
+ set driverkey "nsodbc"
+ } else {
+ set driverkey {}
+ ns_log Error "db_driverkey: Unknown driver '$driver'."
+ }
- nsv_set db_driverkey $dbn $driverkey
- }
-
- return [set $key [nsv_get db_driverkey $dbn]]
+ nsv_set db_driverkey $dbn $driverkey
+ }
+ nsv_get db_driverkey $dbn
+ }]
}
@@ -1689,14 +1658,14 @@
set local_counter -1
#
- # Make sure 'next_row' array doesn't exist.
+ # Make sure 'next_row' dict doesn't exist.
#
# The variables 'this_row' and 'next_row' are used to always
# execute the code block one result set row behind, so that we
# have the opportunity to peek ahead, which allows us to do
# group by's inside the multirow generation.
#
- # Also make the 'next_row' array available as a magic __db_multirow__next_row variable
+ # Also make the 'next_row' dict available as a magic __db_multirow__next_row variable
#
upvar 1 __db_multirow__next_row next_row
unset -nocomplain next_row
@@ -2133,7 +2102,7 @@
}
upvar 1 $column column_value
# Otherwise, it's the last row in the group if the next row has a different value than this row
- return [expr {$column_value ne $next_row($column) }]
+ return [expr {$column_value ne [dict get $next_row $column] }]
}
Index: openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl,v
diff -u -N -r1.10.2.4 -r1.10.2.5
--- openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl 13 May 2020 10:25:12 -0000 1.10.2.4
+++ openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl 18 May 2020 21:13:20 -0000 1.10.2.5
@@ -370,7 +370,54 @@
}
}
+namespace eval ::acs {
+ ##########################################################################
+ #
+ # Per-Thread Cache
+ #
+ # Cached values are stored as namespaced variables. This kind of
+ # cache has the advantage that no lock is required, but has the
+ # disadvantage that it can be used only for values that never
+ # change. Currently, there is no interface to flush these values.
+ #
+ ##########################################################################
+ nx::Class create acs::PerThreadCache {
+
+ :public method eval {
+ {-key:required}
+ {-no_empty:switch false}
+ cmd
+ } {
+ #
+ # Implement per-thread cache based on namespaced Tcl variables.
+ # The cached values are stored in the namespace ::acs:cache::*
+ #
+ # @param key key for caching, should start with package-keys
+ # and a single colon to avoid name clashes
+ # @param cmd command to be executed.
+ # @return return the last value set (don't use "return").
+ #
+ set cache_key ::acs::cache::$key
+ #ns_log notice "### exists $cache_key => [info exists $cache_key]"
+ if {![info exists $cache_key]} {
+ #ns_log notice "### call cmd <$cmd>"
+ set value [:uplevel $cmd]
+ #ns_log notice "### cmd returns <$value> no_empty $no_empty "
+ if {$no_empty && $value eq ""} {
+ return ""
+ }
+ set $cache_key $value
+ #ns_log notice "### [list set $cache_key $value]"
+ }
+ return [set $cache_key]
+ }
+ :create per_thread_cache
+ }
+ namespace eval ::acs::cache {}
+}
+
+
namespace eval ::acs {
##########################################################################
#
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 -N -r1.114.2.8 -r1.114.2.9
--- openacs-4/packages/acs-tcl/tcl/apm-procs.tcl 13 May 2020 08:05:09 -0000 1.114.2.8
+++ openacs-4/packages/acs-tcl/tcl/apm-procs.tcl 18 May 2020 21:13:20 -0000 1.114.2.9
@@ -1216,19 +1216,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
#
Index: openacs-4/packages/acs-tcl/tcl/object-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/object-procs.tcl,v
diff -u -N -r1.14.2.2 -r1.14.2.3
--- openacs-4/packages/acs-tcl/tcl/object-procs.tcl 30 Mar 2020 19:21:00 -0000 1.14.2.2
+++ openacs-4/packages/acs-tcl/tcl/object-procs.tcl 18 May 2020 21:13:20 -0000 1.14.2.3
@@ -39,12 +39,9 @@
@error if no object exists with that magic name.
} {
- set key ::acs::magic_object($name)
- if {[info exists $key]} {
- return [set $key]
- } else {
- return [set $key [acs_lookup_magic_object_no_cache $name]]
- }
+ return [acs::per_thread_cache eval -key acs-tcl:acs_magic_object($name) {
+ acs_lookup_magic_object_no_cache $name
+ }]
}
ad_proc -public acs_object_name { object_id } {
Index: openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl,v
diff -u -N -r1.153.2.16 -r1.153.2.17
--- openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl 26 Dec 2019 14:43:50 -0000 1.153.2.16
+++ openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl 18 May 2020 21:13:20 -0000 1.153.2.17
@@ -1866,9 +1866,9 @@
Maps a hostname to the corresponding sub-directory.
} {
- set key ::acs::root_of_host($host)
- if {[info exists $key]} {return [set $key]}
- set $key [acs::root_of_host_noncached $host]
+ return [acs::per_thread_cache eval -key acs-tcl:root_of_host($host) {
+ acs::root_of_host_noncached $host
+ }]
}
Index: openacs-4/packages/notifications/notifications.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/notifications/notifications.info,v
diff -u -N -r1.61.2.1 -r1.61.2.2
--- openacs-4/packages/notifications/notifications.info 12 Apr 2020 08:57:27 -0000 1.61.2.1
+++ openacs-4/packages/notifications/notifications.info 18 May 2020 21:13:20 -0000 1.61.2.2
@@ -8,7 +8,7 @@
t
notifications
-
+
OpenACS
Email notifications management
2019-01-16
@@ -17,9 +17,9 @@
3
#notifications.Notifications#
-
+
-
+
Index: openacs-4/packages/notifications/tcl/notification-type-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/notifications/tcl/notification-type-procs.tcl,v
diff -u -N -r1.16 -r1.16.2.1
--- openacs-4/packages/notifications/tcl/notification-type-procs.tcl 11 Apr 2018 10:26:07 -0000 1.16
+++ openacs-4/packages/notifications/tcl/notification-type-procs.tcl 18 May 2020 21:13:20 -0000 1.16.2.1
@@ -52,13 +52,12 @@
ad_proc -public get_type_id {
{-short_name:required}
} {
- return the notification type ID given a short name. Short names are unique but not primary keys.
+ return the notification type ID given a short name.
+ Short names are unique but not primary keys.
} {
- set key ::notification::type::get_type_id($short_name)
- if {[info exists $key]} {
- return [set $key]
- }
- return [set $key [notification::type::get_type_id_not_cached $short_name]]
+ return [acs::per_thread_cache eval -key notifications:get_type_id($short_name) {
+ notification::type::get_type_id_not_cached $short_name
+ }]
}
ad_proc -private get_type_id_not_cached {
Index: openacs-4/packages/xotcl-core/xotcl-core.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v
diff -u -N -r1.106.2.17 -r1.106.2.18
--- openacs-4/packages/xotcl-core/xotcl-core.info 12 May 2020 08:28:00 -0000 1.106.2.17
+++ openacs-4/packages/xotcl-core/xotcl-core.info 18 May 2020 21:13:20 -0000 1.106.2.18
@@ -10,7 +10,7 @@
t
xotcl
-
+
Gustaf Neumann
XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)
2017-08-06
@@ -43,12 +43,12 @@
BSD-Style
2
-
+
-
+
Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v
diff -u -N -r1.93.2.12 -r1.93.2.13
--- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 17 Apr 2020 17:27:42 -0000 1.93.2.12
+++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 18 May 2020 21:13:20 -0000 1.93.2.13
@@ -415,16 +415,14 @@
# Return 2 digit version number (suitable for number compare
# operations) from PostgreSQL or 0.0 if not available
#
- set key ::xo::pg_version
- if {[info exists $key]} {
- return [set $key]
- }
- set version 0.0
- if {[db_driverkey {}] eq "postgresql"} {
- set version_string [db_string dbqd.null.get_version {select version() from dual}]
- regexp {PostgreSQL ([0-9]+[.][0-9+])} $version_string . version
- }
- return [set $key $version]
+ return [acs::per_thread_cache -key xo:pg_version {
+ set version 0.0
+ if {[db_driverkey {}] eq "postgresql"} {
+ set version_string [db_string dbqd.null.get_version {select version() from dual}]
+ regexp {PostgreSQL ([0-9]+[.][0-9+])} $version_string . version
+ }
+ set version
+ }]
}
}
@@ -726,6 +724,9 @@
}
::xo::system_stats proc gettid {} {
+ #
+ # Get name and tid of the current thread
+ #
set hex [ns_thread id]
foreach t [ns_info threads] {
if {[lindex $t 2] eq $hex} {
@@ -744,6 +745,10 @@
"-driver:*" { set group drivers }
"-asynclogwriter*" { set group logwriter }
"-writer*" { set group writers }
+ "-spooler*" { set group spoolers }
+ "-socks-" { set group socks }
+ "-nsproxy*" { set group nsproxy }
+ "-ns_job_*" { set group ns_job }
default { set group others }
}
return $group
@@ -752,12 +757,11 @@
::xo::system_stats proc recordtimes {} {
set threadInfo [:gettid]
if {$threadInfo ne ""} {
- array set i $threadInfo
- array set i [:thread_info [pid] $i(tid)]
- if {[info exists i(stime)]} {
- set group [:thread_classify $i(name)]
- nsv_incr [self] $group,stime $i(stime)
- nsv_incr [self] $group,utime $i(utime)
+ set i [:thread_info [pid] [dict get $threadInfo tid]]
+ if {[dict exists $i stime]} {
+ set group [:thread_classify [dict get $i name]]
+ nsv_incr [self] $group,stime [dict get $i stime]
+ nsv_incr [self] $group,utime [dict get $i utime]
}
}
}
@@ -771,20 +775,19 @@
::xo::system_stats proc aggcpuinfo {utime stime ttime} {
upvar $utime utimes $stime stimes $ttime ttimes
set pid [pid]
- array set varnames {utime utimes stime stimes}
+ set varnames {utime utimes stime stimes}
foreach index [nsv_array names [self]] {
lassign [split $index ,] group kind
- :aggregate $group $varnames($kind) [nsv_get [self] $index]
+ :aggregate $group [dict get $varnames $kind] [nsv_get [self] $index]
}
set threadInfo [ns_info threads]
if {[file readable /proc/$pid/statm] && [llength [lindex $threadInfo 0]] > 7} {
foreach t $threadInfo {
- array unset s
- array set s [:thread_info $pid [lindex $t 7]]
- if {[info exists s(stime)]} {
+ set s [:thread_info $pid [lindex $t 7]]
+ if {[dict exists $s stime]} {
set group [:thread_classify [lindex $t 0]]
- :aggregate $group $varnames(utime) $s(utime)
- :aggregate $group $varnames(stime) $s(stime)
+ :aggregate $group [dict get $varnames utime] [dict get $s utime]
+ :aggregate $group [dict get $varnames stime] [dict get $s stime]
}
}
}
Index: openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl,v
diff -u -N -r1.41.2.22 -r1.41.2.23
--- openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 11 May 2020 19:12:54 -0000 1.41.2.22
+++ openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 18 May 2020 21:13:20 -0000 1.41.2.23
@@ -422,22 +422,16 @@
PackageMgr ad_proc get_package_class_from_package_key {package_key} {
Obtain the package class from a package key
} {
- set key ::xo::package_class($package_key)
- if {[info exists $key]} {return [set $key]}
-
- foreach p [::xo::PackageMgr allinstances] {
- # Sanity check for old apps, having not set the package key.
- # TODO: remove this in future versions, when package_keys are enforced
- #if {![$p exists package_key]} {
- # ns_log notice "!!! You should provide a package_key for $p [$p info class] !!!"
- # continue
- #}
- if {[$p package_key] eq $package_key} {
- return [set $key $p]
+ return [acs::per_thread_cache eval -key xo:get_package_class_from_package_key($package_key) {
+ set result ""
+ foreach p [::xo::PackageMgr allinstances] {
+ if {[$p package_key] eq $package_key} {
+ set result $p
+ break
+ }
}
- }
-
- return ""
+ set result
+ }]
}
PackageMgr ad_instproc require {{-url ""} package_id} {