Index: openacs-4/contrib/misc/db-cache-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/misc/db-cache-procs.tcl,v
diff -u -N
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/misc/db-cache-procs.tcl	21 Feb 2003 17:33:07 -0000	1.1
@@ -0,0 +1,508 @@
+ad_library {
+
+    Greenpeace Planet customized database procs
+
+    @author Don Baccus (dhogaza@pacifier.com)
+}
+
+# DRB: Notes on caching strategy in Planet (2002-06-28)
+
+# These versions of the database API implement caching of results, flagged by the
+# inclusion of a "-cache" argument in the call.  They're written to take an optional
+# cache pool name but as of this writing Planet does not make use of this facility and
+# will fail if you do so without providing for selective flushing of cache contents.
+
+# In most cases use of the cached query results is indistinguishable from the use of
+# query results taken from the database.  The exception is in the multirow database
+# call.
+
+# When a multirow datasource is cached, all of the columns listed as arguments to "-extend",
+# along with those created by the query itself, are cached for each row in the resultset after
+# executiing the code block associated with the multirow (if any).
+
+# When this result is returned from cache, THE CODE BLOCK IS NOT EXECUTED.  Therefore any
+# values calculated by the code block that aren't listed as arguments to "extend" will
+# not be created.  In practice this impacts relatively few queries, but do take care.
+
+# The cache is currently flushed every five minutes, a compromise between performance and
+# the desire to make site content truly dynamic.  Selective cache flushing based on DML and
+# PL/SQL calls to create or update content would be much better, but involves solving the
+# multiserver cache synch issue as Planet runs on two web servers.
+
+# This strategy is not adequate for general use but the details as to how caching is
+# implemented, particular for db_multirow, db_0or1row and db_string may be of interest
+# since they're a bit tricky.
+
+# Ignore the "cache_pool" stuff.  Originally I was planning to divvy content types
+# (news, multimedia, etc) into their own cache pools.  Then we'd just flush the appropriate
+# pool when new content of that type was added.  However I wasn't able to come up with a
+# quick way to synchronize cached content on both of the webservers that run Planet so I
+# abandoned that approach.  Any general solution for caching will have to address the
+# multiple webserver issue.
+
+# (Non-Greenpeace users who only have a single webserver may find it useful)
+
+# You must initialize the cache pools yourself in an appropriate *-init.tcl file.  As
+# mentioned above the cache pool used in Greenpeace Planet is set to time out contents
+# every five minutes.  Here's our init code:
+
+# ns_cache create db_cache_pool -size 2000000
+# ad_schedule_proc 300 db_flush_cache_pool
+
+
+ad_proc -public db_list {
+    -cache:boolean
+    {-cache_pool db_cache_pool}
+    statement_name
+    sql
+    args
+} {
+
+    Returns a list containing the first column of each row returned by the SQL query $sql.
+
+} {
+    ad_arg_parser { bind } $args
+
+    # Query Dispatcher (OpenACS - SDW)
+    set full_statement_name [db_qd_get_fullname $statement_name]
+
+    if { $cache_p } {
+        set key "db_list::$sql"
+
+        set pair [ns_cache eval $cache_pool $key {
+            db_with_handle db {
+                set selection [db_exec select $db $full_statement_name $sql]
+                set result [list]
+                while { [db_getrow $db $selection] } {
+                    lappend result [ns_set value $selection 0]
+                }
+            }
+
+            return [list [ns_time] $result]
+        }]
+
+        set result [lindex $pair 1]
+    } else {
+        # Can't use db_foreach here, since we need to use the ns_set directly.
+        db_with_handle db {
+            set selection [db_exec select $db $full_statement_name $sql]
+            set result [list]
+            while { [db_getrow $db $selection] } {
+                lappend result [ns_set value $selection 0]
+            }
+        }
+    }
+
+    return $result
+}
+
+proc_doc db_list_of_lists {
+    -cache:boolean
+    {-cache_pool db_cache_pool}
+    statement_name
+    sql
+    args
+} {
+
+    Returns a list containing lists of the values in each column of each row returned by the SQL query $sql.
+
+} {
+    ad_arg_parser { bind } $args
+
+    # Query Dispatcher (OpenACS - SDW)
+    set full_statement_name [db_qd_get_fullname $statement_name]
+
+    if { $cache_p } {
+        set key "db_list_of_lists::$sql"
+
+        set pair [ns_cache eval $cache_pool $key {
+            db_with_handle db {
+                set selection [db_exec select $db $full_statement_name $sql]
+
+                set result [list]
+    
+                while { [db_getrow $db $selection] } {
+                    set this_result [list]
+                    for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+                        lappend this_result [ns_set value $selection $i]
+                    }
+                    lappend result $this_result
+                }
+            }
+
+            return [list [ns_time] $result]
+        }]
+
+        set result [lindex $pair 1]
+    } else {
+        db_with_handle db {
+            set selection [db_exec select $db $full_statement_name $sql]
+
+            set result [list]
+
+            while { [db_getrow $db $selection] } {
+                set this_result [list]
+                for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+                    lappend this_result [ns_set value $selection $i]
+                }
+                lappend result $this_result
+            }
+        }
+    }
+
+    return $result
+}
+
+proc db_multirow_helper {} {
+  uplevel 1 {
+    if { !$append_p } {
+        set counter 0
+        set columns [list]
+    } 
+
+    db_with_handle db {
+        set selection [db_exec select $db $full_statement_name $sql]
+
+        while { [db_getrow $db $selection] } {
+            
+            if { $counter == 0 } {
+                for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+                    lappend columns [ns_set key $selection $i]
+                }
+                set columns [concat $columns $extend]
+            }
+
+            if { [empty_string_p $code_block] } {
+                # No code block - pull values directly into the var_name array.
+                upvar $level_up "$var_name:[expr {$counter+1}]" array_val
+                for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+                    set array_val([ns_set key $selection $i]) \
+                        [ns_set value $selection $i]
+                }
+            } else {
+                # Pull values from the query into local variables
+                for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+                    upvar 1 [ns_set key $selection $i] column_value
+                    set column_value [ns_set value $selection $i]
+                }
+
+                # Initialize the "extend" columns to the empty string
+                foreach column_name $extend {
+                    upvar 1 $column_name column_value
+                    set column_value ""
+                }
+                
+                # Execute the code block
+                set errno [catch { uplevel 1 $code_block } error]
+
+                # Handle or propagate the error. Can't use the usual
+                # "return -code $errno..." trick due to the db_with_handle
+                # wrapped around this loop, so propagate it explicitly.
+                switch $errno {
+                    0 {
+                        # TCL_OK
+                    }
+                    1 {
+                        # TCL_ERROR
+                        global errorInfo errorCode
+                        error $error $errorInfo $errorCode
+                    }
+                    2 {
+                        # TCL_RETURN
+                        error "Cannot return from inside a db_multirow loop"
+                    }
+                    3 {
+                        # TCL_BREAK
+                        ns_db flush $db
+                        break
+                    }
+                    4 {
+                        # TCL_CONTINUE
+                        continue
+                    }
+                    default {
+                        error "Unknown return code: $errno"
+                    }
+                }
+
+                # Pull the local variables back out and into the array.
+                upvar $level_up "$var_name:[expr {$counter + 1}]" array_val
+                foreach column_name $columns {
+                    upvar 1 $column_name column_value
+                    set array_val($column_name) $column_value
+                }
+            }
+            incr counter
+            set array_val(rownum) $counter
+        }
+    }
+  }
+}
+
+ad_proc -public db_multirow {
+    -local:boolean
+    -append:boolean
+    -cache:boolean
+    {-cache_pool db_cache_pool}
+    {-extend {}}
+    var_name
+    statement_name
+    sql
+    args } {
+
+    Performs the SQL query $sql, saving results in variables of the form
+    <code><i>var_name</i>:1</code>, <code><i>var_name</i>:2</code>, etc,
+    and setting <code><i>var_name</i>:rowcount</code> to the total number
+    of rows.  Notice the nonstandard numbering (everything else in Tcl
+    starts at 0); the reason is that the graphics designer, a non
+    programmer, may wish to work with row numbers.
+
+    If "cache" is set true, cache the array that results from the query *and*
+    any code block for future use.   The key for caching is the query itself
+    so don't use any bindvars in queries you intend to cache.
+
+    The cache_pool parameter can probably (?) be used to flush, say, all news
+    queries when a new news story is posted but that's an exercise for launch
+    day if all goes well.   Ever the optimist ...
+
+} {
+    # Query Dispatcher (OpenACS - ben)
+    set full_statement_name [db_qd_get_fullname $statement_name]
+
+    if { $local_p } {
+        set level_up 1
+    } else {
+        set level_up \#[template::adp_level]
+    }
+
+    ad_arg_parser { bind args } $args
+
+    if { $cache_p && $append_p } {
+        return -code error "Can't append and cache a multirow datasource simultaneously"
+    }
+
+    # Do some syntax checking.
+    set arglength [llength $args]
+    if { $arglength == 0 } {
+        # No code block.
+        set code_block ""
+    } elseif { $arglength == 1 } {
+        # Have only a code block.
+        set code_block [lindex $args 0]
+    } elseif { $arglength == 3 } {
+        # Should have code block + if_no_rows + code block.
+        if {   ![string equal [lindex $args 1] "if_no_rows"] \
+            && ![string equal [lindex $args 1] "else"] } {
+            return -code error "Expected if_no_rows as second-to-last argument"
+        }
+        set code_block [lindex $args 0]
+        set if_no_rows_code_block [lindex $args 2]
+    } else {
+        return -code error "Expected 1 or 3 arguments after switches"
+    }
+    
+    upvar $level_up "$var_name:rowcount" counter
+    upvar $level_up "$var_name:columns" columns
+
+    if { $cache_p } {
+        set key "db_multirow::$sql"
+
+        set pair [ns_cache eval $cache_pool $key {
+            db_multirow_helper
+
+            set values [list]
+
+            for { set count 1 } { $count <= $counter } { incr count } {
+                upvar $level_up "$var_name:[expr {$count}]" array_val
+                lappend values [array get array_val]
+            }
+
+            return [list [ns_time] [list $counter $columns $values]]
+        }]
+
+        set counter [lindex [lindex $pair 1] 0]
+        set columns [lindex [lindex $pair 1] 1]
+        set values [lindex [lindex $pair 1] 2]
+
+        set count 1
+
+        foreach value $values {
+           upvar $level_up "$var_name:[expr {$count}]" array_val
+           array set array_val $value
+           incr count
+        }
+    } else {
+        db_multirow_helper
+    }
+
+    # If the if_no_rows_code is defined, go ahead and run it.
+    if { $counter == 0 && [info exists if_no_rows_code_block] } {
+        uplevel 1 $if_no_rows_code_block
+    }
+}
+
+
+ad_proc db_0or1row {
+    -cache:boolean
+    {-cache_pool db_cache_pool}
+    statement_name
+    sql
+    args
+} { 
+
+    Performs the SQL query $sql, setting variables to column values. Returns 1 if a row is returned, or 0 if no row is returned.
+
+} {
+    ad_arg_parser { bind column_array column_set } $args
+
+    # Query Dispatcher (OpenACS - ben)
+    set full_statement_name [db_qd_get_fullname $statement_name]
+
+    if { [info exists column_array] && [info exists column_set] } {
+        return -code error "Can't specify both column_array and column_set"
+    }
+
+    if { [info exists column_array] } {
+        upvar 1 $column_array array_val
+        if { [info exists array_val] } {
+            unset array_val
+        }
+    }
+
+    if { [info exists column_set] } {
+        upvar 1 $column_set selection
+    }
+
+    if { $cache_p } { 
+        set key "db_0or1row::$sql"
+
+        set pair [ns_cache eval $cache_pool $key {
+            db_with_handle db {
+                set selection [db_exec 0or1row $db $full_statement_name $sql]
+            }
+
+            set cached_values [list]
+
+            if { ![string equal $selection ""] } {
+                for {set i 0} { $i < [ns_set size $selection] } {incr i} {
+                    lappend cached_values [list [ns_set key $selection $i] [ns_set value $selection $i]]
+                }
+            }
+
+            return [list [ns_time] $cached_values]
+        }]
+
+        set cached_values [lindex $pair 1]
+
+        if { [string equal $cached_values ""] } {
+            set selection ""
+        } else { 
+            set selection [ns_set create]
+
+            foreach cached_value $cached_values {
+                ns_set put $selection [lindex $cached_value 0] [lindex $cached_value 1]
+            }
+        }
+    } else {
+        db_with_handle db {
+            set selection [db_exec 0or1row $db $full_statement_name $sql]
+        }
+    }
+    
+    if { [empty_string_p $selection] } {
+        return 0
+    }
+
+    if { [info exists column_array] } {
+        for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+            set array_val([ns_set key $selection $i]) [ns_set value $selection $i]
+        }
+    } elseif { ![info exists column_set] } {
+        for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+            upvar 1 [ns_set key $selection $i] value
+            set value [ns_set value $selection $i]
+        }
+    }
+
+    return 1
+}
+
+ad_proc db_1row { args } {
+
+    Performs the SQL query $sql, setting variables to column values. Raises an error if no rows are returned.
+
+} {
+    if { ![uplevel db_0or1row $args] } {
+        return -code error "Query did not return any rows."
+    }
+}
+
+
+
+ad_proc db_string {
+    -cache:boolean
+    {-cache_pool db_cache_pool}
+    statement_name
+    sql
+    args
+} { 
+
+    Returns the first column of the result of the SQL query $sql.
+    If the query doesn't return a row, returns $default (or raises an error if no $default is provided).
+
+} {
+    # Query Dispatcher (OpenACS - ben)
+    set full_name [db_qd_get_fullname $statement_name]
+
+    ad_arg_parser { default bind } $args
+
+    if { $cache_p } {
+        set key "db_string::$sql"
+
+        set pair [ns_cache eval $cache_pool $key {
+            db_with_handle db {
+                set selection [db_exec 0or1row $db $full_name $sql]
+            }
+
+            if { [string equal $selection ""] } {
+                return [list [ns_time] ""]
+            } else {
+                return [list [ns_time] [list [ns_set key $selection 0] [ns_set value $selection 0]]]
+            }
+        }]
+
+        set cached_value [lindex $pair 1]
+
+        if { [string equal $cached_value ""] } {
+            set selection ""
+        } else { 
+            set selection [ns_set create]
+            ns_set put $selection [lindex $cached_value 0] [lindex $cached_value 1]
+        }
+    } else {
+        db_with_handle db {
+            set selection [db_exec 0or1row $db $full_name $sql]
+        }
+    }
+
+    if { [empty_string_p $selection] } {
+        if { [info exists default] } {
+            return $default
+        }
+        return -code error "Selection did not return a value, and no default was provided"
+    }
+    return [ns_set value $selection 0]
+}
+
+ad_proc -public db_flush_cache_pool {
+    {-cache_pool db_cache_pool}
+} {
+
+    Flush the values for the given pool
+
+    @author Don Baccus (dhogasa@pacifier.com)
+} {
+    foreach key [ns_cache names $cache_pool] {
+        ns_cache flush $cache_pool $key
+    }
+}