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 -r1.13 -r1.13.6.1 --- openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 11 Mar 2010 09:17:40 -0000 1.13 +++ openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 20 Oct 2013 12:34:56 -0000 1.13.6.1 @@ -8,156 +8,286 @@ @cvs-id $Id$ } -# Use shiny new ns_cache-based util_memoize. -ad_proc -public util_memoize {script {max_age ""}} { - If script has been executed before, return the value it - returned last time, unless it was more than max_age seconds ago. +if {[ns_info name] eq "NaviServer"} { + # + # Implementation of util_memoize for NaviServer. The built-in + # ns_cache_* implementation of NaviServer allows to specify for + # every entry an expire time (among others). This allows us to + # drop the "manual" expire handling as implemented in the OpenACS + # when NaviServer is available. + # + # @author Victor Guerra + # @author Gustaf Neumann + # + ad_proc -public util_memoize {script {max_age ""}} { + If script has been executed before, return the value it + returned last time, unless it was more than max_age seconds ago. + +
Otherwise, evaluate script and cache and return the + result. + +
Note: script is not evaluated with uplevel
.
+
+ @param script A Tcl script whose value should be memoized. May be
+ best to pass this as a list, e.g. [list someproc $arg1 $arg2]
.
+
+ @param max_age The maximum age in seconds for the cached value of
+ script. If the cached value is older than max_age
+ seconds, script will be re-executed.
+
+ @return The possibly-cached value returned by script.
+ } {
+ if {$max_age ne ""} {
+ set max_age "-expires $max_age"
+ }
+ ns_cache_eval {*}$max_age -- util_memoize $script {*}$script
+ }
-
Otherwise, evaluate script and cache and return the - result. -
Note: script is not evaluated with uplevel
.
+ ad_proc -public util_memoize_seed {script value {max_age ""}} {
+ Pretend util_memoize
was called with script and
+ it returned value. Cache value, replacing any
+ previous cache entry for script.
+
+
If clustering is enabled, this command flushes script's
+ value from the caches on all servers in the cluster before storing
+ the new value. The new value is only stored in the local cache.
+
+ @param script A Tcl script that presumably would return
+ value.
+
+ @param value The value to cache for script.
+
+ @param max_age Not used.
+ } {
+ ns_cache_eval -force util_memoize $script [list set _ $value]
+ }
- @param script A Tcl script whose value should be memoized. May be
- best to pass this as a list, e.g. [list someproc $arg1 $arg2]
.
- @param max_age The maximum age in seconds for the cached value of
- script. If the cached value is older than max_age
- seconds, script will be re-executed.
+ ad_proc -public util_memoize_cached_p {script {max_age ""}} {
+ Check whether script's value has been cached, and whether it
+ was cached no more than max_age seconds ago.
+
+ @param script A Tcl script.
- @return The possibly-cached value returned by script.
-} {
-
- if {$max_age ne "" && $max_age < 0} {
- error "max_age must not be negative"
+ @param max_age Maximum age of cached value in seconds.
+
+ @return Boolean value.
+ } {
+ if {$max_age ne ""} {
+ ns_log Warning "util_memoize_cached_p: ignore max_age $max_age for $script"
+ }
+ return [expr {[ns_cache_keys util_memoize $script] ne ""}]
}
- set current_time [ns_time]
+ ad_proc -public util_memoize_flush_pattern {
+ -log:boolean
+ pattern
+ } {
- set cached_p [ns_cache get util_memoize $script pair]
-
- if {$cached_p && $max_age ne "" } {
- set cache_time [lindex $pair 0]
- if {$current_time - $cache_time > $max_age} {
- ns_cache flush util_memoize $script
- set cached_p 0
+ Loop through all cached scripts, flushing all that match the
+ pattern that was passed in.
+
+ @param pattern Match pattern (glob pattern like in 'string match $pattern ...').
+ @param log Whether to log keys checked and flushed (useful for debugging).
+
+ } {
+ set nr_flushed [ns_cache_flush -glob util_memoize $pattern]
+ if {$log_p} {
+ ns_log Debug "util_memoize_flush_pattern: flushed $nf_flushed entries using the pattern: $pattern"
}
}
- if {!$cached_p} {
- set pair [ns_cache eval util_memoize $script {
- list $current_time [eval $script]
- }]
- }
+} else {
+ #
+ # "Classical" implementation of util_memoize for AOLServer
+ # with script-level expire handling
+ #
+ ad_proc -public util_memoize {script {max_age ""}} {
+ If script has been executed before, return the value it
+ returned last time, unless it was more than max_age seconds ago.
- return [lindex $pair 1]
-}
+
Otherwise, evaluate script and cache and return the
+ result.
-ad_proc -public util_memoize_seed {script value {max_age ""}} {
- Pretend util_memoize
was called with script and
- it returned value. Cache value, replacing any
- previous cache entry for script.
+
Note: script is not evaluated with uplevel
.
-
If clustering is enabled, this command flushes script's
- value from the caches on all servers in the cluster before storing
- the new value. The new value is only stored in the local cache.
+ @param script A Tcl script whose value should be memoized. May be
+ best to pass this as a list, e.g. [list someproc $arg1 $arg2]
.
- @param script A Tcl script that presumably would return
- value.
+ @param max_age The maximum age in seconds for the cached value of
+ script. If the cached value is older than max_age
+ seconds, script will be re-executed.
- @param value The value to cache for script.
+ @return The possibly-cached value returned by script.
+ } {
- @param max_age Not used.
-} {
- util_memoize_flush $script
+ if {$max_age ne "" && $max_age < 0} {
+ error "max_age must not be negative"
+ }
- ns_cache set util_memoize $script [list [ns_time] $value]
-}
+ set current_time [ns_time]
-ad_proc -private util_memoize_flush_local {script} {
- Forget any cached value for script. You probably want to use
- util_memoize_flush
to flush the caches on all servers
- in the cluster, in case clustering is enabled.
+ set cached_p [ns_cache get util_memoize $script pair]
- @param script The Tcl script whose cached value should be flushed.
-} {
- ns_cache flush util_memoize $script
-}
+ if {$cached_p && $max_age ne "" } {
+ set cache_time [lindex $pair 0]
+ if {$current_time - $cache_time > $max_age} {
+ ns_cache flush util_memoize $script
+ set cached_p 0
+ }
+ }
-ad_proc -public util_memoize_cached_p {script {max_age ""}} {
- Check whether script's value has been cached, and whether it
- was cached no more than max_age seconds ago.
+ if {!$cached_p} {
+ set pair [ns_cache eval util_memoize $script {
+ list $current_time [eval $script]
+ }]
+ }
- @param script A Tcl script.
+ return [lindex $pair 1]
+ }
- @param max_age Maximum age of cached value in seconds.
+ ad_proc -public util_memoize_seed {script value {max_age ""}} {
+ Pretend util_memoize
was called with script and
+ it returned value. Cache value, replacing any
+ previous cache entry for script.
- @return Boolean value.
-} {
- if {![ns_cache get util_memoize $script pair]} {
- return 0
+
If clustering is enabled, this command flushes script's
+ value from the caches on all servers in the cluster before storing
+ the new value. The new value is only stored in the local cache.
+
+ @param script A Tcl script that presumably would return
+ value.
+
+ @param value The value to cache for script.
+
+ @param max_age Not used.
+ } {
+ util_memoize_flush $script
+
+ ns_cache set util_memoize $script [list [ns_time] $value]
}
- if {$max_age eq ""} {
- return 1
- } else {
- set cache_time [lindex $pair 0]
- return [expr {[ns_time] - $cache_time <= $max_age}]
+ ad_proc -public util_memoize_cached_p {script {max_age ""}} {
+ Check whether script's value has been cached, and whether it
+ was cached no more than max_age seconds ago.
+
+ @param script A Tcl script.
+
+ @param max_age Maximum age of cached value in seconds.
+
+ @return Boolean value.
+ } {
+ if {![ns_cache get util_memoize $script pair]} {
+ return 0
+ }
+
+ if {$max_age eq ""} {
+ return 1
+ } else {
+ set cache_time [lindex $pair 0]
+ return [expr {[ns_time] - $cache_time <= $max_age}]
+ }
}
+
+ ad_proc -public util_memoize_flush_pattern {
+ -log:boolean
+ pattern
+ } {
+
+ Loop through all cached scripts, flushing all that match the
+ pattern that was passed in.
+
+ @param pattern Match pattern (glob pattern like in 'string match $pattern').
+ @param log Whether to log keys checked and flushed (useful for debugging).
+
+ } {
+ foreach name [ns_cache names util_memoize $pattern] {
+ if {$log_p} {
+ ns_log Debug "util_memoize_flush_pattern: flushing $name"
+ }
+ util_memoize_flush $name
+ }
+ }
+
}
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
+} -
+
+if { [catch {ns_cache set util_memoize __util_memoize_installed_p 1} error] } {
+ # This definition of util_memoize_initialized_p is for loading during bootstrap.
+
+ proc util_memoize_initialized_p {} {
+ #
+ # If the cache is not yet created (or some other error is
+ # raised) the util_memoize cache is not available.
+ #
+ if {[catch {ns_cache set util_memoize __util_memoize_installed_p 1} error]} {
+ return 0
+ }
+ #
+ # When he call above has succes, the cache is initialized, we
+ # can rewrite the function in an always succeeding one and
+ # return success as well.
+ #
+ proc ::util_memoize_initialized_p {} {
+ return 1
+ }
+ return 1
+ }
+} else {
+ proc util_memoize_initialized_p {} {
+ #
+ # This definition of util_memoize_initialized_p is just for
+ # reloading, since at that time the cache is always
+ # initialized.
+ #
+ return 1
+ }
+}
+
+
+ad_proc -private util_memoize_flush_local {script} {
+ Forget any cached value for script. You probably want to use
+ util_memoize_flush
to flush the caches on all servers
+ in the cluster, in case clustering is enabled.
+
+ @param script The Tcl script whose cached value should be flushed.
} {
- return [ad_decode [catch {ns_cache set util_memoize __util_memoize_installed_p 1} error] 0 1 0]
+ ns_cache flush util_memoize $script
}
ad_proc -public util_memoize_flush_regexp {
-log:boolean
expr
} {
-
Loop through all cached scripts, flushing all that match the
regular expression that was passed in.
+ It is recommended to use util_memoize_flush_pattern whenever
+ possible, since glob-match is in most cases sufficient and much
+ better performancewise. the glob match can be better supported by
+ the built-in set of the server.
+
+ @see util_memoize_flush_pattern
+
@param expr The regular expression to match.
@param log Whether to log keys checked and flushed (useful for debugging).
-
} {
foreach name [ns_cache names util_memoize] {
- if {$log_p} {
- ns_log Debug "util_memoize_flush_regexp: checking $name for $expr"
- }
- if { [regexp $expr $name] } {
- if {$log_p} {
- ns_log Debug "util_memoize_flush_regexp: flushing $name"
- }
- util_memoize_flush $name
- }
+ if {$log_p} {
+ ns_log Debug "util_memoize_flush_regexp: checking $name for $expr"
+ }
+ if { [regexp $expr $name] } {
+ if {$log_p} {
+ ns_log Debug "util_memoize_flush_regexp: flushing $name"
+ }
+ util_memoize_flush $name
+ }
}
}
-
-ad_proc -public util_memoize_flush_pattern {
- -log:boolean
- pattern
-} {
-
- Loop through all cached scripts, flushing all that match the
- pattern that was passed in.
-
- @param pattern Match pattern (glob pattern like in 'string match $pattern').
- @param log Whether to log keys checked and flushed (useful for debugging).
-
-} {
- foreach name [ns_cache names util_memoize $pattern] {
- if {$log_p} {
- ns_log Debug "util_memoize_flush_regexp: flushing $name"
- }
- util_memoize_flush $name
- }
-}
-