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 -r1.10.2.13 -r1.10.2.14 --- openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl 27 Jan 2021 20:24:38 -0000 1.10.2.13 +++ openacs-4/packages/acs-tcl/tcl/acs-cache-procs.tcl 14 Feb 2021 21:04:55 -0000 1.10.2.14 @@ -413,10 +413,9 @@ # @param key cache key # @return return boolean value indicating success. # - set cache_key ${:prefix}$key - if {[info exists $cache_key]} { + if {[info exists ${:prefix}] && [dict exists [set ${:prefix}] $key]} { :upvar $var value - set value [set $cache_key] + set value [dict get [set ${:prefix}] $key] return 1 } return 0 @@ -436,20 +435,21 @@ # @param cmd command to be executed. # @return return the last value set (don't use "return"). # - set cache_key ${:prefix}$key - #ns_log notice "### exists $cache_key => [info exists $cache_key]" + #set cache_key ${:prefix}$key + #ns_log notice "### exists $cache_key => [dict exists ${:prefix} $key]" - if {![info exists $cache_key]} { + if {![info exists ${:prefix}] || ![dict exists [set ${:prefix}] $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]" + } + dict set ${:prefix} $key $value + #ns_log notice "### [list dict set ${:prefix} $key $value]" } - return [set $cache_key] + #ns_log notice "### will return [list dict get ${:prefix} $key]" + return [dict get [set ${:prefix}] $key] } :public method flush { @@ -459,22 +459,36 @@ # Flush a cache entry based on the pattern (which might be # wild-card-free). # - set pattern ${:prefix}${pattern} - unset -nocomplain {*}[info vars $pattern] + if {[info exists ${:prefix}]} { + if {$pattern eq "*"} { + ns_log notice "### dict flush ${:prefix} <$pattern>" + unset ${:prefix} + } elseif {[string first "*" $pattern] != -1} { + # + # A real pattern with wild-card was provided. + # + set keys [dict keys [set ${:prefix}] $pattern] + ns_log notice "### dict flush ${:prefix} <$pattern> -> [llength $keys]]" + foreach key $keys { + dict unset ${:prefix} $key + } + } elseif [dict exists [set ${:prefix}] $pattern] { + dict unset ${:prefix} $pattern + } + } } - # # The per-thread cache uses namespaced Tcl variables, identified # by the prefix "::acs:cache::" # - :create per_thread_cache -prefix ::acs::cache:: + :create per_thread_cache -prefix ::acs::cache # # The per-request cache uses Tcl variables in the global # namespace, such they are automatically reclaimed after the # request. These use the prefix "::__acs_cache_" # - :create per_request_cache -prefix ::__acs_cache_ + :create per_request_cache -prefix ::__acs_cache } namespace eval ::acs::cache {} } Index: openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl,v diff -u -r1.20.2.13 -r1.20.2.14 --- openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl 1 Feb 2021 10:51:09 -0000 1.20.2.13 +++ openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl 14 Feb 2021 21:04:55 -0000 1.20.2.14 @@ -40,36 +40,47 @@ } { set count 0 set good 0 - set allowedChars {^[a-zA-Z_0-9_]+$} + set allowedChars {^[a-zA-Z0-9_]+$} set allowedToplevel {^(_|(ad|acs|aa|adp|api|apm|chat|db|doc|ds|dt|cr|export|fs|general_comments|lc|news|ns|package|pkg_info|relation|rp|rss|sec|server_cluster|content_search|util|xml)_.+|callback|exec)$} set serverModuleProcs {^(h264open|h264length|h264read|h264eof|h264close|dom|bin|zip|transform|md5|base64|berkdb)$} set xmlRPC {^system\.(add|listMethods|multicall|methodHelp)$} set functionalOps {^f::(-|/)$} - set internalUse {^(_.+|AcsSc[.].+|callback::.+|install::.+)$} - set prescribed {^((after|before|notifications)-(install|instantiate|uninstall|uninstantiate|upgrade))$} + set internalUse {^(_.+|AcsSc[.].+|callback::.+|install::.+|.*[-](lob|text|gridfs|file))$} + set prescribed {^((after|before|notifications)-([a-zA-Z0-9_]+))$} + foreach p [lsort -dictionary [nsv_array names api_proc_doc]] { if {[string match "* *" $p]} continue - ns_log notice "$p" + set info [nsv_get api_proc_doc $p] + if {![dict exists $info script]} { + aa_log "$p has no script (probably a referenced C-level cmd or a proc (no ad_proc)" + } elseif {[dict get $info script] eq ""} { + continue + } incr count set tail [namespace tail $p] set qualifiers [regsub -all -- "::" [namespace qualifiers $p] "__"] - if {[regexp $internalUse $p] || [regexp $serverModuleProcs $p] || [regexp $functionalOps $p] || [regexp $xmlRPC $p]} continue - set pa [nsv_get api_proc_doc $p] - set protection [expr {[dict exists $pa protection] && "public" in [dict get $pa protection] + if {[regexp $internalUse $p] + || [regexp $serverModuleProcs $p] + || [regexp $functionalOps $p] + || [regexp $xmlRPC $p] + } { + continue + } + set protection [expr {[dict exists $info protection] && "public" in [dict get $info protection] ? "public" : "private"}] if {![regexp $allowedToplevel $p] && ![string match *::* $p]} { - if {[dict exists $pa deprecated_p] && [dict get $pa deprecated_p]} { + if {[dict exists $info deprecated_p] && [dict get $info deprecated_p]} { aa_log_result warning "deprecated proc '$p' ($protection) is not in a namespace" } else { - aa_log_result fail "proc '$p' ($protection) is not in a namespace" + aa_log_result fail "proc '$p' ($protection) is not in a namespace: $info" } } elseif { (![regexp $allowedChars $tail] - || $qualifiers ne "" - && ![regexp $allowedChars $qualifiers]) - && ![regexp $prescribed $tail] - && ![regexp {^(before|after)} $tail] - } { + || $qualifiers ne "" + && ![regexp $allowedChars $qualifiers] + ) + && ![regexp $prescribed $tail] + } { aa_log_result fail "proc '$p' ($protection): name/namespace contains invalid characters" } else { incr good