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.6.1 -r1.13.6.2 --- openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 20 Oct 2013 12:34:56 -0000 1.13.6.1 +++ openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 20 Oct 2013 12:41:09 -0000 1.13.6.2 @@ -8,286 +8,156 @@ @cvs-id $Id$ } +# Use shiny new ns_cache-based util_memoize. -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 - } +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. - 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] - } +

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]. - 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 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 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 ""}] + @return The possibly-cached value returned by script. +} { + + if {$max_age ne "" && $max_age < 0} { + error "max_age must not be negative" } - ad_proc -public util_memoize_flush_pattern { - -log:boolean - pattern - } { + set current_time [ns_time] - 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" + 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 } } -} 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. - -

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 "" && $max_age < 0} { - error "max_age must not be negative" - } - - set current_time [ns_time] - - 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 - } - } - - if {!$cached_p} { - set pair [ns_cache eval util_memoize $script { - list $current_time [eval $script] - }] - } - - return [lindex $pair 1] + if {!$cached_p} { + set pair [ns_cache eval util_memoize $script { + list $current_time [eval $script] + }] } - 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 [lindex $pair 1] +} -

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. +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. - @param script A Tcl script that presumably would return - value. +

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 value The value to cache for script. + @param script A Tcl script that presumably would return + value. - @param max_age Not used. - } { - util_memoize_flush $script + @param value The value to cache for script. - ns_cache set util_memoize $script [list [ns_time] $value] - } + @param max_age Not used. +} { + util_memoize_flush $script - 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. + ns_cache set util_memoize $script [list [ns_time] $value] +} - @param script A Tcl script. +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 max_age Maximum age of cached value in seconds. + @param script The Tcl script whose cached value should be flushed. +} { + ns_cache flush util_memoize $script +} - @return Boolean value. - } { - if {![ns_cache get util_memoize $script pair]} { - return 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 {$max_age eq ""} { - return 1 - } else { - set cache_time [lindex $pair 0] - return [expr {[ns_time] - $cache_time <= $max_age}] - } - } + @param script A Tcl script. - ad_proc -public util_memoize_flush_pattern { - -log:boolean - pattern - } { + @param max_age Maximum age of cached value in seconds. - 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 - } + @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_initialized_p {} { Return 1 if the util_memoize cache has been initialized and is ready to be used and 0 otherwise. -} - - -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. + @author Peter Marklund } { - ns_cache flush util_memoize $script + 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 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 + } +} +