Index: openacs-4/packages/acs-tcl/tcl/00-database-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/00-database-procs.tcl,v diff -u -r1.61 -r1.62 --- openacs-4/packages/acs-tcl/tcl/00-database-procs.tcl 19 Jun 2005 16:47:55 -0000 1.61 +++ openacs-4/packages/acs-tcl/tcl/00-database-procs.tcl 28 Feb 2006 03:22:26 -0000 1.62 @@ -7,6 +7,21 @@ @cvs-id 00-database-procs.tcl,v 1.19.2.5 2003/05/23 13:11:29 lars Exp } +# Database caching. +# +# Values returned by a query are cached if you pass the "-cache_key" switch +# to the database procedure. The switch value will be used as the key in the +# ns_cache eval call used to execute the query and processing code. The +# db_flush proc should be called to flush the cache when appropriate. The +# "-cache_pool" parameter can be used to specify the cache pool to be used, +# and defaults to db_cache_pool. The # size of the default cache is governed +# by the kernel parameter "DBCacheSize" in the "caching" section. +# +# Currently db_string, db_list, db_list_of_lists, db_0or1row, and db_multirow support +# caching. +# +# Don Baccus 2/25/2006 - my 52nd birthday! + # As originally released in (at least) ACS 4.2 through OpenACS 4.6, # this DB API supported only a single, default database. You could # define any number of different database drivers and pools in @@ -441,14 +456,14 @@ # If errno is 1, it's an error, so return errorCode and errorInfo; # if errno = 2, it's a return, so don't try to return errorCode/errorInfo # errno = 3 or 4 give undefined results - + if { $errno == 1 } { # A real error occurred global errorInfo errorCode return -code $errno -errorcode $errorCode -errorinfo $errorInfo $error } - + if { $errno == 2 } { # The code block called a "return", so pass the message through but don't try @@ -553,7 +568,7 @@ 

     db_exec_plsql delete_note { }
- +

yourfilename-oracle.xql:

@@ -1015,48 +1030,100 @@ } -ad_proc -public db_string {{ -dbn "" } statement_name sql args } { +ad_proc -public db_string { + { -dbn "" } + -cache_key + {-cache_pool db_cache_pool} + statement_name + sql + args + } { Usage: db_string statement-name sql [ -default default ] [ -bind bind_set_id | -bind bind_value_list ] @return 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. @param dbn The database name to use. If empty_string, uses the default database. + @param cache_key Cache the result using given value as the key. Default is to not cache. + @param cache_pool Override the default db_cache_pool } { # Query Dispatcher (OpenACS - ben) set full_name [db_qd_get_fullname $statement_name] ad_arg_parser { default bind } $args - db_with_handle -dbn $dbn db { - set selection [db_exec 0or1row $db $full_name $sql] - } - - if { [empty_string_p $selection] } { - if { [info exists default] } { - return $default + if { [info exists cache_key] } { + set value [ns_cache eval $cache_pool $cache_key { + db_with_handle db { + set selection [db_exec 0or1row $db $full_name $sql] + } + if { $selection ne ""} { + set selection [list [ns_set value $selection 0]] + } + set selection + }] + if { $value eq "" } { + if { [info exists default] } { + return $default + } + return -code error "Selection did not return a value, and no default was provided" + } else { + return [lindex $value 0] } - return -code error "Selection did not return a value, and no default was provided" + } else { + db_with_handle db { + set selection [db_exec 0or1row $db $full_name $sql] + } + if { $selection eq ""} { + 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] } - return [ns_set value $selection 0] + } -ad_proc -public db_list {{ -dbn "" } statement_name sql args } { +ad_proc -public db_list { + { -dbn "" } + -cache_key + {-cache_pool db_cache_pool} + statement_name + sql + args +} { Usage: db_list statement-name sql [ -bind bind_set_id | -bind bind_value_list ] - + @return a Tcl list of the values in the first column of the result of SQL query sql. If sql doesn't return any rows, returns an empty list. @param dbn The database name to use. If empty_string, uses the default database. + @param cache_key Cache the result using given value as the key. Default is to not cache. + @param cache_pool Override the default db_cache_pool } { ad_arg_parser { bind } $args # Query Dispatcher (OpenACS - SDW) set full_statement_name [db_qd_get_fullname $statement_name] - # Can't use db_foreach here, since we need to use the ns_set directly. + # Can't use db_foreach in this proc, since we need to use the ns_set directly. + + if { [info exists cache_key] } { + return [ns_cache eval $cache_pool $cache_key { + db_with_handle -dbn $dbn 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] + } + } + set result + }] + } + db_with_handle -dbn $dbn db { set selection [db_exec select $db $full_statement_name $sql] set result [list] @@ -1065,33 +1132,59 @@ } } return $result + } -ad_proc -public db_list_of_lists {{ -dbn "" } statement_name sql args } { +ad_proc -public db_list_of_lists { + { -dbn "" } + -cache_key + {-cache_pool db_cache_pool} + statement_name + sql + args +} { Usage: db_list_of_lists statement-name sql [ -bind bind_set_id | -bind bind_value_list ] @return a Tcl list, each element of which is a list of all column values in a row of the result of the SQL querysql. If sql doesn't return any rows, returns an empty list. - + It checks if the element is I18N and replaces it, thereby reducing the need to do this with every single package @param dbn The database name to use. If empty_string, uses the default database. + @param cache_key Cache the result using given value as the key. Default is to not cache. + @param cache_pool Override the default db_cache_pool } { ad_arg_parser { bind } $args # Query Dispatcher (OpenACS - SDW) set full_statement_name [db_qd_get_fullname $statement_name] # Can't use db_foreach here, since we need to use the ns_set directly. + + if { [info exists cache_key] } { + return [ns_cache eval $cache_pool $cache_key { + db_with_handle -dbn $dbn 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 + } + } + set result + }] + } + db_with_handle -dbn $dbn 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 } { @@ -1101,6 +1194,7 @@ } } return $result + } @@ -1164,7 +1258,7 @@ # This block is optional. ns_write "<li>No greebles!\n" } - + @param dbn The database name to use. If empty_string, uses the default database. } { # Query Dispatcher (OpenACS - ben) @@ -1257,20 +1351,218 @@ } +proc db_multirow_helper {} { + uplevel 1 { + if { !$append_p || ![info exists counter]} { + set counter 0 + } + + db_with_handle -dbn $dbn db { + set selection [db_exec select $db $full_statement_name $sql] + set local_counter 0 + + # Make sure 'next_row' array doesn't exist + # The this_row and next_row variables are used to always execute the code block one result set row behind, + # so that we have the opportunity to peek ahead, which allows us to do group by's inside + # the multirow generation + # Also make the 'next_row' array available as a magic __db_multirow__next_row variable + upvar 1 __db_multirow__next_row next_row + if { [info exists next_row] } { + unset next_row + } + + set more_rows_p 1 + while { 1 } { + + if { $more_rows_p } { + set more_rows_p [db_getrow $db $selection] + } else { + break + } + + # Setup the 'columns' part, now that we know the columns in the result set + # And save variables which we might clobber, if '-unclobber' switch is specified. + if { $local_counter == 0 } { + for { set i 0 } { $i < [ns_set size $selection] } { incr i } { + lappend local_columns [ns_set key $selection $i] + } + set local_columns [concat $local_columns $extend] + if { !$append_p || ![info exists columns] } { + # store the list of columns in the var_name:columns variable + set columns $local_columns + } else { + # Check that the columns match, if not throw an error + if { ![string equal [join [lsort -ascii $local_columns]] [join [lsort -ascii $columns]]] } { + error "Appending to a multirow with differing columns. + Original columns : [join [lsort -ascii $columns] ", "]. + Columns in this query: [join [lsort -ascii $local_columns] ", "]" "" "ACS_MULTIROW_APPEND_COLUMNS_MISMATCH" + } + } + + # Save values of columns which we might clobber + if { $unclobber_p && ![empty_string_p $code_block] } { + foreach col $columns { + upvar 1 $col column_value __saved_$col column_save + + if { [info exists column_value] } { + if { [array exists column_value] } { + array set column_save [array get column_value] + } else { + set column_save $column_value + } + + # Clear the variable + unset column_value + } + } + } + } + + if { [empty_string_p $code_block] } { + # No code block - pull values directly into the var_name array. + + # The extra loop after the last row is only for when there's a code block + if { !$more_rows_p } { + break + } + incr counter + upvar $level_up "$var_name:$counter" array_val + set array_val(rownum) $counter + 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 { + # There is a code block to execute + + # Copy next_row to this_row, if it exists + if { [info exists this_row] } { + unset this_row + } + set array_get_next_row [array get next_row] + if { ![empty_string_p $array_get_next_row] } { + array set this_row [array get next_row] + } + + # Pull values from the query into next_row + if { [info exists next_row] } { + unset next_row + } + if { $more_rows_p } { + for { set i 0 } { $i < [ns_set size $selection] } { incr i } { + set next_row([ns_set key $selection $i]) [ns_set value $selection $i] + } + } + + # Process the row + if { [info exists this_row] } { + # Pull values from this_row into local variables + foreach name [array names this_row] { + upvar 1 $name column_value + set column_value $this_row($name) + } + + # 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. + incr counter + upvar $level_up "$var_name:$counter" array_val + set array_val(rownum) $counter + foreach column_name $columns { + upvar 1 $column_name column_value + set array_val($column_name) $column_value + } + } + } + incr local_counter + } + } + + # Restore values of columns which we've saved + if { $unclobber_p && ![empty_string_p $code_block] && $local_counter > 0 } { + foreach col $columns { + upvar 1 $col column_value __saved_$col column_save + + # Unset it first, so the road's paved to restoring + if { [info exists column_value] } { + unset column_value + } + + # Restore it + if { [info exists column_save] } { + if { [array exists column_save] } { + array set column_value [array get column_save] + } else { + set column_value $column_save + } + + # And then remove the saved col + unset column_save + } + } + } + # Unset the next_row variable, just in case + if { [info exists next_row] } { + unset next_row + } + } +} + ad_proc -public db_multirow { -local:boolean -append:boolean {-upvar_level 1} -unclobber:boolean {-extend {}} {-dbn ""} + -cache_key + {-cache_pool db_cache_pool} var_name statement_name sql args } { @param dbn The database name to use. If empty_string, uses the default database. - + @param cache_key Cache the result using given value as the key. Default is to not cache. + @param cache_pool Override the default db_cache_pool + @param unclobber If set, will cause the proc to not overwrite local variables. Actually, what happens is that the local variables will be overwritten, so you can access them within the code block. However, if you specify -unclobber, we will revert them to their original state after execution of this proc. @@ -1291,15 +1583,29 @@ list of column names.

- + + If "cache_key" is set, cache the array that results from the query *and* + any code block for future use. 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. + +

+ + You can not simultaneously append to and cache a multirow. + +

+ Each row also has a column, rownum, automatically added and set to the row number, starting with 1. Note that this will override any column in the SQL statement named 'rownum', also if you're using the Oracle rownum pseudo-column. - +

- If the -local is passed, the variables defined - by db_multirow will be set locally (useful if you're compiling dynamic templates + + If the -local is passed, the variables defined + by db_multirow will be set locally (useful if you're compiling dynamic templates in a function or similar situations). Use the -upvar_level switch to specify how many levels up the variable should be set. @@ -1382,200 +1688,45 @@ } else { return -code error "Expected 1 or 3 arguments after switches" } - + + if { [info exists cache_key] && $append_p } { + return -code error "Can't append and cache a multirow datasource simultaneously" + } + upvar $level_up "$var_name:rowcount" counter upvar $level_up "$var_name:columns" columns - if { !$append_p || ![info exists counter]} { - set counter 0 - } + if { [info exists cache_key] } { - db_with_handle -dbn $dbn db { - set selection [db_exec select $db $full_statement_name $sql] - set local_counter 0 + set value [ns_cache eval $cache_pool $cache_key { + db_multirow_helper - # Make sure 'next_row' array doesn't exist - # The this_row and next_row variables are used to always execute the code block one result set row behind, - # so that we have the opportunity to peek ahead, which allows us to do group by's inside - # the multirow generation - # Also make the 'next_row' array available as a magic __db_multirow__next_row variable - upvar 1 __db_multirow__next_row next_row - if { [info exists next_row] } { - unset next_row - } - - set more_rows_p 1 - while { 1 } { + set values [list] - if { $more_rows_p } { - set more_rows_p [db_getrow $db $selection] - } else { - break + for { set count 1 } { $count <= $counter } { incr count } { + upvar $level_up "$var_name:[expr {$count}]" array_val + lappend values [array get array_val] } - - # Setup the 'columns' part, now that we know the columns in the result set - # And save variables which we might clobber, if '-unclobber' switch is specified. - if { $local_counter == 0 } { - for { set i 0 } { $i < [ns_set size $selection] } { incr i } { - lappend local_columns [ns_set key $selection $i] - } - set local_columns [concat $local_columns $extend] - if { !$append_p || ![info exists columns] } { - # store the list of columns in the var_name:columns variable - set columns $local_columns - } else { - # Check that the columns match, if not throw an error - if { ![string equal [join [lsort -ascii $local_columns]] [join [lsort -ascii $columns]]] } { - error "Appending to a multirow with differing columns. -Original columns : [join [lsort -ascii $columns] ", "]. -Columns in this query: [join [lsort -ascii $local_columns] ", "]" "" "ACS_MULTIROW_APPEND_COLUMNS_MISMATCH" - } - } - # Save values of columns which we might clobber - if { $unclobber_p && ![empty_string_p $code_block] } { - foreach col $columns { - upvar 1 $col column_value __saved_$col column_save + return [list $counter $columns $values] + }] - if { [info exists column_value] } { - if { [array exists column_value] } { - array set column_save [array get column_value] - } else { - set column_save $column_value - } + set counter [lindex $value 0] + set columns [lindex $value 1] + set values [lindex $value 2] - # Clear the variable - unset column_value - } - } - } - } + set count 1 - if { [empty_string_p $code_block] } { - # No code block - pull values directly into the var_name array. - - # The extra loop after the last row is only for when there's a code block - if { !$more_rows_p } { - break - } - incr counter - upvar $level_up "$var_name:$counter" array_val - set array_val(rownum) $counter - 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 { - # There is a code block to execute - - # Copy next_row to this_row, if it exists - if { [info exists this_row] } { - unset this_row - } - set array_get_next_row [array get next_row] - if { ![empty_string_p $array_get_next_row] } { - array set this_row [array get next_row] - } - - # Pull values from the query into next_row - if { [info exists next_row] } { - unset next_row - } - if { $more_rows_p } { - for { set i 0 } { $i < [ns_set size $selection] } { incr i } { - set next_row([ns_set key $selection $i]) [ns_set value $selection $i] - } - } - - # Process the row - if { [info exists this_row] } { - # Pull values from this_row into local variables - foreach name [array names this_row] { - upvar 1 $name column_value - set column_value $this_row($name) - } - - # 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. - incr counter - upvar $level_up "$var_name:$counter" array_val - set array_val(rownum) $counter - foreach column_name $columns { - upvar 1 $column_name column_value - set array_val($column_name) $column_value - } - } - } - incr local_counter + foreach value $values { + upvar $level_up "$var_name:[expr {$count}]" array_val + array set array_val $value + incr count } + } else { + db_multirow_helper } - # Restore values of columns which we've saved - if { $unclobber_p && ![empty_string_p $code_block] && $local_counter > 0 } { - foreach col $columns { - upvar 1 $col column_value __saved_$col column_save - # Unset it first, so the road's paved to restoring - if { [info exists column_value] } { - unset column_value - } - - # Restore it - if { [info exists column_save] } { - if { [array exists column_save] } { - array set column_value [array get column_save] - } else { - set column_value $column_save - } - - # And then remove the saved col - unset column_save - } - } - } - # Unset the next_row variable, just in case - if { [info exists next_row] } { - unset next_row - } - # 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 @@ -1587,7 +1738,7 @@ } { Used inside the code_block to db_multirow to ask whether this row is the last row before the value of 'column' changes, or the last row of the result set. - +

This is useful when you want to build up a multirow for a master/slave table pair, @@ -1631,7 +1782,7 @@ @author Lars Pind (lars@collaboraid.biz) - + @param column The name of the column defining the groups. @return 1 if this is the last row before the column value changes, 0 otherwise. @@ -1787,7 +1938,14 @@ } -ad_proc -public db_0or1row {{ -dbn "" } statement_name sql args } { +ad_proc -public db_0or1row { + {-dbn ""} + -cache_key + {-cache_pool db_cache_pool} + statement_name + sql + args +} { Usage:

@@ -1804,6 +1962,8 @@ @return 1 if variables are set, 0 if no rows are returned. If more than one row is returned, throws an error. @param dbn The database name to use. If empty_string, uses the default database. + @param cache_key Cache the result using given value as the key. Default is to not cache. + @param cache_pool Override the default db_cache_pool } { ad_arg_parser { bind column_array column_set } $args @@ -1825,11 +1985,39 @@ upvar 1 $column_set selection } - db_with_handle -dbn $dbn db { - set selection [db_exec 0or1row $db $full_statement_name $sql] + if { [info exists cache_key] } { + set values [ns_cache eval $cache_pool $cache_key { + db_with_handle -dbn $dbn db { + set selection [db_exec 0or1row $db $full_statement_name $sql] + } + + set values [list] + + if { $selection ne "" } { + for {set i 0} { $i < [ns_set size $selection] } {incr i} { + lappend values [list [ns_set key $selection $i] [ns_set value $selection $i]] + } + } + + set values + }] + + if { $values eq "" } { + set selection "" + } else { + set selection [ns_set create] + + foreach value $values { + ns_set put $selection [lindex $value 0] [lindex $value 1] + } + } + } else { + db_with_handle -dbn $dbn db { + set selection [db_exec 0or1row $db $full_statement_name $sql] + } } - - if { [empty_string_p $selection] } { + + if { $selection eq "" } { return 0 } @@ -1863,6 +2051,9 @@ @return 1 if variables are set. @param dbn The database name to use. If empty_string, uses the default database. + @param cache_key Cache the result using given value as the key. Default is to not cache. + @param cache_pool Override the default db_cache_pool + } { if { ![uplevel db_0or1row $args] } { return -code error "Query did not return any rows." @@ -1872,7 +2063,7 @@ ad_proc -public db_transaction {{ -dbn ""} transaction_code args } { Usage: db_transaction transaction_code [ on_error { error_code_block } ] - + Executes transaction_code with transactional semantics. This means that either all of the database commands within transaction_code are committed to the database or none of them are. Multiple db_transactions may be nested (end transaction is transparently ns_db dml'ed when the outermost transaction completes).

@@ -1908,10 +2099,10 @@ @param dbn The database name to use. If empty_string, uses the default database. } { upvar "#0" [db_state_array_name_is -dbn $dbn] db_state - + set syn_err "db_transaction: Invalid arguments. Use db_transaction { code } \[on_error { error_code_block }\] " set arg_c [llength $args] - + if { $arg_c != 0 && $arg_c != 2 } { # Either this is a transaction with no error handling or there must be an on_error { code } block. error $syn_err @@ -1927,7 +2118,7 @@ } # Make the error message and database handle available to the on_error block. upvar errmsg errmsg - + db_with_handle -dbn $dbn db { # Preserve the handle, since db_with_handle kills it after executing # this block. @@ -1946,7 +2137,7 @@ uplevel 1 $transaction_code } errmsg] incr db_state(transaction_level,$dbh) -1 - + set err_p 0 switch $errno { 0 { @@ -2095,7 +2286,7 @@ ad_proc -public db_abort_transaction {{ -dbn "" }} { - + Aborts all levels of a transaction. That is if this is called within several nested transactions, all of them are terminated. Use this instead of db_dml "abort" "abort transaction". @@ -2555,7 +2746,7 @@ {-dbn ""} } { @return a Tcl list of all the tables owned by the connected user. - + @param pattern Will be used as LIKE 'pattern%' to limit the number of tables returned. @param dbn The database name to use. If empty_string, uses the default database. @@ -2683,7 +2874,7 @@ @return 1 if the row exists in the table, 0 if not. @param dbn The database name to use. If empty_string, uses the default database. - + @author Lars Pind (lars@pinds.com) } { set columns [list] @@ -3247,3 +3438,23 @@ return -code $errno -errorinfo $errinfo -errorcode $errcode $error } + +ad_proc -public db_flush_cache { + {-cache_key_pattern *} + {-cache_pool db_cache_pool} +} { + + Flush the given cache of entries with keys that match the given pattern. + + @param cache_key_pattern The "string match" pattern used to flush keys (default is + to flush all entries) + @param cache_pool The pool to flush (default is to flush db_cache_pool) + @author Don Baccus (dhogasa@pacifier.com) + +} { + foreach key [ns_cache names $cache_pool] { + if { [string match $cache_key_pattern $key] } { + ns_cache flush $cache_pool $key + } + } +}