Index: openacs-4/packages/acs-tcl/tcl/memoize-procs-aolserver.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/memoize-procs-aolserver.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/memoize-procs-aolserver.tcl 26 Feb 2018 18:46:41 -0000 1.1
@@ -0,0 +1,120 @@
+if {[ns_info name] eq "NaviServer"} {
+ return
+}
+
+#
+# "Classical" implementation of util_memoize for AOLServer
+# with script-level expire handling
+#
+ad_proc -public util_memoize {script {max_age ""}} {
+ If <i>script</i> has been executed before, return the value it
+ returned last time, unless it was more than <i>max_age</i> seconds ago.
+
+ <p> Otherwise, evaluate <i>script</i> and cache and return the
+ result.
+
+ <p> Note: <i>script</i> is not evaluated with <code>uplevel</code>.
+
+ @param script A Tcl script whose value should be memoized. May be
+ best to pass this as a list, e.g. <code>[list someproc $arg1 $arg2]</code>.
+
+ @param max_age The maximum age in seconds for the cached value of
+ <i>script</i>. If the cached value is older than <i>max_age</i>
+ seconds, <i>script</i> will be re-executed.
+
+ @return The possibly-cached value returned by <i>script</i>.
+} {
+
+ 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]
+}
+
+ad_proc -public util_memoize_seed {script value {max_age ""}} {
+ Pretend <code>util_memoize</code> was called with <i>script</i> and
+ it returned <i>value</i>. Cache <i>value</i>, replacing any
+ previous cache entry for <i>script</i>.
+
+ <p> If clustering is enabled, this command flushes <i>script</i>'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
+ <i>value</i>.
+
+ @param value The value to cache for <i>script</i>.
+
+ @param max_age Not used.
+} {
+ util_memoize_flush $script
+
+ ns_cache set util_memoize $script [list [ns_time] $value]
+}
+
+ad_proc -public util_memoize_cached_p {script {max_age ""}} {
+ Check whether <i>script</i>'s value has been cached, and whether it
+ was cached no more than <i>max_age</i> 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
+ }
+}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/acs-tcl/tcl/memoize-procs-naviserver.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/memoize-procs-naviserver.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/memoize-procs-naviserver.tcl 26 Feb 2018 18:46:41 -0000 1.1
@@ -0,0 +1,117 @@
+ad_library {
+
+ Defines a convenient cache mechanism, util_memoize.
+
+ @author Various [acs@arsdigita.com]
+ @author Rob Mayoff <mayoff@arsdigita.com>
+ @author Victor Guerra
+ @author Gustaf Neumann
+
+ @creation-date 2000-10-19
+ @cvs-id $Id: memoize-procs-naviserver.tcl,v 1.1 2018/02/26 18:46:41 gustafn Exp $
+}
+
+if {[ns_info name] ne "NaviServer"} {
+ return
+}
+
+#
+# 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
+
+#
+# Flush the existing util memoize cache to get rid of any previous
+# caching conventions. This is actually just needed for the
+# upgrade from an AOLserver based util_memoize cache to the
+# NaviServer based one, since the old version kept pairs of values
+# and timestamps, which are not needed, but which might cause
+# confusions, when retrieved later.
+#
+catch {ns_cache_flush util_memoize}
+
+ad_proc -public util_memoize {script {max_age ""}} {
+ If <i>script</i> has been executed before, return the value it
+ returned last time, unless it was more than <i>max_age</i> seconds ago.
+
+ <p> Otherwise, evaluate <i>script</i> and cache and return the
+ result.
+
+ <p> Note: <i>script</i> is not evaluated with <code>uplevel</code>.
+
+ @param script A Tcl script whose value should be memoized. May be
+ best to pass this as a list, e.g. <code>[list someproc $arg1 $arg2]</code>.
+
+ @param max_age The maximum age in seconds for the cached value of
+ <i>script</i>. If the cached value is older than <i>max_age</i>
+ seconds, <i>script</i> will be re-executed.
+
+ @return The possibly-cached value returned by <i>script</i>.
+} {
+ if {$max_age ne ""} {
+ set max_age "-expires $max_age"
+ }
+ ns_cache_eval {*}$max_age -- util_memoize $script {*}$script
+}
+
+# In case, the definition of the function has cached something,
+# drop this as well.
+catch {ns_cache_flush util_memoize}
+
+
+ad_proc -public util_memoize_seed {script value {max_age ""}} {
+ Pretend <code>util_memoize</code> was called with <i>script</i> and
+ it returned <i>value</i>. Cache <i>value</i>, replacing any
+ previous cache entry for <i>script</i>.
+
+ <p> If clustering is enabled, this command flushes <i>script</i>'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
+ <i>value</i>.
+
+ @param value The value to cache for <i>script</i>.
+
+ @param max_age Not used.
+} {
+ ns_cache_eval -force util_memoize $script [list set _ $value]
+}
+
+
+ad_proc -public util_memoize_cached_p {script {max_age ""}} {
+ Check whether <i>script</i>'s value has been cached, and whether it
+ was cached no more than <i>max_age</i> seconds ago.
+
+ @param script A Tcl script.
+
+ @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 ""}]
+}
+
+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.
+}
+
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
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.17 -r1.18
--- openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 19 Jan 2018 19:47:13 -0000 1.17
+++ openacs-4/packages/acs-tcl/tcl/memoize-procs.tcl 26 Feb 2018 18:46:41 -0000 1.18
@@ -12,225 +12,6 @@
}
-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
-
- #
- # Flush the existing util memoize cache to get rid of any previous
- # caching conventions. This is actually just needed for the
- # upgrade from an AOLserver based util_memoize cache to the
- # NaviServer based one, since the old version kept pairs of values
- # and timestamps, which are not needed, but which might cause
- # confusions, when retrieved later.
- #
- catch {ns_cache_flush util_memoize}
-
-
- ad_proc -public util_memoize {script {max_age ""}} {
- If <i>script</i> has been executed before, return the value it
- returned last time, unless it was more than <i>max_age</i> seconds ago.
-
- <p> Otherwise, evaluate <i>script</i> and cache and return the
- result.
-
- <p> Note: <i>script</i> is not evaluated with <code>uplevel</code>.
-
- @param script A Tcl script whose value should be memoized. May be
- best to pass this as a list, e.g. <code>[list someproc $arg1 $arg2]</code>.
-
- @param max_age The maximum age in seconds for the cached value of
- <i>script</i>. If the cached value is older than <i>max_age</i>
- seconds, <i>script</i> will be re-executed.
-
- @return The possibly-cached value returned by <i>script</i>.
- } {
- if {$max_age ne ""} {
- set max_age "-expires $max_age"
- }
- ns_cache_eval {*}$max_age -- util_memoize $script {*}$script
- }
-
- # In case, the definition of the function has cached something,
- # drop this as well.
- catch {ns_cache_flush util_memoize}
-
-
- ad_proc -public util_memoize_seed {script value {max_age ""}} {
- Pretend <code>util_memoize</code> was called with <i>script</i> and
- it returned <i>value</i>. Cache <i>value</i>, replacing any
- previous cache entry for <i>script</i>.
-
- <p> If clustering is enabled, this command flushes <i>script</i>'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
- <i>value</i>.
-
- @param value The value to cache for <i>script</i>.
-
- @param max_age Not used.
- } {
- ns_cache_eval -force util_memoize $script [list set _ $value]
- }
-
-
- ad_proc -public util_memoize_cached_p {script {max_age ""}} {
- Check whether <i>script</i>'s value has been cached, and whether it
- was cached no more than <i>max_age</i> seconds ago.
-
- @param script A Tcl script.
-
- @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 ""}]
- }
-
- 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).
-
- } {
- set nr_flushed [ns_cache_flush -glob util_memoize $pattern]
- if {$log_p} {
- ns_log Debug "util_memoize_flush_pattern: flushed $nr_flushed entries using the pattern: $pattern"
- }
- }
-
-} else {
- #
- # "Classical" implementation of util_memoize for AOLServer
- # with script-level expire handling
- #
- ad_proc -public util_memoize {script {max_age ""}} {
- If <i>script</i> has been executed before, return the value it
- returned last time, unless it was more than <i>max_age</i> seconds ago.
-
- <p> Otherwise, evaluate <i>script</i> and cache and return the
- result.
-
- <p> Note: <i>script</i> is not evaluated with <code>uplevel</code>.
-
- @param script A Tcl script whose value should be memoized. May be
- best to pass this as a list, e.g. <code>[list someproc $arg1 $arg2]</code>.
-
- @param max_age The maximum age in seconds for the cached value of
- <i>script</i>. If the cached value is older than <i>max_age</i>
- seconds, <i>script</i> will be re-executed.
-
- @return The possibly-cached value returned by <i>script</i>.
- } {
-
- 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]
- }
-
- ad_proc -public util_memoize_seed {script value {max_age ""}} {
- Pretend <code>util_memoize</code> was called with <i>script</i> and
- it returned <i>value</i>. Cache <i>value</i>, replacing any
- previous cache entry for <i>script</i>.
-
- <p> If clustering is enabled, this command flushes <i>script</i>'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
- <i>value</i>.
-
- @param value The value to cache for <i>script</i>.
-
- @param max_age Not used.
- } {
- util_memoize_flush $script
-
- ns_cache set util_memoize $script [list [ns_time] $value]
- }
-
- ad_proc -public util_memoize_cached_p {script {max_age ""}} {
- Check whether <i>script</i>'s value has been cached, and whether it
- was cached no more than <i>max_age</i> 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.
Index: openacs-4/packages/acs-tcl/tcl/security-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/security-procs.tcl,v
diff -u -r1.85 -r1.86
--- openacs-4/packages/acs-tcl/tcl/security-procs.tcl 1 Feb 2018 21:24:57 -0000 1.85
+++ openacs-4/packages/acs-tcl/tcl/security-procs.tcl 26 Feb 2018 18:46:41 -0000 1.86
@@ -2163,12 +2163,14 @@
return ""
}
set result [db_list host_header_field_mapped {select 1 from host_node_map where host = :hostName}]
- ns_log notice "checking entry <$hostName> from host_node_map -> $result"
+ #ns_log notice "security::validated_host_header: checking entry <$hostName> from host_node_map -> $result"
+
if {$result == 1} {
#
# port is ignored
#
set $key 1
+ #ns_log notice "security::validated_host_header: checking entry <$hostName> from host_node_map return host <$host>"
return $host
}