-handle_p 1 and pass the db handle.
-
- Hmm, as of 2018, it seems that in most cases, db_driverkey is
- called with a handle.
-
- @return The driverkey for use in db_* API switch statements.
-
- @author Andrew Piskorski (atp@piskorski.com)
- @creation-date 2003/04/08
-} {
- if { $handle_p } {
- #
- # In the case, the passed "dbn" is actually a
- # handle. Determine from the handle the "pool" and from the
- # "pool" the "dbn".
- #
- set handle $dbn
- set pool [ns_db poolname $handle]
- set key ::acs::db_pool_to_dbn($pool)
- if {[info exists $key]} {
- #
- # First, try to get the variable from the per-thread
- # variable (which is part of the blueprint).
- #
- set dbn [set $key]
- } elseif { [nsv_exists db_pool_to_dbn $pool] } {
- #
- # Fallback to nsv (old style), when for whatever
- # reasons, the namespaced variable is not available.
- #
- ns_log notice "db_driverkey $handle_p dbn <$dbn> VIA NSV"
- set dbn [nsv_get db_pool_to_dbn $pool]
- } else {
- #
- # db_pool_to_dbn_init runs on startup, so other than some
- # broken code deleting the nsv key (very unlikely), the
- # only way this could happen is for someone to call this
- # proc with a db handle from a pool which is not part of
- # any dbn.
-
- error "No database name (dbn) found for pool '$pool'. Check the 'ns/server/[ns_info server]/acs/database' section of your config file."
- }
- }
-
- set key ::acs::db_driverkey($dbn)
- if {[info exists $key]} {
- return [set $key]
- }
-
- if { ![nsv_exists db_driverkey $dbn] } {
- # This ASSUMES that any overriding of this default value via
- # "ns_param driverkey_dbn" has already been done:
-
- if { $handle_p } {
- set driver [ns_db driver $handle]
- } else {
- db_with_handle -dbn $dbn handle {
- set driver [ns_db driver $handle]
- }
- }
-
- # These are the default driverkey values, if they are not set
- # in the config file:
-
- if { [string match "Oracle*" $driver] } {
- set driverkey {oracle}
- } elseif { $driver eq "PostgreSQL" } {
- set driverkey "postgresql"
- } elseif { $driver eq "ODBC" } {
- set driverkey "nsodbc"
- } else {
- set driverkey {}
- ns_log Error "db_driverkey: Unknown driver '$driver'."
- }
-
- nsv_set db_driverkey $dbn $driverkey
- }
-
- return [set $key [nsv_get db_driverkey $dbn]]
-}
-
-
-ad_proc -public db_type {} {
- @return the RDBMS type (i.e. oracle, postgresql) this OpenACS installation is using.
- The nsv ad_database_type is set up during the bootstrap process.
-} {
- #
- # Currently this should always be either "oracle" or "postgresql":
- # --atp@piskorski.com, 2003/03/16 22:01 EST
- #
- # First check, if the database type exists in the namespaced
- # variable. This should be always the case. If this fail, fall
- # back to the old-style nsv (which can be costly in tight db loops)
- #
- if {[info exists ::acs::database_type]} {
- set result $::acs::database_type
- } else {
- set result [nsv_get ad_database_type .]
- ns_log Warning "db_type '$result' had to be obtained from the nsv 'ad_database_type'"
- set ::acs::database_type $result
- }
- return $result
-}
-
-ad_proc -public db_compatible_rdbms_p { db_type } {
- @return 1 if the given db_type is compatible with the current RDBMS.
-} {
- return [expr { $db_type eq "" || [db_type] eq $db_type }]
-}
-
-
-
-ad_proc -private db_legacy_package_p { db_type_list } {
- @return 1 if the package is a legacy package. We can only tell for certain if it explicitly supports Oracle 8.1.6 rather than the OpenACS more general oracle.
-} {
- if {"oracle-8.1.6" in $db_type_list} {
- return 1
- }
- return 0
-}
-
-ad_proc -public db_version {} {
- @return the RDBMS version (i.e. 8.1.6 is a recent Oracle version; 7.1 a
- recent PostgreSQL version)
-} {
- return [nsv_get ad_database_version .]
-}
-
-ad_proc -public db_current_rdbms {} {
- @return the current rdbms type and version.
-} {
- return [db_rdbms_create [db_type] [db_version]]
-}
-
-ad_proc -public db_known_database_types {} {
- @return a list of three-element lists describing the database engines known
- to OpenACS. Each sublist contains the internal database name (used in file
- paths, etc), the driver name, and a "pretty name" to be used in selection
- forms displayed to the user.
-
- The nsv containing the list is initialized by the bootstrap script and should
- never be referenced directly by user code.
-} {
- return $::acs::known_database_types
-}
-
-
-# db_null, db_quote, db_nullify_empty_string - were all previously
-# defined Oracle only, no Postgres equivalent existed at all. So, it
-# can't hurt anything to have them defined in when OpenACS is using
-# Postgres too. --atp@piskorski.com, 2003/04/08 05:34 EDT
-
-ad_proc -deprecated db_null {} {
-
- @return an empty string, which Oracle thinks is null.
-
- Deprecated: This routine was invented to provide an RDBMS-specific null
- value but doesn't actually work. I (DRB) left it in to speed porting - we
- should really clean up the code and pull out the calls instead, though.
-
- @see ""
-} {
- return ""
-}
-
-ad_proc -public db_quote { string } {
- Quotes a string value to be placed in a SQL statement.
-} {
- regsub -all {'} "$string" {''} result
- return $result
-}
-
-ad_proc -public -deprecated db_nullify_empty_string { string } {
- A convenience function that returns [db_null] if $string is the empty string.
-
- Deprecated: essentially just returns the passed string.
-
- @see: db_null
-} {
- return $string
-}
-
-ad_proc -public db_boolean { bool } {
- Converts a Tcl boolean (1/0) into a SQL boolean (t/f)
- @return t or f
-} {
- if { $bool } {
- return "t"
- } else {
- return "f"
- }
-}
-
-ad_proc -public db_nextval {
- { -dbn "" }
- sequence
-} {
-
- Example:
-
- - set new_object_id [db_nextval acs_object_id_seq] -- - @return the next value for a sequence. This can utilize a pool of - sequence values. - - @param sequence the name of an SQL sequence - - @param dbn The database name to use. If empty_string, uses the default database. - - @see /doc/db-api-detailed -} { - set driverkey [db_driverkey $dbn] - - # PostgreSQL has a special implementation here, any other db will - # probably work with the default: - - switch -- $driverkey { - - postgresql { - # # the following query will return a nextval if the sequnce - # # is of relkind = 'S' (a sequnce). if it is not of relkind = 'S' - # # we will try querying it as a view: - - # if { [db_0or1row -dbn $dbn nextval_sequence " - # select nextval('${sequence}') as nextval - # where (select relkind - # from pg_class - # where relname = '${sequence}') = 'S' - # "]} { - # return $nextval - # } else { - # ns_log debug "db_nextval: sequence($sequence) is not a real sequence. perhaps it uses the view hack." - # db_0or1row -dbn $dbn nextval_view "select nextval from ${sequence}" - # return $nextval - # } - # - # The code above is just for documentation, how it worked - # before the change below. We keep now a per-thread table of - # the "known" sequences to avoid at runtime the query, - # whether the specified sequence is a real sequence or a - # view. This change makes this function more than a factor - # of 2 faster than before. - # - # Note that solely the per-thread information won't work for - # freshly created sequences. Therefore, we keep the old - # code for checking at runtime in the database for such - # occurrences. - # - # Note that the sequence handling in OpenACS is quite a - # mess. Some sequences are named t_SEQUENCE (10 in - # dotlrn), others are called just SEQUENCE (18 in dotlrn), - # for some sequences, additional views are defined with an - # attribute 'nextval', and on top of this, db_nextval is - # called sometimes with the view name and sometimes with - # the sequence name. Checking this at runtime is - # unnecessary complex and costly. - # - # The best solution would certainly be to call "db_nextval" - # only with real sequence names (as defined in SQL). In that - # case, the whole function would for postgres would collapse - # to a single line, without any need for sequence name - # caching. But in that case, one should rename the sequences - # from t_SEQUENCE to SEQUENCE for postgres. - # - # However, since Oracle uses the pseudo column ".nextval", - # which is emulated via the view, it is not clear, how - # feasible this is to remove all such views without breaking - # installed applications. We keep for such cases the view, - # but nevertheless, the function "db_nextval" should always - # be called with names without the "t_" prefix to achieve - # Oracle compatibility. - - if {![info exists ::db::sequences]} { - ns_log notice "-- creating per thread sequence table" - namespace eval ::db {} - foreach s [db_list -dbn $dbn relnames "select relname, relkind from pg_class where relkind = 'S'"] { - set ::db::sequences($s) 1 - } - } - if {[info exists ::db::sequences(t_$sequence)]} { - #ns_log notice "-- found t_$sequence - #ad_log Warning "Deprecated sequence name 't_$sequence' is used. Use instead 't_$sequence'" - set nextval [db_string -dbn $dbn nextval "select nextval('t_$sequence')"] - } elseif {[info exists ::db::sequences($sequence)]} { - #ns_log notice "-- found $sequence" - set nextval [db_string -dbn $dbn nextval "select nextval('$sequence')"] - if {[string match t_* $sequence]} { - ad_log Warning "For portability, db_nextval should be called without the leading 't_' prefix: 't_$sequence'" - } - } elseif { [db_0or1row -dbn $dbn nextval_sequence " - select nextval('${sequence}') as nextval - where (select relkind - from pg_class - where relname = '${sequence}') = 'S' - "]} { - # - # We do not have an according sequence-table. Use the system catalog to check - # for the sequence - # - # ... the query sets nextval if it succeeds - # - ad_log Warning "Probably deprecated sequence name '$sequence' is used (no sequence table found)" - } else { - # - # Finally, there might be a view with a nextval - # - ns_log debug "db_nextval: sequence($sequence) is not a real sequence. perhaps it uses the view hack." - set nextval [db_string -dbn $dbn nextval "select nextval from $sequence"] - ad_log Warning "Using deprecated sequence view hack for '$sequence'. Is there not real sequence?" - } - - return $nextval - } - - oracle - - nsodbc - - default { - return [db_string -dbn $dbn nextval "select $sequence.nextval from dual"] - } - } -} - -ad_proc -public db_nth_pool_name { - { -dbn "" } - n -} { - @return the name of the pool used for the nth-nested selection (0-relative). - @param dbn The database name to use. If empty_string, uses the default database. -} { - set available_pools [db_available_pools $dbn] - - if { $n < [llength $available_pools] } { - set pool [lindex $available_pools $n] - } else { - return -code error "Ran out of database pools ($available_pools)" - } - return $pool -} - -if {[acs::icanuse "ns_db currenthandles"]} { - - ns_log notice "... I can use 'ns_db currenthandles'" - - # - # This branch uses "ns_db currenthandles" to implement - # "db_with_handle" instead of the old approach based on the global - # db_state variables. The new approach has the advantage that it - # is: - # - # - more robust (deletion and creation of the per-request variables, - # no coherency problem), - # - simpler, and - # - faster (less overhead per db_with_handle call) - # - # time {db_string . {select object_id from acs_objects limit 1}} 1000 - # old: 160-190 microseconds per iteration - # new: 150-180 microseconds per iteration - # - # time {xo::dc get_value . {select object_id from acs_objects limit 1}} 1000 - # old: 110-120 - # new: 105-110 - # - # set id -1 - # time {xo::dc get_value -prepare {int} . {select object_id from acs_objects where object_id=:id}} 1000 - # old: 80-100 - # new: 76-90 - # - # Still, more improvement can be done (GN). - # - ad_proc -public db_with_handle { - { -dbn "" } - db code_block - } { - Place a usable database handle in db and executes - code_block. - - @param dbn Database name to use. If empty_string, use the default database - @param db Name of the handle variable used in the code block - @param code_block code block to be executed with handle - } { - # - # Let the caller decide, how the handle variable is called in - # the code block. - # - upvar 1 $db dbh - - # - # Get the pools and the current allocated handles for this thread. - # - set pools [db_available_pools $dbn] - set currentHandles [ns_db currenthandles] - #ns_log notice "### pools <$pools> currentHandles <$currentHandles>" - - set db "" - set n 0 - foreach pool $pools { - # - # Do we have already handles allocated from this pool? - # - if {[dict exists $currentHandles $pool]} { - # - # Are there handles, which are not active (i.e. not in - # a currently open "ns_db select" and "ns_db getrow" - # context. - # - foreach {handle active} [dict get $currentHandles $pool] { - #ns_log notice "### FOUND pool $pool handle $handle active $active" - if {$active eq "0"} { - # - # We can use this handle - # - set db $handle - break - } - } - } else { - break - } - incr n - } - # - # In case, we got no handle above, we have to allocate a - # handle from the next pool, from which we have not got a - # handle before. - # - if {$db eq ""} { - # - # We were not successful above - # - set pool [lindex $pools $n] - if {$pool eq ""} { - ad_log error "handles from all pools <$pools> are exhausted" - error "could not obtain handle, all pools are exhausted" - } - set start_time [expr {[clock clicks -microseconds]/1000.0}] - #ns_log notice "### BEFORE gethandle $pool ($n)" - set errno [catch { - set db [ns_db gethandle $pool] - } error] - #ad_log notice "### AFTER gethandle $pool errno $errno handle <$db> currentHandles [ns_db currenthandles]" - ds_collect_db_call $db gethandle "" $pool $start_time $errno $error - if { $errno } { - ns_log notice "### RETURNING error $error" - return -code $errno -errorcode $::errorCode -errorinfo $::errorInfo $error - } - } - #ns_log notice "### db_with_handle has handle <$db>" - - set dbh $db - set errno [catch { uplevel 1 $code_block } error] - - # Unset dbh, so any subsequence use of this variable will bomb. - unset -nocomplain dbh - - # 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 - ns_log notice "### db_with_handle returned error <$error> for statement $code_block" - 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 - # to return errorCode or errorInfo since they may not exist - - return -code $errno $error - } - } - - # - # db_last_used_handle - # - ad_proc -private db_last_used_handle {{-dbn ""}} { - Get the last used inactive handle. - - @param dbn database name - @return last active handle or empty string - } { - set pools [db_available_pools $dbn] - set currentHandles [ns_db currenthandles] - - set last_used_handle "" - foreach pool $pools { - if {[dict exists $currentHandles $pool]} { - foreach {handle active} [dict get $currentHandles $pool] { - #ns_log notice "### FOUND pool $pool handle $handle active $active" - if {$active eq 0} { - set last_used_handle $handle - } - } - } - } - #ns_log notice "###### db_last_used_handle: <$currentHandles> last used $last_used_handle" - return $last_used_handle - } - - # - # db_release_unused_handles - # - ad_proc -public db_release_unused_handles {{-dbn ""}} { - Releases any database handles that are presently unused. - - @param dbn The database name to use. If empty_string, uses the default database. - } { - # we need the state array still for transaction handling - upvar "#0" [db_state_array_name_is -dbn $dbn] db_state - - set pools [db_available_pools $dbn] - set currentHandles [ns_db currenthandles] - - foreach pool $pools { - if {[dict exists $currentHandles $pool]} { - foreach {handle active} [dict get $currentHandles $pool] { - #ns_log notice "### FOUND pool $pool handle $handle active $active" - if {$active eq 0} { - # Don't release handles which are part of a transaction. - if { [info exists db_state(transaction_level,$handle)] - && $db_state(transaction_level,$handle) > 0 - } { - continue - } - set start_time [expr {[clock clicks -microseconds]/1000.0}] - ns_db releasehandle $handle - #ns_log notice "### AFTER releasehandle [ns_db currenthandles $pool]" - ds_collect_db_call $handle releasehandle "" "" $start_time 0 "" - } - } - } - } - } - - -} else { - - # - # This is the legacy branch without [ns_db currenthandles], using - # the global state variables. - # - ns_log notice "... cannot use 'ns_db currenthandles'" - - ad_proc -public db_with_handle { - { -dbn "" } - db code_block - } { - - Places a usable database handle in db and executes code_block. - - @param dbn The database name to use. If empty_string, uses the default database. - } { - upvar 1 $db dbh - upvar "#0" [db_state_array_name_is -dbn $dbn] db_state - - # Initialize bookkeeping variables. - if { ![info exists db_state(handles)] } { - set db_state(handles) [list] - } - if { ![info exists db_state(n_handles_used)] } { - set db_state(n_handles_used) 0 - } - if { $db_state(n_handles_used) >= [llength $db_state(handles)] } { - set pool [db_nth_pool_name -dbn $dbn $db_state(n_handles_used)] - set start_time [expr {[clock clicks -microseconds]/1000.0}] - set errno [catch { - set db [ns_db gethandle $pool] - } error] - ds_collect_db_call $db gethandle "" $pool $start_time $errno $error - lappend db_state(handles) $db - if { $errno } { - return -code $errno -errorcode $::errorCode -errorinfo $::errorInfo $error - } - } - set my_dbh [lindex $db_state(handles) $db_state(n_handles_used)] - set dbh $my_dbh - set db_state(last_used) $my_dbh - - incr db_state(n_handles_used) - set errno [catch { uplevel 1 $code_block } error] - incr db_state(n_handles_used) -1 - - # This may have changed while the code_block was being evaluated. - set db_state(last_used) $my_dbh - - # Unset dbh, so any subsequence use of this variable will bomb. - unset -nocomplain dbh - - # 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 - 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 - # to return errorCode or errorInfo since they may not exist - - return -code $errno $error - } - } - - ad_proc -private db_last_used_handle {{-dbn ""}} { - Get the last used handle - - @param dbn database name - @return last active handle or empty string - } { - upvar "#0" [db_state_array_name_is -dbn $dbn] db_state - - return $db_state(last_used) - } - - ad_proc -public db_release_unused_handles {{-dbn ""}} { - - Releases any database handles that are presently unused. - - @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 - - if { [info exists db_state(n_handles_used)] } { - # Examine the elements at the end of db_state(handles), killing off - # handles that are unused and not engaged in a transaction. - - set index_to_examine [expr { [llength $db_state(handles)] - 1 }] - while { $index_to_examine >= $db_state(n_handles_used) } { - set db [lindex $db_state(handles) $index_to_examine] - - # Stop now if the handle is part of a transaction. - if { [info exists db_state(transaction_level,$db)] - && $db_state(transaction_level,$db) > 0 - } { - break - } - - set pool [db_nth_pool_name -dbn $dbn $db_state(n_handles_used)] - set start_time [expr {[clock clicks -microseconds]/1000.0}] - ns_db releasehandle $db - ds_collect_db_call $db releasehandle "" "" $start_time 0 "" - incr index_to_examine -1 - } - set db_state(handles) [lrange $db_state(handles) 0 $index_to_examine] - } - } - - -} - -ad_proc -public db_resultrows {{-dbn ""}} { - @return the number of rows affected by the last DML command. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set driverkey [db_driverkey $dbn] - - switch -- $driverkey { - oracle { - return [ns_ora resultrows [db_last_used_handle -dbn $dbn]] - } - postgresql { - return [ns_pg ntuples [db_last_used_handle -dbn $dbn]] - } - nsodbc { - error "db_resultrows is not supported for this database." - } - default { - error "Unknown database driver. db_resultrows is not supported for this database." - } - } -} - - - -ad_proc -public db_exec_plsql { - {-dbn ""} - statement_name - sql - args -} { - - Oracle: - Executes a PL/SQL statement, and returns the variable of bind - variable
:1.
-
- - PostgreSQL: - Performs a pl/pgsql function or procedure call. The caller must - perform a select query that returns the value of the function. - -
- Examples: - -
-
- # Oracle:
- db_exec_plsql delete_note {
- begin note.del(:note_id); end;
- }
-
- # PostgreSQL:
- db_exec_plsql delete_note {
- select note__delete(:note_id);
- }
-
-
- - If you need the return value, then do something like this: - -
-
- # Oracle:
- set new_note_id [db_exec_plsql create_note {
- begin
- :1 := note.new(
- owner_id => :user_id,
- title => :title,
- body => :body,
- creation_user => :user_id,
- creation_ip => :peeraddr,
- context_id => :package_id
- );
- end;
- }]
-
- # PostgreSQL:
- set new_note_id [db_exec_plsql create_note {
- select note__new(
- null,
- :user_id,
- :title,
- :body,
- 'note',
- now(),
- :user_id,
- :peeraddr,
- :package_id
- );
- }]
-
-
- - You can call several pl/sql statements at once, like this: - -
-
- # Oracle:
- db_exec_plsql delete_note {
- begin
- note.del(:note_id);
- note.del(:another_note_id);
- note.del(:yet_another_note_id);
- end;
- }
-
- # PostgreSQL:
- db_exec_plsql delete_note {
- select note__delete(:note_id);
- select note__delete(:another_note_id);
- select note__delete(:yet_another_note_id);
- }
-
-
- If you are using xql files then put the body of the query in a
- yourfilename-oracle.xql or yourfilename-postgresql.xql file, as appropriate. E.g. the first example
- transformed to use xql files looks like this:
-
-
-
- yourfilename.tcl:
-
-
- db_exec_plsql delete_note {}
-
-
- yourfilename-oracle.xql:
-
-
- <fullquery name="delete_note"> - <querytext> - begin - note.del(:note_id); - end; - </querytext> - </fullquery>- -
- yourfilename-postgresql.xql:
-
-
- <fullquery name="delete_note"> - <querytext> - select note__delete(:note_id); - </querytext> - </fullquery>- - - @param dbn The database name to use. If empty_string, uses the default database. - - @see /doc/db-api-detailed -} { - ad_arg_parser { bind_output bind } $args - - # Query Dispatcher (OpenACS - ben) - set full_statement_name [db_qd_get_fullname $statement_name] - - if { [info exists bind_output] } { - return -code error "the -bind_output switch is not currently supported" - } - - set driverkey [db_driverkey $dbn] - switch -- $driverkey { - postgresql { - set postgres_p 1 - } - - oracle - - nsodbc - - default { - set postgres_p 0 - } - } - - if { ! $postgres_p } { - db_with_handle -dbn $dbn db { - # Right now, use :1 as the output value if it occurs in the statement, - # or not otherwise. - set test_sql [db_qd_replace_sql $full_statement_name $sql] - if { [regexp {:1} $test_sql] } { - return [db_exec exec_plsql_bind $db $full_statement_name $sql 2 1 ""] - } else { - return [db_exec dml $db $full_statement_name $sql] - } - } - } else { - # Postgres doesn't have PL/SQL, of course, but it does have - # PL/pgSQL and other procedural languages. Rather than assign the - # result to a bind variable which is then returned to the caller, - # the Postgres version of OpenACS requires the caller to perform a - # select query that returns the value of the function. - - # We are no longer calling db_string, which screws up the bind - # variable stuff otherwise because of calling environments. (ben) - - ad_arg_parser { bind_output bind } $args - - # I'm not happy about having to get the fullname here, but right now - # I can't figure out a cleaner way to do it. I will have to - # revisit this ASAP. (ben) - set full_statement_name [db_qd_get_fullname $statement_name] - - if { [info exists bind_output] } { - return -code error "the -bind_output switch is not currently supported" - } - - db_with_handle -dbn $dbn db { - # plsql calls that are simple selects bypass the plpgsql - # mechanism for creating anonymous functions (OpenACS - Dan). - # if a table is being created, we need to bypass things, too (OpenACS - Ben). - set test_sql [db_qd_replace_sql $full_statement_name $sql] - if {[regexp -nocase -- {^\s*select} $test_sql match]} { - # ns_log Debug "PLPGSQL: bypassed anon function" - set selection [db_exec 0or1row $db $full_statement_name $sql] - } elseif {[regexp -nocase -- {^\s*(create|drop) table} $test_sql match]} { - ns_log Debug "PLPGSQL: bypassed anon function for create/drop table" - set selection [db_exec dml $db $full_statement_name $sql] - return "" - } else { - # ns_log Debug "PLPGSQL: using anonymous function" - set selection [db_exec_plpgsql $db $full_statement_name $sql $statement_name] - } - return [ns_set value $selection 0] - } - } -} - - -ad_proc -private db_exec_plpgsql { db statement_name pre_sql fname } { - - PostgreSQL only. -
- - A helper procedure to execute a SQL statement, potentially binding - depending on the value of the $bind variable in the calling environment - (if set). - -
- Low level replacement for db_exec which replaces inline code with a proc. - db proc is dropped after execution. This is a temporary fix until we can - port all of the db_exec_plsql calls to simple selects of the inline code - wrapped in function calls. - -
- emulation of plsql calls from oracle. This routine takes the plsql - statements and wraps them in a function call, calls the function, and then - drops the function. Future work might involve converting this to cache the - function calls - -
- This proc is private - use db_exec_plsql instead! - - @see db_exec_plsql - -} { - set start_time [expr {[clock clicks -microseconds]/1000.0}] - - set sql [db_qd_replace_sql $statement_name $pre_sql] - - set unique_id [db_nextval "anon_func_seq"] - - set function_name "__exec_${unique_id}_${fname}" - - # insert Tcl variable values (OpenACS - Dan) - if {$sql ne $pre_sql } { - set sql [uplevel 2 [list subst -nobackslashes $sql]] - } - ns_log Debug "PLPGSQL: converted: $sql to: select $function_name ()" - - # create a function definition statement for the inline code - # binding is emulated in tcl. (OpenACS - Dan) - - set errno [catch { - upvar bind bind - if { [info exists bind] && [llength $bind] != 0 } { - if { [llength $bind] == 1 } { - set bind_vars [list] - set len [ns_set size $bind] - for {set i 0} {$i < $len} {incr i} { - lappend bind_vars [ns_set key $bind $i] \ - [ns_set value $bind $i] - } - set proc_sql [db_bind_var_substitution $sql $bind_vars] - } else { - set proc_sql [db_bind_var_substitution $sql $bind] - } - } else { - set proc_sql [uplevel 2 [list db_bind_var_substitution $sql]] - } - - ns_db dml $db "create function $function_name () returns varchar as [::ns_dbquotevalue $proc_sql] language 'plpgsql'" - - set ret_val [ns_db 0or1row $db "select $function_name ()"] - - # drop the anonymous function (OpenACS - Dan) - # JCD: ignore return code -- maybe we should be smarter about this though. - catch {ns_db dml $db "drop function $function_name ()"} - - return $ret_val - - } error] - - set errinfo $::errorInfo - set errcode $::errorCode - - ds_collect_db_call $db 0or1row $statement_name $sql $start_time $errno $error - - if { $errno == 2 } { - return $error - } else { - catch {ns_db dml $db "drop function $function_name ()"} - } - - return -code $errno -errorinfo $errinfo -errorcode $errcode $error -} - -ad_proc -private db_get_quote_indices { sql } { - Given a piece of SQL, return the indices of single quotes. - This is useful when we do bind var substitution because we should - not attempt bind var substitution inside quotes. Examples: - -
- sql return value
- {'a'} {0 2}
- {'a''} {}
- {'a'a'a'} {0 2 4 6}
- {a'b'c'd'} {1 3 5 7}
-
-
- @see db_bind_var_substitution
-} {
- set quote_indices [list]
-
- # Returns a list on the format
- # Example - for sql={'a'a'a'} returns
- # {0 2} {0 0} {2 2} {3 6} {4 4} {6 6}
- set all_indices [regexp -inline -indices -all -- {(?:^|[^'])(')(?:[^']|'')+(')(?=$|[^'])} $sql]
-
- for {set i 0} { $i < [llength $all_indices] } { incr i 3 } {
- lappend quote_indices [lindex $all_indices $i+1 0] [lindex $all_indices $i+2 0]
- }
-
- return $quote_indices
-}
-
-ad_proc -private db_bind_var_quoted_p { sql bind_start_idx bind_end_idx} {
-
-} {
- foreach {quote_start_idx quote_end_idx} [db_get_quote_indices $sql] {
- if { $bind_start_idx > $quote_start_idx && $bind_end_idx < $quote_end_idx } {
- return 1
- }
- }
-
- return 0
-}
-
-ad_proc -private db_bind_var_substitution { sql { bind "" } } {
-
- This proc emulates the bind variable substitution in the PostgreSQL driver.
- Since this is a temporary hack, we do it in Tcl instead of hacking up the
- driver to support plsql calls. This is only used for the db_exec_plpgsql
- function.
-
-} {
- if {$bind eq ""} {
- upvar __db_sql lsql
- set lsql $sql
- uplevel {
- set __db_lst [regexp -inline -indices -all -- {:?:\w+} $__db_sql]
- for {set __db_i [expr {[llength $__db_lst] - 1}]} {$__db_i >= 0} {incr __db_i -1} {
- set __db_ws [lindex $__db_lst $__db_i 0]
- set __db_we [lindex $__db_lst $__db_i 1]
- set __db_bind_var [string range $__db_sql $__db_ws $__db_we]
- if {![string match "::*" $__db_bind_var] && ![db_bind_var_quoted_p $__db_sql $__db_ws $__db_we]} {
- set __db_tcl_var [string range $__db_bind_var 1 end]
- set __db_tcl_var [set $__db_tcl_var]
- if {$__db_tcl_var eq ""} {
- set __db_tcl_var null
- } else {
- set __db_tcl_var "[::ns_dbquotevalue $__db_tcl_var]"
- }
- set __db_sql [string replace $__db_sql $__db_ws $__db_we $__db_tcl_var]
- }
- }
- }
- } else {
-
- array set bind_vars $bind
-
- set lsql $sql
- set lst [regexp -inline -indices -all -- {:?:\w+} $sql]
- for {set i [expr {[llength $lst] - 1}]} {$i >= 0} {incr i -1} {
- set ws [lindex $lst $i 0]
- set we [lindex $lst $i 1]
- set bind_var [string range $sql $ws $we]
- if {![string match "::*" $bind_var] && ![db_bind_var_quoted_p $lsql $ws $we]} {
- set tcl_var [string range $bind_var 1 end]
- set val $bind_vars($tcl_var)
- if {$val eq ""} {
- set val null
- } else {
- set val "[::ns_dbquotevalue $val]"
- }
- set lsql [string replace $lsql $ws $we $val]
- }
- }
- }
-
- return $lsql
-}
-
-
-ad_proc -private db_getrow { db selection } {
-
- A helper procedure to perform an ns_db getrow, invoking developer support
- routines as necessary.
-
-} {
- set start_time [expr {[clock clicks -microseconds]/1000.0}]
- set errno [catch { return [ns_db getrow $db $selection] } error]
- ds_collect_db_call $db getrow "" "" $start_time $errno $error
- if { $errno == 2 } {
- return $error
- }
- return -code $errno -errorinfo $::errorInfo -errorcode $::errorCode $error
-}
-
-
-ad_proc -public db_exec { type db statement_name pre_sql {ulevel 2} args } {
-
- A helper procedure to execute a SQL statement, potentially binding
- depending on the value of the $bind variable in the calling environment
- (if set).
-
-} {
- set start_time [expr {[clock clicks -microseconds]/1000.0}]
- set driverkey [db_driverkey -handle_p 1 $db]
-
- # Note: Although marked as private, db_exec is in fact called
- # extensively from several other packages. We DEFINITELY don't
- # want to have to change all those procs to pass in the
- # (redundant) $dbn just so we can use it in the call to
- # db_driverkey, so db_driverkey MUST support its -handle switch.
- # --atp@piskorski.com, 2003/04/09 12:13 EDT
-
- set sql [db_qd_replace_sql $statement_name $pre_sql]
-
- # insert Tcl variable values (OpenACS - Dan)
- if {$sql ne $pre_sql } {
- set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
- }
-
- set errno [catch {
- upvar bind bind
-
- if { [info exists bind] && [llength $bind] != 0 } {
- if { [llength $bind] == 1 } {
- # $bind is an ns_set id:
-
- switch -- $driverkey {
- oracle {
- return [ns_ora $type $db -bind $bind $sql {*}$args]
- }
- postgresql {
- return [ns_pg_bind $type $db -bind $bind $sql]
- }
- nsodbc {
- return [ns_odbc_bind $type $db -bind $bind $sql]
- }
- default {
- error "Unknown database driver. Bind variables not supported for this database."
- }
- }
-
- } else {
- # $bind is a Tcl list, convert it to an ns_set:
- set bind_vars [ns_set create]
- foreach { name value } $bind {
- ns_set put $bind_vars $name $value
- }
- }
-
- switch -- $driverkey {
- oracle {
- # TODO: Using $args outside the list is
- # potentially bad here, depending on what is in
- # args and if the items contain any embedded
- # whitespace. Or maybe it works fine. But it's
- # hard to know. Document or fix.
- # --atp@piskorski.com, 2003/04/09 15:33 EDT
-
- return [ns_ora $type $db -bind $bind_vars $sql {*}$args]
- }
- postgresql {
- return [ns_pg_bind $type $db -bind $bind_vars $sql]
- }
- nsodbc {
- return [ns_odbc_bind $type $db -bind $bind_vars $sql]
- }
- default {
- error "Unknown database driver. Bind variables not supported for this database."
- }
- }
-
- } else {
- # Bind variables, if any, are defined solely as individual
- # Tcl variables:
-
- switch -- $driverkey {
- oracle {
- return [uplevel $ulevel [list ns_ora $type $db $sql] $args]
- }
- postgresql {
- return [uplevel $ulevel [list ns_pg_bind $type $db $sql]]
- }
- nsodbc {
- return [uplevel $ulevel [list ns_odbc_bind $type $db $sql]]
- }
- default {
- # Using plain ns_db like this will work ONLY if
- # the query is NOT using bind variables:
- # --atp@piskorski.com, 2001/09/03 08:41 EDT
- return [uplevel $ulevel [list ns_db $type $db $sql] $args]
- }
- }
- }
- } error]
-
- # JCD: we log the clicks, dbname, query time, and statement to catch long running queries.
- # If we took more than 3 seconds yack about it.
- if { [clock clicks -milliseconds] - $start_time > 3000 } {
- set duration [format %.2f [expr {[clock clicks -milliseconds] - $start_time}]]
- ns_log Warning "db_exec: longdb $duration ms $db $type $statement_name"
- } else {
- #set duration [format %.2f [expr {[clock clicks -milliseconds] - $start_time}]]
- #ns_log Debug "db_exec: timing $duration seconds $db $type $statement_name"
- }
-
- ds_collect_db_call $db $type $statement_name $sql $start_time $errno $error
- if { $errno == 2 } {
- return $error
- }
-
- return -code $errno -errorinfo $::errorInfo -errorcode $::errorCode $error
-}
-
-
-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
-
- set code {
- db_with_handle -dbn $dbn db {
- set selection [db_exec 0or1row $db $full_name $sql]
- }
- if { $selection eq ""} {
- if { [info exists default] } {
- return $default
- }
- error "Selection did not return a value, and no default was provided"
- }
- return [ns_set value $selection 0]
- }
-
- if { [info exists cache_key] } {
- return [ns_cache eval $cache_pool $cache_key $code]
- } else {
- return [eval $code]
- }
-}
-
-
-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 in this proc, since we need to use the ns_set directly.
-
- set code {
- 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]
- }
- }
- return $result
- }
- if { [info exists cache_key] } {
- return [ns_cache eval $cache_pool $cache_key $code]
- } else {
- return [eval $code]
- }
-}
-
-
-ad_proc -public db_list_of_lists {
- {-dbn ""}
- -cache_key
- {-cache_pool db_cache_pool}
- -with_headers:boolean
- statement_name
- sql
- args
-} {
-
- Usage: db_list_of_lists statement-name sql [ -bind bind_set_id | -bind bind_value_list ]
-
- @param with_headers when specified, first line of returned list of
- lists will always be the list of column names as reported by the
- database. Useful when you want to dynamically assign variables to
- values returned in the list of lists.
-
- @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,
- unless with_headers flag was specified and in this case the only
- element in the list will be the list of headers.
-
- 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
-
- set code {
- set result [list]
- foreach selection [uplevel [list db_list_of_ns_sets -dbn $dbn $statement_name $sql]] {
- set selection_array [ns_set array $selection]
- if {[llength $result] == 0 && $with_headers_p} {
- set headers [list]
- foreach {key value} $selection_array {
- lappend headers $key
- }
- lappend result $headers
- }
- set row [list]
- foreach {key value} $selection_array {
- lappend row $value
- }
- lappend result $row
- }
- set result
- }
- if { [info exists cache_key] } {
- return [ns_cache eval $cache_pool $cache_key $code]
- } else {
- return [eval $code]
- }
-}
-
-
-ad_proc -public db_list_of_ns_sets {
- {-dbn ""}
- statement_name
- sql
- args
-} {
- Usage: db_list_of_ns_sets statement-name sql [ -bind bind_set_id | -bind bind_value_list ]
-
- @return a list of ns_sets with the values of each column of each row
- returned by the sql query specified.
-
- @param statement_name The name of the query.
- @param sql The SQL to be executed.
- @param args Any additional arguments.
-
- @return list of ns_sets, one per each row return by the SQL query
-
- @param dbn The database name to use. If empty_string, uses the default database.
-} {
- ad_arg_parser { bind } $args
-
- set full_statement_name [db_qd_get_fullname $statement_name]
-
- db_with_handle -dbn $dbn db {
- set result [list]
- set selection [db_exec select $db $full_statement_name $sql]
-
- while {[db_getrow $db $selection]} {
- lappend result [ns_set copy $selection]
- }
- }
-
- return $result
-}
-
-
-ad_proc -public db_foreach {
- {-dbn ""}
- statement_name
- sql
- args
-} {
-
- Usage:
- - db_foreach statement-name sql [ -bind bind_set_id | -bind bind_value_list ] \ - [ -column_array array_name | -column_set set_name ] \ - code_block [ if_no_rows if_no_rows_block ] - -- -
Performs the SQL query sql, executing - code_block once for each row with variables set to - column values (or a set or array populated if -column_array or - column_set is specified). If the query returns no rows, executes - if_no_rows_block (if provided). In place of 'if_no_rows' also the 'else' keyword can be used.
- -Example: - -
db_foreach greeble_query "select foo, bar from greeble" {
- ns_write "<li>foo=$foo; bar=$bar\n"
- } if_no_rows {
- # This block is optional.
- ns_write "<li>No greebles!\n"
- }- db_multirow [ -local ] [ -upvar_level n_levels_up ] [ -append ] [ -extend column_list ] \ - var-name statement-name sql [ -bind bind_set_id | -bind bind_value_list ] \ - code_block [ if_no_rows if_no_rows_block ] - -- -
Performs the SQL query sql, saving results in variables
- of the form
- var_name:1, var_name:2, etc,
- setting var_name:rowcount to the total number
- of rows, and setting var_name:columns to a
- 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 non-empty 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
- in a function or similar situations). Use the -upvar_level
- switch to specify how many levels up the variable should be set.
-
-
- - You may supply a code block, which will be executed for each row in - the loop. This is very useful if you need to make computations that - are better done in Tcl than in SQL, for example using ns_urlencode - or ad_quotehtml, etc. When the Tcl code is executed, all the columns - from the SQL query will be set as local variables in that code. Any - changes made to these local variables will be copied back into the - multirow. - -
-
- You may also add additional, computed columns to the multirow, using the
- -extend { col_1 col_2 ... } switch. This is
- useful for things like constructing a URL for the object retrieved by
- the query.
-
-
-
- If you're constructing your multirow through multiple queries with the
- same set of columns, but with different rows, you can use the
- -append switch. This causes the rows returned by this query
- to be appended to the rows already in the multirow, instead of starting
- a clean multirow, as is the normal behavior. The columns must match the
- columns in the original multirow, or an error will be thrown.
-
-
-
- Your code block may call continue in order to skip a row
- and not include it in the multirow. Or you can call break
- to skip this row and quit looping.
-
-
- - 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. - -
- - Example: -
db_multirow -extend { user_url } users users_query {
- select user_id first_names, last_name, email from cc_users
- } {
- set user_url [acs_community_member_url -user_id $user_id]
- }
-
- @see template::multirow
-} {
- # Query Dispatcher (OpenACS - ben)
- set full_statement_name [db_qd_get_fullname $statement_name]
-
- if { $local_p } {
- set level_up $upvar_level
- } else {
- set level_up \#[template::adp_level]
- }
-
- ad_arg_parser { bind args } $args
-
- # 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 { [lindex $args 1] ne "if_no_rows"
- && [lindex $args 1] ne "else"
- } {
- return -code error "Expected if_no_rows as second-to-last argument"
- }
- lassign $args code_block . if_no_rows_code_block
- } 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 { [info exists cache_key]
- && $append_p
- && [info exists counter] && $counter > 0
- } {
- return -code error "Can't append and cache a non-empty multirow datasource simultaneously"
- }
-
- if { [info exists cache_key] } {
-
- set value [ns_cache eval $cache_pool $cache_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 $counter $columns $values]
- }]
-
- lassign $value counter columns values
-
- 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 -public db_multirow_group_last_row_p {
- {-column:required}
-} {
- 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, - where you only want one row per row in the master table, but you want to include - data from the slave table in a column of the multirow. - -
- - Here's an example: - -
- # Initialize the lines variable to hold a list of order line summaries
- set lines [list]
-
- # Start building the multirow. We add the dynamic column 'lines_pretty', which will
- # contain the pretty summary of the order lines.
- db_multirow -extend { lines_pretty } orders select_orders_and_lines {
- select o.order_id,
- o.customer_name,
- l.item_name,
- l.quantity
- from orders o,
- order_lines l
- where l.order_id = o.order_id
- order by o.order_id, l.item_name
- } {
- lappend lines "$quantity $item_name"
- if { [db_multirow_group_last_row_p -column order_id] } {
- # Last row of this order, prepare the pretty version of the order lines
- set lines_pretty [join $lines ", "]
-
- # Reset the lines list, so we start from a fresh with the next row
- set lines [list]
- } else {
- # There are yet more order lines to come for this order,
- # continue until we've collected all the order lines
- # The 'continue' keyword means this line will not be added to the resulting multirow
- continue
- }
- }
-
-
- @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.
-} {
- upvar 1 __db_multirow__next_row next_row
- if { ![info exists next_row] } {
- # If there is no next row, this is the last row
- return 1
- }
- upvar 1 $column column_value
- # Otherwise, it's the last row in the group if the next row has a different value than this row
- return [expr {$column_value ne $next_row($column) }]
-}
-
-
-ad_proc -public db_dml {{-dbn ""} statement_name sql args } {
- Do a DML statement.
-
- - - args can be one of: -clobs, -blobs, -clob_files or -blob_files. See the db-api doc referenced below for more information. - - @param dbn The database name to use. If empty_string, uses the default database. - - @see /doc/db-api-detailed -} { - ad_arg_parser { clobs blobs clob_files blob_files bind } $args - set driverkey [db_driverkey $dbn] - - switch -- $driverkey { - postgresql { - set postgres_p 1 - } - oracle - - nsodbc - - default { - set postgres_p 0 - } - } - - # Query Dispatcher (OpenACS - ben) - set full_statement_name [db_qd_get_fullname $statement_name] - - # This "only one of..." check didn't exist in the PostgreSQL - # version, but it shouldn't't hurt anything: --atp@piskorski.com, - # 2003/04/08 06:19 EDT - - # Only one of clobs, blobs, clob_files, and blob_files is allowed. - # Remember which one (if any) is provided: - - set lob_argc 0 - set lob_argv [list] - set command "dml" - if { [info exists clobs] } { - set command "clob_dml" - set lob_argv $clobs - incr lob_argc - } - if { [info exists blobs] } { - set command "blob_dml" - set lob_argv $blobs - incr lob_argc - } - if { [info exists clob_files] } { - set command "clob_dml_file" - set lob_argv $clob_files - incr lob_argc - } - if { [info exists blob_files] } { - set command "blob_dml_file" - set lob_argv $blob_files - incr lob_argc - } - if { $lob_argc > 1 } { - error "Only one of -clobs, -blobs, -clob_files, or -blob_files may be specified as an argument to db_dml" - } - - if { ! $postgres_p } { - # Oracle: - db_with_handle -dbn $dbn db { - if { $lob_argc == 1 } { - # Bind :1, :2, ..., :n as LOBs (where n = [llength $lob_argv]) - set bind_vars [list] - for { set i 1 } { $i <= [llength $lob_argv] } { incr i } { - lappend bind_vars $i - } - eval [list db_exec "${command}_bind" $db $full_statement_name $sql 2 $bind_vars] $lob_argv - } else { - eval [list db_exec $command $db $full_statement_name $sql] $lob_argv - } - } - - } elseif {$command eq "blob_dml_file"} { - # PostgreSQL: - db_with_handle -dbn $dbn db { - # another ugly hack to avoid munging Tcl files. - # __lob_id needs to be set inside of a query (.xql) file for this - # to work. Say for example that you need to create a lob. In - # Oracle, you would do something like: - - # db_dml update_photo "update foo set bar = empty_blob() - # where bar = :bar - # returning foo into :1" -blob_files [list $file] - # for PostgreSQL we can do the equivalent by placing the following - # in a query file: - # update foo set bar = [set __lob_id [db_string get_id "select empty_lob()"]] - # where bar = :bar - - # __lob_id acts as a flag that signals that blob_dml_file is - # required, and it is also used to pass along the lob_id. It - # is unsert afterwards to avoid name clashes with other invocations - # of this routine. - # (DanW - Openacs) - - db_exec dml $db $full_statement_name $sql - if {[uplevel {info exists __lob_id}]} { - ns_pg blob_dml_file $db [uplevel {set __lob_id}] $blob_files - uplevel {unset __lob_id} - } - } - - } else { - # PostgreSQL: - db_with_handle -dbn $dbn db { - db_exec dml $db $full_statement_name $sql - } - } -} - - - - -ad_proc -public db_0or1row { - {-dbn ""} - -cache_key - {-cache_pool db_cache_pool} - statement_name - sql - args -} { - - Usage: -
- db_0or1row statement-name sql [ -bind bind_set_id | -bind bind_value_list ] \ - [ -column_array array_name | -column_set set_name ] - -- -
Performs the SQL query sql. If a row is returned, sets variables
- to column values (or a set or array populated if -column_array
- or column_set is specified) and returns 1. If no rows are returned,
- returns 0.
-
- @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
-
- # 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
- unset -nocomplain array_val
- }
-
- if { [info exists column_set] } {
- upvar 1 $column_set selection
- }
-
- 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 { $selection eq "" } {
- return 0
- }
-
- if { [info exists column_array] } {
- array set array_val [ns_set array $selection]
- } elseif { ![info exists column_set] } {
- for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
- uplevel 1 [list set [ns_set key $selection $i] [ns_set value $selection $i]]
- }
- }
-
- return 1
-}
-
-
-ad_proc -public db_1row { args } {
-
- A wrapper for db_0or1row, which produces an error if no rows are returned.
-
- @param args Arguments to be passed to db_0or1row. Check db_0or1row proc doc
- for details.
-
- @see db_0or1row
-
- @return 1 if variables are set.
-
-} {
- if { ![uplevel ::db_0or1row $args] } {
- return -code error "Query did not return any rows."
- }
-}
-
-if {[info commands ns_cache_transaction_begin] eq ""} {
- #
- # When the server has no support for ns_cache_transaction_*,
- # provide dummy procs to avoid runtime "if" statements.
- #
- proc ns_cache_transaction_begin args {;}
- proc ns_cache_transaction_commit args {;}
- proc ns_cache_transaction_rollback args {;}
-}
-
-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).
-
- To handle errors, use db_transaction {transaction_code} on_error {error_code_block}. Any error generated in
- transaction_code will be caught automatically and process control will transfer to error_code_block
- with a variable errmsg set. The error_code block can then clean up after the error, such as presenting a usable
- error message to the user. Following the execution of error_code_block the transaction will be aborted.
- If you want to explicitly abort the transaction, call db_abort_transaction
- from within the transaction_code block or the error_code block.
-
- Example 1:
- In this example, db_dml triggers an error, so control passes to the on_error block which prints a readable error.
-
- db_transaction {
- db_dml test "nonsense"
- } on_error {
- ad_return_error "Error in blah/foo/bar" "The error was: $errmsg"
- }
-
-
- Example 2:
- db_transaction {
- db_dml test {insert into footest values(1)}
- nonsense
- db_dml test {insert into footest values(2)}
- }
-
-
- @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
- } elseif { $arg_c == 2 } {
- # We think they're specifying an on_error block
- if {[lindex $args 0] ne "on_error" } {
- # Unexpected: they put something besides on_error as a connector.
- error $syn_err
- } else {
- # Success! We got an on_error code block.
- set on_error [lindex $args 1]
- }
- }
- # 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.
- set dbh $db
- # Remember that there's a transaction happening on this handle.
- if { ![info exists db_state(transaction_level,$dbh)] } {
- set db_state(transaction_level,$dbh) 0
- }
- set level [incr db_state(transaction_level,$dbh)]
- if { $level == 1 } {
- ns_db dml $dbh "begin transaction"
- ns_cache_transaction_begin
- }
- }
- # Execute the transaction code.
- set errno [catch {
- uplevel 1 $transaction_code
- } errmsg]
- incr db_state(transaction_level,$dbh) -1
-
- set err_p 0
- switch -- $errno {
- 0 {
- # TCL_OK
- }
- 2 {
- # TCL_RETURN
- }
- 3 {
- # TCL_BREAK - Abort the transaction and do the break.
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- db_release_unused_handles -dbn $dbn
- break
- }
- 4 {
- # TCL_CONTINUE - just ignore.
- }
- default {
- # TCL_ERROR or unknown error code: Its a real error.
- set err_p 1
- }
- }
-
- if { $err_p || [db_abort_transaction_p -dbn $dbn]} {
- # An error was triggered or the transaction has been aborted.
- db_abort_transaction -dbn $dbn
- if { [info exists on_error] && $on_error ne "" } {
-
- if {"postgresql" eq [db_type]} {
-
- # JCD: with postgres we abort the transaction prior to
- # executing the on_error block since there is nothing
- # you can do to "fix it" and keeping it meant things like
- # queries in the on_error block would then fail.
- #
- # Note that the semantics described in the proc doc
- # are not possible to support on PostgreSQL.
-
- # DRB: I removed the db_release_unused_handles call that
- # this patch included because additional aborts further
- # down triggered an illegal db handle error. I'm going to
- # have the code start a new transaction as well. If we
- # don't, if a transaction fails and the on_error block
- # fails, the on_error block DML will have been committed.
- # Starting a new transaction here means that DML by both
- # the transaction and on_error clause will be rolled back.
- # On the other hand, if the on_error clause doesn't fail,
- # any DML in that block will be committed. This seems more
- # useful than simply punting ...
-
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- ns_db dml $dbh "begin transaction"
- ns_cache_transaction_begin
-
- }
-
- # An on_error block exists, so execute it.
-
- set errno [catch {
- uplevel 1 $on_error
- } on_errmsg]
-
- # Determine what do with the error.
- set err_p 0
- switch -- $errno {
- 0 {
- # TCL_OK
- }
-
- 2 {
- # TCL_RETURN
- }
- 3 {
- # TCL_BREAK
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- db_release_unused_handles
- break
- }
- 4 {
- # TCL_CONTINUE - just ignore.
- }
- default {
- # TCL_ERROR or unknown error code: Its a real error.
- set err_p 1
- }
- }
-
- if { $err_p } {
- # An error was generated from the $on_error block.
- if { $level == 1} {
- # We're at the top level, so we abort the transaction.
- set db_state(db_abort_p,$dbh) 0
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- }
- # We throw this error because it was thrown from the error handling code that the programmer must fix.
- error $on_errmsg $::errorInfo $::errorCode
- } else {
- # Good, no error thrown by the on_error block.
- if { [db_abort_transaction_p -dbn $dbn] } {
- # This means we should abort the transaction.
- if { $level == 1 } {
- set db_state(db_abort_p,$dbh) 0
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- # We still have the transaction generated error. We don't want to throw it, so we log it.
- ns_log Error "Aborting transaction due to error:\n$errmsg"
- } else {
- # Propagate the error up to the next level.
- error $errmsg $::errorInfo $::errorCode
- }
- } else {
- # The on_error block has resolved the transaction error. If we're at the top, commit and exit.
- # Otherwise, we continue on through the lower transaction levels.
- if { $level == 1} {
- ns_db dml $dbh "end transaction"
- ns_cache_transaction_commit
- }
- }
- }
- } else {
- # There is no on_error block, yet there is an error, so we propagate it.
- if { $level == 1 } {
- set db_state(db_abort_p,$dbh) 0
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- error "Transaction aborted: $errmsg" $::errorInfo $::errorCode
- } else {
- db_abort_transaction -dbn $dbn
- error $errmsg $::errorInfo $::errorCode
- }
- }
- } else {
- # There was no error from the transaction code.
- if { [db_abort_transaction_p -dbn $dbn] } {
- # The user requested the transaction be aborted.
- if { $level == 1 } {
- set db_state(db_abort_p,$dbh) 0
- ns_db dml $dbh "abort transaction"
- ns_cache_transaction_rollback
- }
- } elseif { $level == 1 } {
- # Success! No errors and no requested abort. Commit.
- ns_db dml $dbh "end transaction"
- ns_cache_transaction_commit
- }
- }
-}
-
-
-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".
-
- @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
-
- db_with_handle -dbn $dbn db {
- # We set the abort flag to true.
- set db_state(db_abort_p,$db) 1
- }
-}
-
-
-ad_proc -private db_abort_transaction_p {{-dbn ""}} {
- @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
-
- db_with_handle -dbn $dbn db {
- if { [info exists db_state(db_abort_p,$db)] } {
- return $db_state(db_abort_p,$db)
- } else {
- # No abort flag registered, so we assume everything is ok.
- return 0
- }
- }
-}
-
-
-ad_proc -public db_name {{-dbn ""}} {
-
- @return the name of the database as reported by the driver.
-
- @param dbn The database name to use. If empty_string, uses the default database.
-} {
- db_with_handle -dbn $dbn db {
- set dbtype [ns_db dbtype $db]
- }
- return $dbtype
-}
-
-
-ad_proc -public db_get_username {{-dbn ""}} {
- @return the username parameter from the driver section of the
- first database pool for the dbn.
-
- @param dbn The database name to use. If empty_string, uses the default database.
-} {
- set pool [lindex [db_available_pools $dbn] 0]
- return [ns_config "ns/db/pool/$pool" User]
-}
-
-ad_proc -public db_get_password {{-dbn ""}} {
- @return the password parameter from the driver section of the
- first database pool for the dbn.
-
- @param dbn The database name to use. If empty_string, uses the default database.
-} {
- set pool [lindex [db_available_pools $dbn] 0]
- return [ns_config "ns/db/pool/$pool" Password]
-}
-
-ad_proc -public db_get_sql_user {{-dbn ""}} {
- Oracle only.
-
- - @return a valid Oracle user@database/password string to access a - database through sqlplus. - -
- This proc may well work for databases other than Oracle, - but its return value won't really be of any use. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set pool [lindex [db_available_pools $dbn] 0] - set datasource [ns_config "ns/db/pool/$pool" DataSource] - if { $datasource ne "" && ![string is space $datasource] } { - return "[ns_config ns/db/pool/$pool User]/[ns_config ns/db/pool/$pool Password]@$datasource" - } else { - return "[ns_config ns/db/pool/$pool User]/[ns_config ns/db/pool/$pool Password]" - } -} - -ad_proc -public db_get_pgbin {{-dbn ""}} { - PostgreSQL only. - -
- @return the pgbin parameter from the driver section of the first database pool. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set pool [lindex [db_available_pools $dbn] 0] - set driver [ns_config "ns/db/pool/$pool" Driver] - return [ns_config "ns/db/driver/$driver" pgbin] -} - - -ad_proc -public db_get_port {{-dbn ""}} { - PostgreSQL only. - -
- @return the port number from the first database pool. It assumes the - datasource is properly formatted since we've already verified that we - can connect to the pool. - It returns an empty string for an empty port value. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set pool [lindex [db_available_pools $dbn] 0] - set datasource [ns_config "ns/db/pool/$pool" DataSource] - set last_colon_pos [string last ":" $datasource] - if { $last_colon_pos == -1 } { - ns_log Error "datasource contains no \":\"? datasource = $datasource" - return "" - } - set first_colon_pos [string first ":" $datasource] - - if { $first_colon_pos == $last_colon_pos || ($last_colon_pos - $first_colon_pos) == 1 } { - # No port specified - return "" - } - - return [string range $datasource $first_colon_pos+1 $last_colon_pos-1] -} - - -ad_proc -public db_get_database {{-dbn ""}} { - PostgreSQL only. - -
- @return the database name from the first database pool. It assumes the - datasource is properly formatted since we've already verified that we - can connect to the pool. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set pool [lindex [db_available_pools $dbn] 0] - set datasource [ns_config "ns/db/pool/$pool" DataSource] - set last_colon_pos [string last ":" $datasource] - if { $last_colon_pos == -1 } { - ns_log Error "datasource contains no \":\"? datasource = $datasource" - return "" - } - return [string range $datasource $last_colon_pos+1 end] -} - - -ad_proc -public db_get_dbhost { - {-dbn ""} -} { - PostgreSQL only. - -
- @return the name of the database host from the first database pool. - It assumes the datasource is properly formatted since we've already - verified that we can connect to the pool. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set pool [lindex [db_available_pools $dbn] 0] - set datasource [ns_config "ns/db/pool/$pool" DataSource] - set first_colon_pos [string first ":" $datasource] - if { $first_colon_pos == -1 } { - ns_log Error "datasource contains no \":\"? datasource = $datasource" - return "" - } - return [string range $datasource 0 $first_colon_pos-1] -} - -ad_proc -public db_source_sql_file { - {-dbn ""} - {-callback apm_ns_write_callback} - file -} { - Sources a SQL file into Oracle (SQL*Plus format file) or - PostgreSQL (psql format file). - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set proc_name {db_source_sql_file} - set driverkey [db_driverkey $dbn] - - switch -- $driverkey { - - oracle { - set user_pass [db_get_sql_user -dbn $dbn] - cd [file dirname $file] - set fp [open "|[file join $::env(ORACLE_HOME) bin sqlplus] $user_pass @$file" "r+"] - fconfigure $fp -buffering line - puts $fp "exit" - - while { [gets $fp line] >= 0 } { - # Don't bother writing out lines which are purely whitespace. - if { ![string is space $line] } { - apm_callback_and_log $callback "[ns_quotehtml $line]\n" - } - } - close $fp - } - - postgresql { - set file_name [file tail $file] - - set pguser [db_get_username] - if { $pguser ne "" } { - set pguser "-U $pguser" - } - - set pgport [db_get_port] - if { $pgport ne "" } { - set pgport "-p $pgport" - } - - set pgpass [db_get_password] - if { $pgpass ne "" } { - set pgpass "<<$pgpass" - } - - # DRB: Submitted patch was in error - the driver opens a -h hostname connection - # unless the hostname is localhost. We need to do the same here. The submitted - # patch checked for a blank hostname, which fails in the driver. Arguably the - # driver's wrong but a lot of non-OpenACS folks use it, and even though I'm the - # maintainer we shouldn't break existing code over such trivialities... - # GN: windows requires $pghost "-h ..." - - if { ([db_get_dbhost] eq "localhost" || [db_get_dbhost] eq "") - && $::tcl_platform(platform) ne "windows" - } { - set pghost "" - } else { - set pghost "-h [db_get_dbhost]" - } - - set errno [catch { - cd [file dirname $file] - set fp [open "|[file join [db_get_pgbin] psql] $pghost $pgport $pguser -f $file [db_get_database] $pgpass" "r"] - } errorMsg] - - if {$errno > 0} { - set error_found 1 - set error_lines $errorMsg - } else { - while { [gets $fp line] >= 0 } { - # Don't bother writing out lines which are purely whitespace. - if { ![string is space $line] } { - apm_callback_and_log $callback "[ns_quotehtml $line]\n" - } - } - - # PSQL dumps errors and notice information on stderr, and has no option to turn - # this off. So we have to chug through the "error" lines looking for those that - # really signal an error. - - set errno [ catch { - close $fp - } error] - - if { $errno == 2 } { - return $error - } - - # Just filter out the "NOTICE" lines, so we get the stack dump along with real - # ERRORs. This could be done with a couple of opaque-looking regexps... - - set error_found 0 - foreach line [split $error "\n"] { - if { [string first NOTICE $line] == -1 } { - append error_lines "$line\n" - set error_found [expr { $error_found - || [string first ERROR $line] != -1 - || [string first FATAL $line] != -1 } ] - } - } - } - - if { $error_found } { - return -code error -errorinfo $error_lines -errorcode $::errorCode $error_lines - } - - } - - nsodbc { - error "$proc_name is not supported for this database." - } - default { - error "$proc_name is not supported for this database." - } - } -} - -ad_proc -public db_load_sql_data { - {-dbn ""} - {-callback apm_ns_write_callback} - file -} { - Loads a CSV formatted file into a table using PostgreSQL's COPY command or - Oracle's SQL*Loader utility. The file name format consists of a sequence - number used to control the order in which tables are loaded, and the table - name with "-" replacing "_". This is a bit of a kludge but greatly speeds - the loading of large amounts of data, such as is done when various "ref-*" - packages are installed. - - @param dbn The database name to use. If empty_string, uses the default database. - @param file Filename in the format dd-table-name.ctl where 'dd' is a sequence number - used to control the order in which data is loaded. This file is an - RDBMS-specific data loader control file. - -} { - - switch [db_driverkey $dbn] { - - oracle { - set user_pass [db_get_sql_user -dbn $dbn] - set tmpnam [ad_tmpnam] - - set fd [open $file r] - set file_contents [read $fd] - close $fd - - set file_contents [subst $file_contents] - - set fd1 [open "${tmpnam}.ctl" w] - puts $fd1 $file_contents - close $fd1 - - cd [file dirname $file] - - set fd [open "|[file join $::env(ORACLE_HOME) bin sqlldr] userid=$user_pass control=$tmpnam" "r"] - - while { [gets $fd line] >= 0 } { - # Don't bother writing out lines which are purely whitespace. - if { ![string is space $line] } { - apm_callback_and_log $callback "[ns_quotehtml $line]\n" - } - } - close $fd - } - - postgresql { - set pguser [db_get_username] - if { $pguser ne "" } { - set pguser "-U $pguser" - } - - set pgport [db_get_port] - if { $pgport ne "" } { - set pgport "-p $pgport" - } - - set pgpass [db_get_password] - if { $pgpass ne "" } { - set pgpass "<<$pgpass" - } - - if { [db_get_dbhost] eq "localhost" || [db_get_dbhost] eq "" } { - set pghost "" - } else { - set pghost "-h [db_get_dbhost]" - } - - set fd [open $file r] - set copy_command [subst -nobackslashes [read $fd]] - close $fd - set copy_file [ns_mktemp [ad_tmpdir]/psql-copyfile-XXXXXX] - set fd [open $copy_file "CREAT EXCL WRONLY" 0600] - puts $fd $copy_command - close $fd - - if { $::tcl_platform(platform) eq "windows" } { - set fp [open "|[file join [db_get_pgbin] psql] -f $copy_file $pghost $pgport $pguser [db_get_database]" "r"] - } else { - set fp [open "|[file join [db_get_pgbin] psql] -f $copy_file $pghost $pgport $pguser [db_get_database] $pgpass" "r"] - } - - while { [gets $fp line] >= 0 } { - # Don't bother writing out lines which are purely whitespace. - if { ![string is space $line] } { - apm_callback_and_log $callback "[ns_quotehtml $line]\n" - } - } - - # PSQL dumps errors and notice information on stderr, and has no option to turn - # this off. So we have to chug through the "error" lines looking for those that - # really signal an error. - - set errno [ catch { - close $fp - } error] - - # remove the copy file. - file delete -force -- $copy_file - - if { $errno == 2 } { - return $error - } - - # Just filter out the "NOTICE" lines, so we get the stack dump along with real - # ERRORs. This could be done with a couple of opaque-looking regexps... - - set error_found 0 - foreach line [split $error "\n"] { - if { [string first NOTICE $line] == -1 } { - append error_lines "$line\n" - set error_found [expr { $error_found - || [string first ERROR $line] != -1 - || [string first FATAL $line] != -1 } ] - } - } - - if { $error_found } { - return -code error -errorinfo $error_lines -errorcode $::errorCode $error_lines - } - - } - - nsodbc { - error "db_load_sql_data is not supported for this database." - } - default { - error "db_load_sql_data is not supported for this database." - } - } -} - -ad_proc -public db_source_sqlj_file { - {-dbn ""} - {-callback apm_ns_write_callback} - file -} { - Oracle only. -
- Sources a SQLJ file using loadjava. - - @param dbn The database name to use. If empty_string, uses the default database. -} { - set user_pass [db_get_sql_user -dbn $dbn] - set fp [open "|[file join $::env(ORACLE_HOME) bin loadjava] -verbose -user $user_pass $file" "r"] - - # Despite the fact that this works, the text does not get written to the stream. - # The output is generated as an error when you attempt to close the input stream as - # done below. - while { [gets $fp line] >= 0 } { - # Don't bother writing out lines which are purely whitespace. - if { ![string is space $line] } { - apm_callback_and_log $callback "[ns_quotehtml $line]\n" - } - } - if { [catch { - close $fp - } errmsg] } { - apm_callback_and_log $callback "[ns_quotehtml $errmsg]\n" - } -} - - -ad_proc -public db_tables { - -pattern - {-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. - - @author Don Baccus (dhogaza@pacifier.com) - @author Lars Pind (lars@pinds.com) - - @change-log yon@arsdigita.com 20000711 changed to return lower case table names -} { - set proc_name {db_tables} - set driverkey [db_driverkey $dbn] - - switch -- $driverkey { - oracle { - set sql_table_names_with_pattern { - select lower(table_name) as table_name - from user_tables - where table_name like upper(:pattern) - } - set sql_table_names_without_pattern { - select lower(table_name) as table_name - from user_tables - } - } - - postgresql { - set sql_table_names_with_pattern { - select relname as table_name - from pg_class - where relname like lower(:pattern) and - relname !~ '^pg_' and relkind = 'r' - } - set sql_table_names_without_pattern { - select relname as table_name - from pg_class - where relname !~ '^pg_' and relkind = 'r' - } - } - - nsodbc - - default { - error "$proc_name is not supported for this database." - } - } - - set tables [list] - if { [info exists pattern] } { - db_foreach -dbn $dbn table_names_with_pattern \ - $sql_table_names_with_pattern { - lappend tables $table_name - } - } else { - db_foreach -dbn $dbn table_names_without_pattern \ - $sql_table_names_without_pattern { - lappend tables $table_name - } - } - - return $tables -} - - -ad_proc -public db_table_exists {{-dbn ""} table_name } { - @return 1 if a table with the specified name exists in the database, otherwise 0. - - @param dbn The database name to use. If empty_string, uses the default database. - - @author Don Baccus (dhogaza@pacifier.com) - @author Lars Pind (lars@pinds.com) -} { - set proc_name {db_table_exists} - set driverkey [db_driverkey $dbn] - - switch -- $driverkey { - oracle { - set n_rows [db_string -dbn $dbn table_count { - select count(*) from user_tables - where table_name = upper(:table_name) - }] - } - - postgresql { - set n_rows [db_string -dbn $dbn table_count { - select count(*) from pg_class - where relname = lower(:table_name) and - relname !~ '^pg_' and relkind = 'r' - }] - } - - nsodbc - - default { - error "$proc_name is not supported for this database." - } - } - - return $n_rows -} - - -ad_proc -public db_columns {{-dbn ""} table_name } { - @return a Tcl list of all the columns in the table with the given name. - - @param dbn The database name to use. If empty_string, uses the default database. - - @author Lars Pind (lars@pinds.com) - - @change-log yon@arsdigita.com 20000711 changed to return lower case column names -} { - set columns [list] - - # Works for both Oracle and PostgreSQL: - db_foreach -dbn $dbn table_column_names { - select lower(column_name) as column_name - from user_tab_columns - where table_name = upper(:table_name) - } { - lappend columns $column_name - } - - return $columns -} - - -ad_proc -public db_column_exists {{-dbn ""} table_name column_name } { - @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] - - # Works for both Oracle and PostgreSQL: - set n_rows [db_string -dbn $dbn column_exists { - select count(*) - from user_tab_columns - where table_name = upper(:table_name) - and column_name = upper(:column_name) - }] - - return [expr {$n_rows > 0}] -} - - -ad_proc -public db_column_type {{-dbn ""} {-complain:boolean} table_name column_name } { - - @return the Oracle Data Type for the specified column. - @return -1 if the table or column doesn't exist. - @return an error if table or column doesn't exist and -complain flag was specified - - @param dbn The database name to use. If empty_string, uses the default database. - @param complain throw an error when datatype is not found - - @author Yon Feldman (yon@arsdigita.com) - - @change-log 10 July, 2000: changed to return error - if column name doesn't exist - (mdettinger@arsdigita.com) - - @change-log 11 July, 2000: changed to return lower case data types - (yon@arsdigita.com) - - @change-log 11 July, 2000: changed to return error using the db_string default clause - (yon@arsdigita.com) - -} { - # Works for both Oracle and PostgreSQL: - set datatype [db_string -dbn $dbn column_type_select " - select data_type as data_type - from user_tab_columns - where upper(table_name) = upper(:table_name) - and upper(column_name) = upper(:column_name) - " -default "-1"] - if {$complain_p && $datatype == -1} { - error "Datatype for $table_name.$column_name not found." - } else { - return $datatype - } -} - - -ad_proc -public ad_column_type {{-dbn ""} table_name column_name } { - - @return 'numeric' for number type columns, 'text' otherwise - Throws an error if no such column exists. - - @param dbn The database name to use. If empty_string, uses the default database. - - @author Yon Feldman (yon@arsdigita.com) - -} { - set column_type [db_column_type -dbn $dbn $table_name $column_name] - - if { $column_type == -1 } { - return "Either table $table_name doesn't exist or column $column_name doesn't exist" - } elseif {$column_type ne "NUMBER" } { - return "numeric" - } else { - return "text" - } -} - - -ad_proc -public db_write_clob {{-dbn ""} statement_name sql args } { - @param dbn The database name to use. If empty_string, uses the default database. -} { - ad_arg_parser { bind } $args - set proc_name {db_write_clob} - set driverkey [db_driverkey $dbn] - - # TODO: Below, is db_qd_get_fullname necessary? Why this - # difference between Oracle and Postgres code? - # --atp@piskorski.com, 2003/04/09 10:00 EDT - - switch -- $driverkey { - oracle { - set full_statement_name [db_qd_get_fullname $statement_name] - db_with_handle -dbn $dbn db { - db_exec write_clob $db $full_statement_name $sql - } - } - - postgresql { - db_with_handle -dbn $dbn db { - db_exec write_clob $db $statement_name $sql - } - } - - nsodbc - - default { - error "$proc_name is not supported for this database." - } - } -} - - -ad_proc -public db_write_blob {{-dbn ""} statement_name sql args } { - @param dbn The database name to use. If empty_string, uses the default database. -} { - ad_arg_parser { bind } $args - set full_statement_name [db_qd_get_fullname $statement_name] - db_with_handle -dbn $dbn db { - db_exec_lob write_blob $db $full_statement_name $sql - } -} - - -ad_proc -public db_blob_get_file {{-dbn ""} statement_name sql args } { - @param dbn The database name to use. If empty_string, uses the default database. - -
- TODO:
- This proc should probably be changed to take a final
- file argument, only, rather than the current
- args variable length argument list. Currently, it is
- called only 4 places in OpenACS, and each place args,
- if used at all, is always "-file $file". However,
- such a change might break custom code... I'm not sure.
- --atp@piskorski.com, 2003/04/09 11:39 EDT
-
-} {
- ad_arg_parser { bind file args } $args
- set proc_name {db_blob_get_file}
- set driverkey [db_driverkey $dbn]
-
- set full_statement_name [db_qd_get_fullname $statement_name]
-
- switch -- $driverkey {
- oracle {
- db_with_handle -dbn $dbn db {
- db_exec_lob blob_get_file $db $full_statement_name $sql $file
- }
- }
-
- postgresql {
- db_with_handle -dbn $dbn db {
- db_exec_lob blob_select_file $db $full_statement_name $sql $file
- }
- }
-
- nsodbc -
- default {
- error "$proc_name is not supported for this database."
- }
- }
-}
-
-
-ad_proc -public db_blob_get {{-dbn ""} statement_name sql args } {
- PostgreSQL only.
-
- @param dbn The database name to use. If empty_string, uses the default database.
-} {
- ad_arg_parser { bind } $args
- set proc_name {db_blob_get}
- set driverkey [db_driverkey $dbn]
-
- switch -- $driverkey {
-
- postgresql {
- set full_statement_name [db_qd_get_fullname $statement_name]
- db_with_handle -dbn $dbn db {
- set data [db_exec_lob blob_get $db $full_statement_name $sql]
- }
- return $data
- }
-
- oracle {
- set pre_sql $sql
- set full_statement_name [db_qd_get_fullname $statement_name]
- set sql [db_qd_replace_sql $full_statement_name $pre_sql]
-
- # insert Tcl variable values (borrowed from Dan W - olah)
- if {$sql ne $pre_sql } {
- set sql [uplevel 2 [list subst -nobackslashes $sql]]
- }
-
- set data [db_string dummy_statement_name $sql]
- return $data
- }
-
- nsodbc -
- default {
- error "$proc_name is not supported for this database."
- }
- }
-}
-
-
-ad_proc -private db_exec_lob {
- {-ulevel 2}
- type
- db
- statement_name
- pre_sql
- {file ""}
-} {
- A helper procedure to execute a SQL statement, potentially binding
- depending on the value of the $bind variable in the calling environment
- (if set).
-} {
- set proc_name {db_exec_lob}
- set driverkey [db_driverkey -handle_p 1 $db]
-
- # Note: db_exec_lob is marked as private and in the entire
- # toolkit, is ONLY called from a few other procs defined in this
- # same file. So we definitely could change it to take a -dbn
- # switch and remove the passed in db handle altogether, and call
- # 'db_driverkey -dbn' rather than 'db_driverkey -handle'. But,
- # db_exec NEEDS 'db_driverkey -handle', so we might as well use it
- # here too. --atp@piskorski.com, 2003/04/09 12:13 EDT
-
- # TODO: Using this as a wrapper for the separate _oracle and
- # _postgresql versions of this proc is ugly. But also simplest
- # and safest at this point, as it let me change as little as
- # possible of those two relatively complex procs.
- # --atp@piskorski.com, 2003/04/09 11:55 EDT
-
- switch -- $driverkey {
- oracle {
- set which_proc {db_exec_lob_oracle}
- }
- postgresql {
- set which_proc {db_exec_lob_postgresql}
- }
-
- nsodbc -
- default {
- error "$proc_name is not supported for this database."
- }
- }
-
- ns_log Debug "$proc_name: $which_proc -ulevel [expr {$ulevel +1}] $type $db $statement_name $pre_sql $file"
- return [$which_proc -ulevel [expr {$ulevel +1}] $type $db $statement_name $pre_sql $file]
-}
-
-
-ad_proc -private db_exec_lob_oracle {
- {-ulevel 2}
- type
- db
- statement_name
- pre_sql
- {file ""}
-} {
- A helper procedure to execute a SQL statement, potentially binding
- depending on the value of the $bind variable in the calling environment
- (if set).
-} {
- set start_time [expr {[clock clicks -microseconds]/1000.0}]
-
- set sql [db_qd_replace_sql $statement_name $pre_sql]
-
- # insert Tcl variable values (OpenACS - Dan)
- if {$sql ne $pre_sql } {
- set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
- }
-
- set file_storage_p 0
- upvar $ulevel storage_type storage_type
-
- if {[info exists storage_type] && $storage_type eq "file"} {
- set file_storage_p 1
- set original_type $type
- set qtype 1row
- ns_log Debug "db_exec_lob: file storage in use"
- } else {
- set qtype $type
- ns_log Debug "db_exec_lob: blob storage in use"
- }
-
- set errno [catch {
- upvar bind bind
-
- # Below, note that 'ns_ora blob_get_file' takes 3 parameters,
- # while 'ns_ora write_blob' takes only 2. So if file is empty
- # string (which it always will/should be for $qtype
- # write_blob), we must not pass any 3rd parameter to the
- # ns_ora command: --atp@piskorski.com, 2003/04/09 15:10 EDT
-
- if { [info exists bind] && [llength $bind] != 0 } {
- if { [llength $bind] == 1 } {
- if { $file eq "" } {
- # gn: not sure, why the eval was ever needed (4 times)
- set selection [eval [list ns_ora $qtype $db -bind $bind $sql]]
- } else {
- set selection [eval [list ns_ora $qtype $db -bind $bind $sql $file]]
- }
-
- } else {
- set bind_vars [ns_set create]
- foreach { name value } $bind {
- ns_set put $bind_vars $name $value
- }
- if { $file eq "" } {
- set selection [eval [list ns_ora $qtype $db -bind $bind_vars $sql]]
- } else {
- set selection [eval [list ns_ora $qtype $db -bind $bind_vars $sql $file]]
- }
- }
-
- } else {
- if { $file eq "" } {
- set selection [uplevel $ulevel [list ns_ora $qtype $db $sql]]
- } else {
- set selection [uplevel $ulevel [list ns_ora $qtype $db $sql $file]]
- }
- }
-
- if {$file_storage_p} {
- set content [ns_set value $selection 0]
- for {set i 0} {$i < [ns_set size $selection]} {incr i} {
- set name [ns_set key $selection $i]
- if {$name eq "content"} {
- set content [ns_set value $selection $i]
- }
- }
-
- switch -- $original_type {
-
- blob_get_file {
- if {[file exists $content]} {
- file copy -- $content $file
- return $selection
- } else {
- error "file: $content doesn't exist"
- }
- }
-
- write_blob {
-
- if {[file exists $content]} {
- set ofp [open $content r]
- fconfigure $ofp -encoding binary
- ns_writefp $ofp
- close $ofp
- return $selection
- } else {
- error "file: $content doesn't exist"
- }
- }
- }
- } else {
- return $selection
- }
-
- } error]
-
- ds_collect_db_call $db $type $statement_name $sql $start_time $errno $error
- if { $errno == 2 } {
- return $error
- }
-
- return -code $errno -errorinfo $::errorInfo -errorcode $::errorCode $error
-}
-
-
-ad_proc -private db_exec_lob_postgresql {
- {-ulevel 2}
- type
- db
- statement_name
- pre_sql
- {file ""}
-} {
- A helper procedure to execute a SQL statement, potentially binding
- depending on the value of the $bind variable in the calling environment
- (if set).
-
- Low level replacement for db_exec which emulates blob handling.
-
-} {
- set start_time [expr {[clock clicks -microseconds]/1000.0}]
-
- # Query Dispatcher (OpenACS - ben)
- set sql [db_qd_replace_sql $statement_name $pre_sql]
-
- # insert Tcl variable values (OpenACS - Dan)
- if {$sql ne $pre_sql } {
- set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
- }
- # create a function definition statement for the inline code
- # binding is emulated in tcl. (OpenACS - Dan)
-
- set errno [catch {
- upvar bind bind
- if { [info exists bind] && [llength $bind] != 0 } {
- if { [llength $bind] == 1 } {
- set bind_vars [list]
- set len [ns_set size $bind]
- for {set i 0} {$i < $len} {incr i} {
- lappend bind_vars [ns_set key $bind $i] \
- [ns_set value $bind $i]
- }
- set lob_sql [db_bind_var_substitution $sql $bind_vars]
- } else {
- set lob_sql [db_bind_var_substitution $sql $bind]
- }
- } else {
- set lob_sql [uplevel $ulevel [list db_bind_var_substitution $sql]]
- }
-
- # get the content - asssume it is in column 0, or optionally it can
- # be returned as "content" with the storage type indicated by the
- # "storage_type" column.
-
- set selection [ns_db 1row $db $lob_sql]
- set content [ns_set value $selection 0]
- for {set i 0} {$i < [ns_set size $selection]} {incr i} {
- set name [ns_set key $selection $i]
- if {$name eq "storage_type"} {
- set storage_type [ns_set value $selection $i]
- } elseif {$name eq "content"} {
- set content [ns_set value $selection $i]
- }
- }
-
- # this is an ugly hack, but it allows content to be written
- # to a file/connection if it is stored as a lob or if it is
- # stored in the content-repository as a file. (DanW - Openacs)
-
- switch -- $type {
-
- blob_get {
-
- if {[info exists storage_type]} {
- switch -- $storage_type {
- file {
- if {[file exists $content]} {
- set ifp [open $content r]
-
- # DRB: this could be made faster by setting the buffersize
- # to the size of the file, but for very large files allocating
- # that much more memory on top of that needed by Tcl for storage
- # of the data might not be wise.
-
- fconfigure $ifp -translation binary
-
- set data [read $ifp]
- close $ifp
- return $data
- } else {
- error "file: $content doesn't exist"
- }
- }
-
- lob {
- if {[regexp {^[0-9]+$} $content match]} {
- return [ns_pg blob_get $db $content]
- } else {
- error "invalid lob_id: should be an integer"
- }
- }
-
- default {
- error "invalid storage type"
- }
- }
- } elseif {[file exists $content]} {
- set ifp [open $content r]
- fconfigure $ifp -translation binary
- set data [read $ifp]
- close $ifp
- return $data
- } elseif {[regexp {^[0-9]+$} $content match]} {
- return [ns_pg blob_get $db $content]
- } else {
- error "invalid query"
- }
- }
-
- blob_select_file {
-
- if {[info exists storage_type]} {
- switch -- $storage_type {
- file {
- if {[file exists $content]} {
- file copy -- $content $file
- } else {
- error "file: $content doesn't exist"
- }
- }
-
- lob {
- if {[regexp {^[0-9]+$} $content match]} {
- ns_pg blob_select_file $db $content $file
- } else {
- error "invalid lob_id: should be an integer"
- }
- }
-
- default {
- error "invalid storage type"
- }
- }
- } elseif {[file exists $content]} {
- file copy -- $content $file
- } elseif {[regexp {^[0-9]+$} $content match]} {
- ns_pg blob_select_file $db $content $file
- } else {
- error "invalid query"
-
- # TODO: Page /file-storage/download-archive/index
- # fails here on cvs head both before and after my
- # mult-db db_* API work, I don't know why. See bug:
- # http://openacs.org/bugtracker/openacs/com/file-storage/bug?bug%5fnumber=427
- # --atp@piskorski.com, 2003/04/09 18:04 EDT
- }
- }
-
- write_blob {
-
- if {[info exists storage_type]} {
- switch -- $storage_type {
- file {
- if {[file exists $content]} {
- set ofp [open $content r]
- fconfigure $ofp -encoding binary
- ns_writefp $ofp
- close $ofp
- } else {
- error "file: $content doesn't exist"
- }
- }
-
- text {
- ns_write $content
- }
-
- lob {
- if {[regexp {^[0-9]+$} $content match]} {
- ns_pg blob_write $db $content
- } else {
- error "invalid lob_id: should be an integer"
- }
- }
-
- default {
- error "invalid storage type"
- }
- }
- } elseif {[file exists $content]} {
- set ofp [open $content r]
- fconfigure $ofp -encoding binary
- ns_writefp $ofp
- close $ofp
- } elseif {[regexp {^[0-9]+$} $content match]} {
- ns_pg blob_write $db $content
- } else {
- ns_write $content
- }
- }
- }
-
- return
-
- } error]
-
- set errinfo $::errorInfo
- set errcode $::errorCode
-
- ds_collect_db_call $db 0or1row $statement_name $sql $start_time $errno $error
-
- if { $errno == 2 } {
- return $error
- }
-
- 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)
-
-} {
- #
- # If the key pattern has meta characters, iterate over the entries.
- # Otherwise, make a direct lookup, without retrieving the all keys
- # from the cache, which can cause large mutex lock times.
- #
- if {[regexp {[*\]\[]} $cache_key_pattern]} {
- foreach key [ns_cache names $cache_pool $cache_key_pattern] {
- ns_cache flush $cache_pool $key
- }
- } else {
- ns_cache flush $cache_pool $cache_key_pattern
- }
-}
-
-ad_proc -public db_bounce_pools {{-dbn ""}} {
- @return Call ns_db bouncepool on all pools for the named database.
- @param dbn The database name to use. Uses the default database if not supplied.
-} {
- foreach pool [db_available_pools $dbn] {
- ns_db bouncepool $pool
- }
-}
-
-# Local variables:
-# mode: tcl
-# tcl-indent-level: 4
-# indent-tabs-mode: nil
-# End:
Index: openacs-4/packages/acs-tcl/tcl/01-database-procs-oracle.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/01-database-procs-oracle.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/01-database-procs-oracle.tcl 17 Jul 2019 17:44:11 -0000 1.1.2.1
@@ -0,0 +1,19 @@
+ad_library {
+
+ Oracle-specific database API and utility procs
+
+ @creation-date 15 Apr 2000
+ @author Jon Salz (jsalz@arsdigita.com)
+ @cvs-id $Id: 01-database-procs-oracle.tcl,v 1.1.2.1 2019/07/17 17:44:11 hectorr Exp $
+}
+
+# This file is now obsolete. All procs have been merged into
+# 00-database-procs.tcl, so that all supported databases are usable
+# with the db_* API all the time, regardless of which database type
+# OpenACS is using. --atp@piskorski.com, 2003/04/09 12:04 EDT
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/acs-tcl/tcl/01-database-procs-postgresql-postgresql.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/01-database-procs-postgresql-postgresql.xql,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/01-database-procs-postgresql-postgresql.xql 17 Jul 2019 17:44:11 -0000 1.1.2.1
@@ -0,0 +1,21 @@
+
+-handle_p 1 and pass the db handle.
+
+ Hmm, as of 2018, it seems that in most cases, db_driverkey is
+ called with a handle.
+
+ @return The driverkey for use in db_* API switch statements.
+
+ @author Andrew Piskorski (atp@piskorski.com)
+ @creation-date 2003/04/08
+} {
+ if { $handle_p } {
+ #
+ # In the case, the passed "dbn" is actually a
+ # handle. Determine from the handle the "pool" and from the
+ # "pool" the "dbn".
+ #
+ set handle $dbn
+ set pool [ns_db poolname $handle]
+ set key ::acs::db_pool_to_dbn($pool)
+ if {[info exists $key]} {
+ #
+ # First, try to get the variable from the per-thread
+ # variable (which is part of the blueprint).
+ #
+ set dbn [set $key]
+ } elseif { [nsv_exists db_pool_to_dbn $pool] } {
+ #
+ # Fallback to nsv (old style), when for whatever
+ # reasons, the namespaced variable is not available.
+ #
+ ns_log notice "db_driverkey $handle_p dbn <$dbn> VIA NSV"
+ set dbn [nsv_get db_pool_to_dbn $pool]
+ } else {
+ #
+ # db_pool_to_dbn_init runs on startup, so other than some
+ # broken code deleting the nsv key (very unlikely), the
+ # only way this could happen is for someone to call this
+ # proc with a db handle from a pool which is not part of
+ # any dbn.
+
+ error "No database name (dbn) found for pool '$pool'. Check the 'ns/server/[ns_info server]/acs/database' section of your config file."
+ }
+ }
+
+ set key ::acs::db_driverkey($dbn)
+ if {[info exists $key]} {
+ return [set $key]
+ }
+
+ if { ![nsv_exists db_driverkey $dbn] } {
+ # This ASSUMES that any overriding of this default value via
+ # "ns_param driverkey_dbn" has already been done:
+
+ if { $handle_p } {
+ set driver [ns_db driver $handle]
+ } else {
+ db_with_handle -dbn $dbn handle {
+ set driver [ns_db driver $handle]
+ }
+ }
+
+ # These are the default driverkey values, if they are not set
+ # in the config file:
+
+ if { [string match "Oracle*" $driver] } {
+ set driverkey {oracle}
+ } elseif { $driver eq "PostgreSQL" } {
+ set driverkey "postgresql"
+ } elseif { $driver eq "ODBC" } {
+ set driverkey "nsodbc"
+ } else {
+ set driverkey {}
+ ns_log Error "db_driverkey: Unknown driver '$driver'."
+ }
+
+ nsv_set db_driverkey $dbn $driverkey
+ }
+
+ return [set $key [nsv_get db_driverkey $dbn]]
+}
+
+
+ad_proc -public db_type {} {
+ @return the RDBMS type (i.e. oracle, postgresql) this OpenACS installation is using.
+ The nsv ad_database_type is set up during the bootstrap process.
+} {
+ #
+ # Currently this should always be either "oracle" or "postgresql":
+ # --atp@piskorski.com, 2003/03/16 22:01 EST
+ #
+ # First check, if the database type exists in the namespaced
+ # variable. This should be always the case. If this fail, fall
+ # back to the old-style nsv (which can be costly in tight db loops)
+ #
+ if {[info exists ::acs::database_type]} {
+ set result $::acs::database_type
+ } else {
+ set result [nsv_get ad_database_type .]
+ ns_log Warning "db_type '$result' had to be obtained from the nsv 'ad_database_type'"
+ set ::acs::database_type $result
+ }
+ return $result
+}
+
+ad_proc -public db_compatible_rdbms_p { db_type } {
+ @return 1 if the given db_type is compatible with the current RDBMS.
+} {
+ return [expr { $db_type eq "" || [db_type] eq $db_type }]
+}
+
+
+
+ad_proc -private db_legacy_package_p { db_type_list } {
+ @return 1 if the package is a legacy package. We can only tell for certain if it explicitly supports Oracle 8.1.6 rather than the OpenACS more general oracle.
+} {
+ if {"oracle-8.1.6" in $db_type_list} {
+ return 1
+ }
+ return 0
+}
+
+ad_proc -public db_version {} {
+ @return the RDBMS version (i.e. 8.1.6 is a recent Oracle version; 7.1 a
+ recent PostgreSQL version)
+} {
+ return [nsv_get ad_database_version .]
+}
+
+ad_proc -public db_current_rdbms {} {
+ @return the current rdbms type and version.
+} {
+ return [db_rdbms_create [db_type] [db_version]]
+}
+
+ad_proc -public db_known_database_types {} {
+ @return a list of three-element lists describing the database engines known
+ to OpenACS. Each sublist contains the internal database name (used in file
+ paths, etc), the driver name, and a "pretty name" to be used in selection
+ forms displayed to the user.
+
+ The nsv containing the list is initialized by the bootstrap script and should
+ never be referenced directly by user code.
+} {
+ return $::acs::known_database_types
+}
+
+
+# db_null, db_quote, db_nullify_empty_string - were all previously
+# defined Oracle only, no Postgres equivalent existed at all. So, it
+# can't hurt anything to have them defined in when OpenACS is using
+# Postgres too. --atp@piskorski.com, 2003/04/08 05:34 EDT
+
+ad_proc -deprecated db_null {} {
+
+ @return an empty string, which Oracle thinks is null.
+
+ Deprecated: This routine was invented to provide an RDBMS-specific null
+ value but doesn't actually work. I (DRB) left it in to speed porting - we
+ should really clean up the code and pull out the calls instead, though.
+
+ @see ""
+} {
+ return ""
+}
+
+ad_proc -public db_quote { string } {
+ Quotes a string value to be placed in a SQL statement.
+} {
+ regsub -all {'} "$string" {''} result
+ return $result
+}
+
+ad_proc -public -deprecated db_nullify_empty_string { string } {
+ A convenience function that returns [db_null] if $string is the empty string.
+
+ Deprecated: essentially just returns the passed string.
+
+ @see: db_null
+} {
+ return $string
+}
+
+ad_proc -public db_boolean { bool } {
+ Converts a Tcl boolean (1/0) into a SQL boolean (t/f)
+ @return t or f
+} {
+ if { $bool } {
+ return "t"
+ } else {
+ return "f"
+ }
+}
+
+ad_proc -public db_nextval {
+ { -dbn "" }
+ sequence
+} {
+
+ Example:
+
+
+ set new_object_id [db_nextval acs_object_id_seq] ++ + @return the next value for a sequence. This can utilize a pool of + sequence values. + + @param sequence the name of an SQL sequence + + @param dbn The database name to use. If empty_string, uses the default database. + + @see /doc/db-api-detailed +} { + set driverkey [db_driverkey $dbn] + + # PostgreSQL has a special implementation here, any other db will + # probably work with the default: + + switch -- $driverkey { + + postgresql { + # # the following query will return a nextval if the sequnce + # # is of relkind = 'S' (a sequnce). if it is not of relkind = 'S' + # # we will try querying it as a view: + + # if { [db_0or1row -dbn $dbn nextval_sequence " + # select nextval('${sequence}') as nextval + # where (select relkind + # from pg_class + # where relname = '${sequence}') = 'S' + # "]} { + # return $nextval + # } else { + # ns_log debug "db_nextval: sequence($sequence) is not a real sequence. perhaps it uses the view hack." + # db_0or1row -dbn $dbn nextval_view "select nextval from ${sequence}" + # return $nextval + # } + # + # The code above is just for documentation, how it worked + # before the change below. We keep now a per-thread table of + # the "known" sequences to avoid at runtime the query, + # whether the specified sequence is a real sequence or a + # view. This change makes this function more than a factor + # of 2 faster than before. + # + # Note that solely the per-thread information won't work for + # freshly created sequences. Therefore, we keep the old + # code for checking at runtime in the database for such + # occurrences. + # + # Note that the sequence handling in OpenACS is quite a + # mess. Some sequences are named t_SEQUENCE (10 in + # dotlrn), others are called just SEQUENCE (18 in dotlrn), + # for some sequences, additional views are defined with an + # attribute 'nextval', and on top of this, db_nextval is + # called sometimes with the view name and sometimes with + # the sequence name. Checking this at runtime is + # unnecessary complex and costly. + # + # The best solution would certainly be to call "db_nextval" + # only with real sequence names (as defined in SQL). In that + # case, the whole function would for postgres would collapse + # to a single line, without any need for sequence name + # caching. But in that case, one should rename the sequences + # from t_SEQUENCE to SEQUENCE for postgres. + # + # However, since Oracle uses the pseudo column ".nextval", + # which is emulated via the view, it is not clear, how + # feasible this is to remove all such views without breaking + # installed applications. We keep for such cases the view, + # but nevertheless, the function "db_nextval" should always + # be called with names without the "t_" prefix to achieve + # Oracle compatibility. + + if {![info exists ::db::sequences]} { + ns_log notice "-- creating per thread sequence table" + namespace eval ::db {} + foreach s [db_list -dbn $dbn relnames "select relname, relkind from pg_class where relkind = 'S'"] { + set ::db::sequences($s) 1 + } + } + if {[info exists ::db::sequences(t_$sequence)]} { + #ns_log notice "-- found t_$sequence + #ad_log Warning "Deprecated sequence name 't_$sequence' is used. Use instead 't_$sequence'" + set nextval [db_string -dbn $dbn nextval "select nextval('t_$sequence')"] + } elseif {[info exists ::db::sequences($sequence)]} { + #ns_log notice "-- found $sequence" + set nextval [db_string -dbn $dbn nextval "select nextval('$sequence')"] + if {[string match t_* $sequence]} { + ad_log Warning "For portability, db_nextval should be called without the leading 't_' prefix: 't_$sequence'" + } + } elseif { [db_0or1row -dbn $dbn nextval_sequence " + select nextval('${sequence}') as nextval + where (select relkind + from pg_class + where relname = '${sequence}') = 'S' + "]} { + # + # We do not have an according sequence-table. Use the system catalog to check + # for the sequence + # + # ... the query sets nextval if it succeeds + # + ad_log Warning "Probably deprecated sequence name '$sequence' is used (no sequence table found)" + } else { + # + # Finally, there might be a view with a nextval + # + ns_log debug "db_nextval: sequence($sequence) is not a real sequence. perhaps it uses the view hack." + set nextval [db_string -dbn $dbn nextval "select nextval from $sequence"] + ad_log Warning "Using deprecated sequence view hack for '$sequence'. Is there not real sequence?" + } + + return $nextval + } + + oracle - + nsodbc - + default { + return [db_string -dbn $dbn nextval "select $sequence.nextval from dual"] + } + } +} + +ad_proc -public db_nth_pool_name { + { -dbn "" } + n +} { + @return the name of the pool used for the nth-nested selection (0-relative). + @param dbn The database name to use. If empty_string, uses the default database. +} { + set available_pools [db_available_pools $dbn] + + if { $n < [llength $available_pools] } { + set pool [lindex $available_pools $n] + } else { + return -code error "Ran out of database pools ($available_pools)" + } + return $pool +} + +if {[acs::icanuse "ns_db currenthandles"]} { + + ns_log notice "... I can use 'ns_db currenthandles'" + + # + # This branch uses "ns_db currenthandles" to implement + # "db_with_handle" instead of the old approach based on the global + # db_state variables. The new approach has the advantage that it + # is: + # + # - more robust (deletion and creation of the per-request variables, + # no coherency problem), + # - simpler, and + # - faster (less overhead per db_with_handle call) + # + # time {db_string . {select object_id from acs_objects limit 1}} 1000 + # old: 160-190 microseconds per iteration + # new: 150-180 microseconds per iteration + # + # time {xo::dc get_value . {select object_id from acs_objects limit 1}} 1000 + # old: 110-120 + # new: 105-110 + # + # set id -1 + # time {xo::dc get_value -prepare {int} . {select object_id from acs_objects where object_id=:id}} 1000 + # old: 80-100 + # new: 76-90 + # + # Still, more improvement can be done (GN). + # + ad_proc -public db_with_handle { + { -dbn "" } + db code_block + } { + Place a usable database handle in db and executes + code_block. + + @param dbn Database name to use. If empty_string, use the default database + @param db Name of the handle variable used in the code block + @param code_block code block to be executed with handle + } { + # + # Let the caller decide, how the handle variable is called in + # the code block. + # + upvar 1 $db dbh + + # + # Get the pools and the current allocated handles for this thread. + # + set pools [db_available_pools $dbn] + set currentHandles [ns_db currenthandles] + #ns_log notice "### pools <$pools> currentHandles <$currentHandles>" + + set db "" + set n 0 + foreach pool $pools { + # + # Do we have already handles allocated from this pool? + # + if {[dict exists $currentHandles $pool]} { + # + # Are there handles, which are not active (i.e. not in + # a currently open "ns_db select" and "ns_db getrow" + # context. + # + foreach {handle active} [dict get $currentHandles $pool] { + #ns_log notice "### FOUND pool $pool handle $handle active $active" + if {$active eq "0"} { + # + # We can use this handle + # + set db $handle + break + } + } + } else { + break + } + incr n + } + # + # In case, we got no handle above, we have to allocate a + # handle from the next pool, from which we have not got a + # handle before. + # + if {$db eq ""} { + # + # We were not successful above + # + set pool [lindex $pools $n] + if {$pool eq ""} { + ad_log error "handles from all pools <$pools> are exhausted" + error "could not obtain handle, all pools are exhausted" + } + set start_time [expr {[clock clicks -microseconds]/1000.0}] + #ns_log notice "### BEFORE gethandle $pool ($n)" + set errno [catch { + set db [ns_db gethandle $pool] + } error] + #ad_log notice "### AFTER gethandle $pool errno $errno handle <$db> currentHandles [ns_db currenthandles]" + ds_collect_db_call $db gethandle "" $pool $start_time $errno $error + if { $errno } { + ns_log notice "### RETURNING error $error" + return -code $errno -errorcode $::errorCode -errorinfo $::errorInfo $error + } + } + #ns_log notice "### db_with_handle has handle <$db>" + + set dbh $db + set errno [catch { uplevel 1 $code_block } error] + + # Unset dbh, so any subsequence use of this variable will bomb. + unset -nocomplain dbh + + # 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 + ns_log notice "### db_with_handle returned error <$error> for statement $code_block" + 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 + # to return errorCode or errorInfo since they may not exist + + return -code $errno $error + } + } + + # + # db_last_used_handle + # + ad_proc -private db_last_used_handle {{-dbn ""}} { + Get the last used inactive handle. + + @param dbn database name + @return last active handle or empty string + } { + set pools [db_available_pools $dbn] + set currentHandles [ns_db currenthandles] + + set last_used_handle "" + foreach pool $pools { + if {[dict exists $currentHandles $pool]} { + foreach {handle active} [dict get $currentHandles $pool] { + #ns_log notice "### FOUND pool $pool handle $handle active $active" + if {$active eq 0} { + set last_used_handle $handle + } + } + } + } + #ns_log notice "###### db_last_used_handle: <$currentHandles> last used $last_used_handle" + return $last_used_handle + } + + # + # db_release_unused_handles + # + ad_proc -public db_release_unused_handles {{-dbn ""}} { + Releases any database handles that are presently unused. + + @param dbn The database name to use. If empty_string, uses the default database. + } { + # we need the state array still for transaction handling + upvar "#0" [db_state_array_name_is -dbn $dbn] db_state + + set pools [db_available_pools $dbn] + set currentHandles [ns_db currenthandles] + + foreach pool $pools { + if {[dict exists $currentHandles $pool]} { + foreach {handle active} [dict get $currentHandles $pool] { + #ns_log notice "### FOUND pool $pool handle $handle active $active" + if {$active eq 0} { + # Don't release handles which are part of a transaction. + if { [info exists db_state(transaction_level,$handle)] + && $db_state(transaction_level,$handle) > 0 + } { + continue + } + set start_time [expr {[clock clicks -microseconds]/1000.0}] + ns_db releasehandle $handle + #ns_log notice "### AFTER releasehandle [ns_db currenthandles $pool]" + ds_collect_db_call $handle releasehandle "" "" $start_time 0 "" + } + } + } + } + } + + +} else { + + # + # This is the legacy branch without [ns_db currenthandles], using + # the global state variables. + # + ns_log notice "... cannot use 'ns_db currenthandles'" + + ad_proc -public db_with_handle { + { -dbn "" } + db code_block + } { + + Places a usable database handle in db and executes code_block. + + @param dbn The database name to use. If empty_string, uses the default database. + } { + upvar 1 $db dbh + upvar "#0" [db_state_array_name_is -dbn $dbn] db_state + + # Initialize bookkeeping variables. + if { ![info exists db_state(handles)] } { + set db_state(handles) [list] + } + if { ![info exists db_state(n_handles_used)] } { + set db_state(n_handles_used) 0 + } + if { $db_state(n_handles_used) >= [llength $db_state(handles)] } { + set pool [db_nth_pool_name -dbn $dbn $db_state(n_handles_used)] + set start_time [expr {[clock clicks -microseconds]/1000.0}] + set errno [catch { + set db [ns_db gethandle $pool] + } error] + ds_collect_db_call $db gethandle "" $pool $start_time $errno $error + lappend db_state(handles) $db + if { $errno } { + return -code $errno -errorcode $::errorCode -errorinfo $::errorInfo $error + } + } + set my_dbh [lindex $db_state(handles) $db_state(n_handles_used)] + set dbh $my_dbh + set db_state(last_used) $my_dbh + + incr db_state(n_handles_used) + set errno [catch { uplevel 1 $code_block } error] + incr db_state(n_handles_used) -1 + + # This may have changed while the code_block was being evaluated. + set db_state(last_used) $my_dbh + + # Unset dbh, so any subsequence use of this variable will bomb. + unset -nocomplain dbh + + # 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 + 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 + # to return errorCode or errorInfo since they may not exist + + return -code $errno $error + } + } + + ad_proc -private db_last_used_handle {{-dbn ""}} { + Get the last used handle + + @param dbn database name + @return last active handle or empty string + } { + upvar "#0" [db_state_array_name_is -dbn $dbn] db_state + + return $db_state(last_used) + } + + ad_proc -public db_release_unused_handles {{-dbn ""}} { + + Releases any database handles that are presently unused. + + @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 + + if { [info exists db_state(n_handles_used)] } { + # Examine the elements at the end of db_state(handles), killing off + # handles that are unused and not engaged in a transaction. + + set index_to_examine [expr { [llength $db_state(handles)] - 1 }] + while { $index_to_examine >= $db_state(n_handles_used) } { + set db [lindex $db_state(handles) $index_to_examine] + + # Stop now if the handle is part of a transaction. + if { [info exists db_state(transaction_level,$db)] + && $db_state(transaction_level,$db) > 0 + } { + break + } + + set pool [db_nth_pool_name -dbn $dbn $db_state(n_handles_used)] + set start_time [expr {[clock clicks -microseconds]/1000.0}] + ns_db releasehandle $db + ds_collect_db_call $db releasehandle "" "" $start_time 0 "" + incr index_to_examine -1 + } + set db_state(handles) [lrange $db_state(handles) 0 $index_to_examine] + } + } + + +} + +ad_proc -public db_resultrows {{-dbn ""}} { + @return the number of rows affected by the last DML command. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set driverkey [db_driverkey $dbn] + + switch -- $driverkey { + oracle { + return [ns_ora resultrows [db_last_used_handle -dbn $dbn]] + } + postgresql { + return [ns_pg ntuples [db_last_used_handle -dbn $dbn]] + } + nsodbc { + error "db_resultrows is not supported for this database." + } + default { + error "Unknown database driver. db_resultrows is not supported for this database." + } + } +} + + + +ad_proc -public db_exec_plsql { + {-dbn ""} + statement_name + sql + args +} { + + Oracle: + Executes a PL/SQL statement, and returns the variable of bind + variable
:1.
+
+ + PostgreSQL: + Performs a pl/pgsql function or procedure call. The caller must + perform a select query that returns the value of the function. + +
+ Examples: + +
+
+ # Oracle:
+ db_exec_plsql delete_note {
+ begin note.del(:note_id); end;
+ }
+
+ # PostgreSQL:
+ db_exec_plsql delete_note {
+ select note__delete(:note_id);
+ }
+
+
+ + If you need the return value, then do something like this: + +
+
+ # Oracle:
+ set new_note_id [db_exec_plsql create_note {
+ begin
+ :1 := note.new(
+ owner_id => :user_id,
+ title => :title,
+ body => :body,
+ creation_user => :user_id,
+ creation_ip => :peeraddr,
+ context_id => :package_id
+ );
+ end;
+ }]
+
+ # PostgreSQL:
+ set new_note_id [db_exec_plsql create_note {
+ select note__new(
+ null,
+ :user_id,
+ :title,
+ :body,
+ 'note',
+ now(),
+ :user_id,
+ :peeraddr,
+ :package_id
+ );
+ }]
+
+
+ + You can call several pl/sql statements at once, like this: + +
+
+ # Oracle:
+ db_exec_plsql delete_note {
+ begin
+ note.del(:note_id);
+ note.del(:another_note_id);
+ note.del(:yet_another_note_id);
+ end;
+ }
+
+ # PostgreSQL:
+ db_exec_plsql delete_note {
+ select note__delete(:note_id);
+ select note__delete(:another_note_id);
+ select note__delete(:yet_another_note_id);
+ }
+
+
+ If you are using xql files then put the body of the query in a
+ yourfilename-oracle.xql or yourfilename-postgresql.xql file, as appropriate. E.g. the first example
+ transformed to use xql files looks like this:
+
+
+
+ yourfilename.tcl:
+
+
+ db_exec_plsql delete_note {}
+
+
+ yourfilename-oracle.xql:
+
+
+ <fullquery name="delete_note"> + <querytext> + begin + note.del(:note_id); + end; + </querytext> + </fullquery>+ +
+ yourfilename-postgresql.xql:
+
+
+ <fullquery name="delete_note"> + <querytext> + select note__delete(:note_id); + </querytext> + </fullquery>+ + + @param dbn The database name to use. If empty_string, uses the default database. + + @see /doc/db-api-detailed +} { + ad_arg_parser { bind_output bind } $args + + # Query Dispatcher (OpenACS - ben) + set full_statement_name [db_qd_get_fullname $statement_name] + + if { [info exists bind_output] } { + return -code error "the -bind_output switch is not currently supported" + } + + set driverkey [db_driverkey $dbn] + switch -- $driverkey { + postgresql { + set postgres_p 1 + } + + oracle - + nsodbc - + default { + set postgres_p 0 + } + } + + if { ! $postgres_p } { + db_with_handle -dbn $dbn db { + # Right now, use :1 as the output value if it occurs in the statement, + # or not otherwise. + set test_sql [db_qd_replace_sql $full_statement_name $sql] + if { [regexp {:1} $test_sql] } { + return [db_exec exec_plsql_bind $db $full_statement_name $sql 2 1 ""] + } else { + return [db_exec dml $db $full_statement_name $sql] + } + } + } else { + # Postgres doesn't have PL/SQL, of course, but it does have + # PL/pgSQL and other procedural languages. Rather than assign the + # result to a bind variable which is then returned to the caller, + # the Postgres version of OpenACS requires the caller to perform a + # select query that returns the value of the function. + + # We are no longer calling db_string, which screws up the bind + # variable stuff otherwise because of calling environments. (ben) + + ad_arg_parser { bind_output bind } $args + + # I'm not happy about having to get the fullname here, but right now + # I can't figure out a cleaner way to do it. I will have to + # revisit this ASAP. (ben) + set full_statement_name [db_qd_get_fullname $statement_name] + + if { [info exists bind_output] } { + return -code error "the -bind_output switch is not currently supported" + } + + db_with_handle -dbn $dbn db { + # plsql calls that are simple selects bypass the plpgsql + # mechanism for creating anonymous functions (OpenACS - Dan). + # if a table is being created, we need to bypass things, too (OpenACS - Ben). + set test_sql [db_qd_replace_sql $full_statement_name $sql] + if {[regexp -nocase -- {^\s*select} $test_sql match]} { + # ns_log Debug "PLPGSQL: bypassed anon function" + set selection [db_exec 0or1row $db $full_statement_name $sql] + } elseif {[regexp -nocase -- {^\s*(create|drop) table} $test_sql match]} { + ns_log Debug "PLPGSQL: bypassed anon function for create/drop table" + set selection [db_exec dml $db $full_statement_name $sql] + return "" + } else { + # ns_log Debug "PLPGSQL: using anonymous function" + set selection [db_exec_plpgsql $db $full_statement_name $sql $statement_name] + } + return [ns_set value $selection 0] + } + } +} + + +ad_proc -private db_exec_plpgsql { db statement_name pre_sql fname } { + + PostgreSQL only. +
+ + A helper procedure to execute a SQL statement, potentially binding + depending on the value of the $bind variable in the calling environment + (if set). + +
+ Low level replacement for db_exec which replaces inline code with a proc. + db proc is dropped after execution. This is a temporary fix until we can + port all of the db_exec_plsql calls to simple selects of the inline code + wrapped in function calls. + +
+ emulation of plsql calls from oracle. This routine takes the plsql + statements and wraps them in a function call, calls the function, and then + drops the function. Future work might involve converting this to cache the + function calls + +
+ This proc is private - use db_exec_plsql instead! + + @see db_exec_plsql + +} { + set start_time [expr {[clock clicks -microseconds]/1000.0}] + + set sql [db_qd_replace_sql $statement_name $pre_sql] + + set unique_id [db_nextval "anon_func_seq"] + + set function_name "__exec_${unique_id}_${fname}" + + # insert Tcl variable values (OpenACS - Dan) + if {$sql ne $pre_sql } { + set sql [uplevel 2 [list subst -nobackslashes $sql]] + } + ns_log Debug "PLPGSQL: converted: $sql to: select $function_name ()" + + # create a function definition statement for the inline code + # binding is emulated in tcl. (OpenACS - Dan) + + set errno [catch { + upvar bind bind + if { [info exists bind] && [llength $bind] != 0 } { + if { [llength $bind] == 1 } { + set bind_vars [list] + set len [ns_set size $bind] + for {set i 0} {$i < $len} {incr i} { + lappend bind_vars [ns_set key $bind $i] \ + [ns_set value $bind $i] + } + set proc_sql [db_bind_var_substitution $sql $bind_vars] + } else { + set proc_sql [db_bind_var_substitution $sql $bind] + } + } else { + set proc_sql [uplevel 2 [list db_bind_var_substitution $sql]] + } + + ns_db dml $db "create function $function_name () returns varchar as [::ns_dbquotevalue $proc_sql] language 'plpgsql'" + + set ret_val [ns_db 0or1row $db "select $function_name ()"] + + # drop the anonymous function (OpenACS - Dan) + # JCD: ignore return code -- maybe we should be smarter about this though. + catch {ns_db dml $db "drop function $function_name ()"} + + return $ret_val + + } error] + + set errinfo $::errorInfo + set errcode $::errorCode + + ds_collect_db_call $db 0or1row $statement_name $sql $start_time $errno $error + + if { $errno == 2 } { + return $error + } else { + catch {ns_db dml $db "drop function $function_name ()"} + } + + return -code $errno -errorinfo $errinfo -errorcode $errcode $error +} + +ad_proc -private db_get_quote_indices { sql } { + Given a piece of SQL, return the indices of single quotes. + This is useful when we do bind var substitution because we should + not attempt bind var substitution inside quotes. Examples: + +
+ sql return value
+ {'a'} {0 2}
+ {'a''} {}
+ {'a'a'a'} {0 2 4 6}
+ {a'b'c'd'} {1 3 5 7}
+
+
+ @see db_bind_var_substitution
+} {
+ set quote_indices [list]
+
+ # Returns a list on the format
+ # Example - for sql={'a'a'a'} returns
+ # {0 2} {0 0} {2 2} {3 6} {4 4} {6 6}
+ set all_indices [regexp -inline -indices -all -- {(?:^|[^'])(')(?:[^']|'')+(')(?=$|[^'])} $sql]
+
+ for {set i 0} { $i < [llength $all_indices] } { incr i 3 } {
+ lappend quote_indices [lindex $all_indices $i+1 0] [lindex $all_indices $i+2 0]
+ }
+
+ return $quote_indices
+}
+
+ad_proc -private db_bind_var_quoted_p { sql bind_start_idx bind_end_idx} {
+
+} {
+ foreach {quote_start_idx quote_end_idx} [db_get_quote_indices $sql] {
+ if { $bind_start_idx > $quote_start_idx && $bind_end_idx < $quote_end_idx } {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+ad_proc -private db_bind_var_substitution { sql { bind "" } } {
+
+ This proc emulates the bind variable substitution in the PostgreSQL driver.
+ Since this is a temporary hack, we do it in Tcl instead of hacking up the
+ driver to support plsql calls. This is only used for the db_exec_plpgsql
+ function.
+
+} {
+ if {$bind eq ""} {
+ upvar __db_sql lsql
+ set lsql $sql
+ uplevel {
+ set __db_lst [regexp -inline -indices -all -- {:?:\w+} $__db_sql]
+ for {set __db_i [expr {[llength $__db_lst] - 1}]} {$__db_i >= 0} {incr __db_i -1} {
+ set __db_ws [lindex $__db_lst $__db_i 0]
+ set __db_we [lindex $__db_lst $__db_i 1]
+ set __db_bind_var [string range $__db_sql $__db_ws $__db_we]
+ if {![string match "::*" $__db_bind_var] && ![db_bind_var_quoted_p $__db_sql $__db_ws $__db_we]} {
+ set __db_tcl_var [string range $__db_bind_var 1 end]
+ set __db_tcl_var [set $__db_tcl_var]
+ if {$__db_tcl_var eq ""} {
+ set __db_tcl_var null
+ } else {
+ set __db_tcl_var "[::ns_dbquotevalue $__db_tcl_var]"
+ }
+ set __db_sql [string replace $__db_sql $__db_ws $__db_we $__db_tcl_var]
+ }
+ }
+ }
+ } else {
+
+ array set bind_vars $bind
+
+ set lsql $sql
+ set lst [regexp -inline -indices -all -- {:?:\w+} $sql]
+ for {set i [expr {[llength $lst] - 1}]} {$i >= 0} {incr i -1} {
+ set ws [lindex $lst $i 0]
+ set we [lindex $lst $i 1]
+ set bind_var [string range $sql $ws $we]
+ if {![string match "::*" $bind_var] && ![db_bind_var_quoted_p $lsql $ws $we]} {
+ set tcl_var [string range $bind_var 1 end]
+ set val $bind_vars($tcl_var)
+ if {$val eq ""} {
+ set val null
+ } else {
+ set val "[::ns_dbquotevalue $val]"
+ }
+ set lsql [string replace $lsql $ws $we $val]
+ }
+ }
+ }
+
+ return $lsql
+}
+
+
+ad_proc -private db_getrow { db selection } {
+
+ A helper procedure to perform an ns_db getrow, invoking developer support
+ routines as necessary.
+
+} {
+ set start_time [expr {[clock clicks -microseconds]/1000.0}]
+ set errno [catch { return [ns_db getrow $db $selection] } error]
+ ds_collect_db_call $db getrow "" "" $start_time $errno $error
+ if { $errno == 2 } {
+ return $error
+ }
+ return -code $errno -errorinfo $::errorInfo -errorcode $::errorCode $error
+}
+
+
+ad_proc -public db_exec { type db statement_name pre_sql {ulevel 2} args } {
+
+ A helper procedure to execute a SQL statement, potentially binding
+ depending on the value of the $bind variable in the calling environment
+ (if set).
+
+} {
+ set start_time [expr {[clock clicks -microseconds]/1000.0}]
+ set driverkey [db_driverkey -handle_p 1 $db]
+
+ # Note: Although marked as private, db_exec is in fact called
+ # extensively from several other packages. We DEFINITELY don't
+ # want to have to change all those procs to pass in the
+ # (redundant) $dbn just so we can use it in the call to
+ # db_driverkey, so db_driverkey MUST support its -handle switch.
+ # --atp@piskorski.com, 2003/04/09 12:13 EDT
+
+ set sql [db_qd_replace_sql $statement_name $pre_sql]
+
+ # insert Tcl variable values (OpenACS - Dan)
+ if {$sql ne $pre_sql } {
+ set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
+ }
+
+ set errno [catch {
+ upvar bind bind
+
+ if { [info exists bind] && [llength $bind] != 0 } {
+ if { [llength $bind] == 1 } {
+ # $bind is an ns_set id:
+
+ switch -- $driverkey {
+ oracle {
+ return [ns_ora $type $db -bind $bind $sql {*}$args]
+ }
+ postgresql {
+ return [ns_pg_bind $type $db -bind $bind $sql]
+ }
+ nsodbc {
+ return [ns_odbc_bind $type $db -bind $bind $sql]
+ }
+ default {
+ error "Unknown database driver. Bind variables not supported for this database."
+ }
+ }
+
+ } else {
+ # $bind is a Tcl list, convert it to an ns_set:
+ set bind_vars [ns_set create]
+ foreach { name value } $bind {
+ ns_set put $bind_vars $name $value
+ }
+ }
+
+ switch -- $driverkey {
+ oracle {
+ # TODO: Using $args outside the list is
+ # potentially bad here, depending on what is in
+ # args and if the items contain any embedded
+ # whitespace. Or maybe it works fine. But it's
+ # hard to know. Document or fix.
+ # --atp@piskorski.com, 2003/04/09 15:33 EDT
+
+ return [ns_ora $type $db -bind $bind_vars $sql {*}$args]
+ }
+ postgresql {
+ return [ns_pg_bind $type $db -bind $bind_vars $sql]
+ }
+ nsodbc {
+ return [ns_odbc_bind $type $db -bind $bind_vars $sql]
+ }
+ default {
+ error "Unknown database driver. Bind variables not supported for this database."
+ }
+ }
+
+ } else {
+ # Bind variables, if any, are defined solely as individual
+ # Tcl variables:
+
+ switch -- $driverkey {
+ oracle {
+ return [uplevel $ulevel [list ns_ora $type $db $sql] $args]
+ }
+ postgresql {
+ return [uplevel $ulevel [list ns_pg_bind $type $db $sql]]
+ }
+ nsodbc {
+ return [uplevel $ulevel [list ns_odbc_bind $type $db $sql]]
+ }
+ default {
+ # Using plain ns_db like this will work ONLY if
+ # the query is NOT using bind variables:
+ # --atp@piskorski.com, 2001/09/03 08:41 EDT
+ return [uplevel $ulevel [list ns_db $type $db $sql] $args]
+ }
+ }
+ }
+ } error]
+
+ # JCD: we log the clicks, dbname, query time, and statement to catch long running queries.
+ # If we took more than 3 seconds yack about it.
+ if { [clock clicks -milliseconds] - $start_time > 3000 } {
+ set duration [format %.2f [expr {[clock clicks -milliseconds] - $start_time}]]
+ ns_log Warning "db_exec: longdb $duration ms $db $type $statement_name"
+ } else {
+ #set duration [format %.2f [expr {[clock clicks -milliseconds] - $start_time}]]
+ #ns_log Debug "db_exec: timing $duration seconds $db $type $statement_name"
+ }
+
+ ds_collect_db_call $db $type $statement_name $sql $start_time $errno $error
+ if { $errno == 2 } {
+ return $error
+ }
+
+ return -code $errno -errorinfo $::errorInfo -errorcode $::errorCode $error
+}
+
+
+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
+
+ set code {
+ db_with_handle -dbn $dbn db {
+ set selection [db_exec 0or1row $db $full_name $sql]
+ }
+ if { $selection eq ""} {
+ if { [info exists default] } {
+ return $default
+ }
+ error "Selection did not return a value, and no default was provided"
+ }
+ return [ns_set value $selection 0]
+ }
+
+ if { [info exists cache_key] } {
+ return [ns_cache eval $cache_pool $cache_key $code]
+ } else {
+ return [eval $code]
+ }
+}
+
+
+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 in this proc, since we need to use the ns_set directly.
+
+ set code {
+ 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]
+ }
+ }
+ return $result
+ }
+ if { [info exists cache_key] } {
+ return [ns_cache eval $cache_pool $cache_key $code]
+ } else {
+ return [eval $code]
+ }
+}
+
+
+ad_proc -public db_list_of_lists {
+ {-dbn ""}
+ -cache_key
+ {-cache_pool db_cache_pool}
+ -with_headers:boolean
+ statement_name
+ sql
+ args
+} {
+
+ Usage: db_list_of_lists statement-name sql [ -bind bind_set_id | -bind bind_value_list ]
+
+ @param with_headers when specified, first line of returned list of
+ lists will always be the list of column names as reported by the
+ database. Useful when you want to dynamically assign variables to
+ values returned in the list of lists.
+
+ @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,
+ unless with_headers flag was specified and in this case the only
+ element in the list will be the list of headers.
+
+ 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
+
+ set code {
+ set result [list]
+ foreach selection [uplevel [list db_list_of_ns_sets -dbn $dbn $statement_name $sql]] {
+ set selection_array [ns_set array $selection]
+ if {[llength $result] == 0 && $with_headers_p} {
+ set headers [list]
+ foreach {key value} $selection_array {
+ lappend headers $key
+ }
+ lappend result $headers
+ }
+ set row [list]
+ foreach {key value} $selection_array {
+ lappend row $value
+ }
+ lappend result $row
+ }
+ set result
+ }
+ if { [info exists cache_key] } {
+ return [ns_cache eval $cache_pool $cache_key $code]
+ } else {
+ return [eval $code]
+ }
+}
+
+
+ad_proc -public db_list_of_ns_sets {
+ {-dbn ""}
+ statement_name
+ sql
+ args
+} {
+ Usage: db_list_of_ns_sets statement-name sql [ -bind bind_set_id | -bind bind_value_list ]
+
+ @return a list of ns_sets with the values of each column of each row
+ returned by the sql query specified.
+
+ @param statement_name The name of the query.
+ @param sql The SQL to be executed.
+ @param args Any additional arguments.
+
+ @return list of ns_sets, one per each row return by the SQL query
+
+ @param dbn The database name to use. If empty_string, uses the default database.
+} {
+ ad_arg_parser { bind } $args
+
+ set full_statement_name [db_qd_get_fullname $statement_name]
+
+ db_with_handle -dbn $dbn db {
+ set result [list]
+ set selection [db_exec select $db $full_statement_name $sql]
+
+ while {[db_getrow $db $selection]} {
+ lappend result [ns_set copy $selection]
+ }
+ }
+
+ return $result
+}
+
+
+ad_proc -public db_foreach {
+ {-dbn ""}
+ statement_name
+ sql
+ args
+} {
+
+ Usage:
+ + db_foreach statement-name sql [ -bind bind_set_id | -bind bind_value_list ] \ + [ -column_array array_name | -column_set set_name ] \ + code_block [ if_no_rows if_no_rows_block ] + ++ +
Performs the SQL query sql, executing + code_block once for each row with variables set to + column values (or a set or array populated if -column_array or + column_set is specified). If the query returns no rows, executes + if_no_rows_block (if provided). In place of 'if_no_rows' also the 'else' keyword can be used.
+ +Example: + +
db_foreach greeble_query "select foo, bar from greeble" {
+ ns_write "<li>foo=$foo; bar=$bar\n"
+ } if_no_rows {
+ # This block is optional.
+ ns_write "<li>No greebles!\n"
+ }+ db_multirow [ -local ] [ -upvar_level n_levels_up ] [ -append ] [ -extend column_list ] \ + var-name statement-name sql [ -bind bind_set_id | -bind bind_value_list ] \ + code_block [ if_no_rows if_no_rows_block ] + ++ +
Performs the SQL query sql, saving results in variables
+ of the form
+ var_name:1, var_name:2, etc,
+ setting var_name:rowcount to the total number
+ of rows, and setting var_name:columns to a
+ 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 non-empty 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
+ in a function or similar situations). Use the -upvar_level
+ switch to specify how many levels up the variable should be set.
+
+
+ + You may supply a code block, which will be executed for each row in + the loop. This is very useful if you need to make computations that + are better done in Tcl than in SQL, for example using ns_urlencode + or ad_quotehtml, etc. When the Tcl code is executed, all the columns + from the SQL query will be set as local variables in that code. Any + changes made to these local variables will be copied back into the + multirow. + +
+
+ You may also add additional, computed columns to the multirow, using the
+ -extend { col_1 col_2 ... } switch. This is
+ useful for things like constructing a URL for the object retrieved by
+ the query.
+
+
+
+ If you're constructing your multirow through multiple queries with the
+ same set of columns, but with different rows, you can use the
+ -append switch. This causes the rows returned by this query
+ to be appended to the rows already in the multirow, instead of starting
+ a clean multirow, as is the normal behavior. The columns must match the
+ columns in the original multirow, or an error will be thrown.
+
+
+
+ Your code block may call continue in order to skip a row
+ and not include it in the multirow. Or you can call break
+ to skip this row and quit looping.
+
+
+ + 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. + +
+ + Example: +
db_multirow -extend { user_url } users users_query {
+ select user_id first_names, last_name, email from cc_users
+ } {
+ set user_url [acs_community_member_url -user_id $user_id]
+ }
+
+ @see template::multirow
+} {
+ # Query Dispatcher (OpenACS - ben)
+ set full_statement_name [db_qd_get_fullname $statement_name]
+
+ if { $local_p } {
+ set level_up $upvar_level
+ } else {
+ set level_up \#[template::adp_level]
+ }
+
+ ad_arg_parser { bind args } $args
+
+ # 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 { [lindex $args 1] ne "if_no_rows"
+ && [lindex $args 1] ne "else"
+ } {
+ return -code error "Expected if_no_rows as second-to-last argument"
+ }
+ lassign $args code_block . if_no_rows_code_block
+ } 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 { [info exists cache_key]
+ && $append_p
+ && [info exists counter] && $counter > 0
+ } {
+ return -code error "Can't append and cache a non-empty multirow datasource simultaneously"
+ }
+
+ if { [info exists cache_key] } {
+
+ set value [ns_cache eval $cache_pool $cache_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 $counter $columns $values]
+ }]
+
+ lassign $value counter columns values
+
+ 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 -public db_multirow_group_last_row_p {
+ {-column:required}
+} {
+ 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, + where you only want one row per row in the master table, but you want to include + data from the slave table in a column of the multirow. + +
+ + Here's an example: + +
+ # Initialize the lines variable to hold a list of order line summaries
+ set lines [list]
+
+ # Start building the multirow. We add the dynamic column 'lines_pretty', which will
+ # contain the pretty summary of the order lines.
+ db_multirow -extend { lines_pretty } orders select_orders_and_lines {
+ select o.order_id,
+ o.customer_name,
+ l.item_name,
+ l.quantity
+ from orders o,
+ order_lines l
+ where l.order_id = o.order_id
+ order by o.order_id, l.item_name
+ } {
+ lappend lines "$quantity $item_name"
+ if { [db_multirow_group_last_row_p -column order_id] } {
+ # Last row of this order, prepare the pretty version of the order lines
+ set lines_pretty [join $lines ", "]
+
+ # Reset the lines list, so we start from a fresh with the next row
+ set lines [list]
+ } else {
+ # There are yet more order lines to come for this order,
+ # continue until we've collected all the order lines
+ # The 'continue' keyword means this line will not be added to the resulting multirow
+ continue
+ }
+ }
+
+
+ @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.
+} {
+ upvar 1 __db_multirow__next_row next_row
+ if { ![info exists next_row] } {
+ # If there is no next row, this is the last row
+ return 1
+ }
+ upvar 1 $column column_value
+ # Otherwise, it's the last row in the group if the next row has a different value than this row
+ return [expr {$column_value ne $next_row($column) }]
+}
+
+
+ad_proc -public db_dml {{-dbn ""} statement_name sql args } {
+ Do a DML statement.
+
+ + + args can be one of: -clobs, -blobs, -clob_files or -blob_files. See the db-api doc referenced below for more information. + + @param dbn The database name to use. If empty_string, uses the default database. + + @see /doc/db-api-detailed +} { + ad_arg_parser { clobs blobs clob_files blob_files bind } $args + set driverkey [db_driverkey $dbn] + + switch -- $driverkey { + postgresql { + set postgres_p 1 + } + oracle - + nsodbc - + default { + set postgres_p 0 + } + } + + # Query Dispatcher (OpenACS - ben) + set full_statement_name [db_qd_get_fullname $statement_name] + + # This "only one of..." check didn't exist in the PostgreSQL + # version, but it shouldn't't hurt anything: --atp@piskorski.com, + # 2003/04/08 06:19 EDT + + # Only one of clobs, blobs, clob_files, and blob_files is allowed. + # Remember which one (if any) is provided: + + set lob_argc 0 + set lob_argv [list] + set command "dml" + if { [info exists clobs] } { + set command "clob_dml" + set lob_argv $clobs + incr lob_argc + } + if { [info exists blobs] } { + set command "blob_dml" + set lob_argv $blobs + incr lob_argc + } + if { [info exists clob_files] } { + set command "clob_dml_file" + set lob_argv $clob_files + incr lob_argc + } + if { [info exists blob_files] } { + set command "blob_dml_file" + set lob_argv $blob_files + incr lob_argc + } + if { $lob_argc > 1 } { + error "Only one of -clobs, -blobs, -clob_files, or -blob_files may be specified as an argument to db_dml" + } + + if { ! $postgres_p } { + # Oracle: + db_with_handle -dbn $dbn db { + if { $lob_argc == 1 } { + # Bind :1, :2, ..., :n as LOBs (where n = [llength $lob_argv]) + set bind_vars [list] + for { set i 1 } { $i <= [llength $lob_argv] } { incr i } { + lappend bind_vars $i + } + eval [list db_exec "${command}_bind" $db $full_statement_name $sql 2 $bind_vars] $lob_argv + } else { + eval [list db_exec $command $db $full_statement_name $sql] $lob_argv + } + } + + } elseif {$command eq "blob_dml_file"} { + # PostgreSQL: + db_with_handle -dbn $dbn db { + # another ugly hack to avoid munging Tcl files. + # __lob_id needs to be set inside of a query (.xql) file for this + # to work. Say for example that you need to create a lob. In + # Oracle, you would do something like: + + # db_dml update_photo "update foo set bar = empty_blob() + # where bar = :bar + # returning foo into :1" -blob_files [list $file] + # for PostgreSQL we can do the equivalent by placing the following + # in a query file: + # update foo set bar = [set __lob_id [db_string get_id "select empty_lob()"]] + # where bar = :bar + + # __lob_id acts as a flag that signals that blob_dml_file is + # required, and it is also used to pass along the lob_id. It + # is unsert afterwards to avoid name clashes with other invocations + # of this routine. + # (DanW - Openacs) + + db_exec dml $db $full_statement_name $sql + if {[uplevel {info exists __lob_id}]} { + ns_pg blob_dml_file $db [uplevel {set __lob_id}] $blob_files + uplevel {unset __lob_id} + } + } + + } else { + # PostgreSQL: + db_with_handle -dbn $dbn db { + db_exec dml $db $full_statement_name $sql + } + } +} + + + + +ad_proc -public db_0or1row { + {-dbn ""} + -cache_key + {-cache_pool db_cache_pool} + statement_name + sql + args +} { + + Usage: +
+ db_0or1row statement-name sql [ -bind bind_set_id | -bind bind_value_list ] \ + [ -column_array array_name | -column_set set_name ] + ++ +
Performs the SQL query sql. If a row is returned, sets variables
+ to column values (or a set or array populated if -column_array
+ or column_set is specified) and returns 1. If no rows are returned,
+ returns 0.
+
+ @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
+
+ # 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
+ unset -nocomplain array_val
+ }
+
+ if { [info exists column_set] } {
+ upvar 1 $column_set selection
+ }
+
+ 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 { $selection eq "" } {
+ return 0
+ }
+
+ if { [info exists column_array] } {
+ array set array_val [ns_set array $selection]
+ } elseif { ![info exists column_set] } {
+ for { set i 0 } { $i < [ns_set size $selection] } { incr i } {
+ uplevel 1 [list set [ns_set key $selection $i] [ns_set value $selection $i]]
+ }
+ }
+
+ return 1
+}
+
+
+ad_proc -public db_1row { args } {
+
+ A wrapper for db_0or1row, which produces an error if no rows are returned.
+
+ @param args Arguments to be passed to db_0or1row. Check db_0or1row proc doc
+ for details.
+
+ @see db_0or1row
+
+ @return 1 if variables are set.
+
+} {
+ if { ![uplevel ::db_0or1row $args] } {
+ return -code error "Query did not return any rows."
+ }
+}
+
+if {[info commands ns_cache_transaction_begin] eq ""} {
+ #
+ # When the server has no support for ns_cache_transaction_*,
+ # provide dummy procs to avoid runtime "if" statements.
+ #
+ proc ns_cache_transaction_begin args {;}
+ proc ns_cache_transaction_commit args {;}
+ proc ns_cache_transaction_rollback args {;}
+}
+
+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).
+
+ To handle errors, use db_transaction {transaction_code} on_error {error_code_block}. Any error generated in
+ transaction_code will be caught automatically and process control will transfer to error_code_block
+ with a variable errmsg set. The error_code block can then clean up after the error, such as presenting a usable
+ error message to the user. Following the execution of error_code_block the transaction will be aborted.
+ If you want to explicitly abort the transaction, call db_abort_transaction
+ from within the transaction_code block or the error_code block.
+
+ Example 1:
+ In this example, db_dml triggers an error, so control passes to the on_error block which prints a readable error.
+
+ db_transaction {
+ db_dml test "nonsense"
+ } on_error {
+ ad_return_error "Error in blah/foo/bar" "The error was: $errmsg"
+ }
+
+
+ Example 2:
+ db_transaction {
+ db_dml test {insert into footest values(1)}
+ nonsense
+ db_dml test {insert into footest values(2)}
+ }
+
+
+ @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
+ } elseif { $arg_c == 2 } {
+ # We think they're specifying an on_error block
+ if {[lindex $args 0] ne "on_error" } {
+ # Unexpected: they put something besides on_error as a connector.
+ error $syn_err
+ } else {
+ # Success! We got an on_error code block.
+ set on_error [lindex $args 1]
+ }
+ }
+ # 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.
+ set dbh $db
+ # Remember that there's a transaction happening on this handle.
+ if { ![info exists db_state(transaction_level,$dbh)] } {
+ set db_state(transaction_level,$dbh) 0
+ }
+ set level [incr db_state(transaction_level,$dbh)]
+ if { $level == 1 } {
+ ns_db dml $dbh "begin transaction"
+ ns_cache_transaction_begin
+ }
+ }
+ # Execute the transaction code.
+ set errno [catch {
+ uplevel 1 $transaction_code
+ } errmsg]
+ incr db_state(transaction_level,$dbh) -1
+
+ set err_p 0
+ switch -- $errno {
+ 0 {
+ # TCL_OK
+ }
+ 2 {
+ # TCL_RETURN
+ }
+ 3 {
+ # TCL_BREAK - Abort the transaction and do the break.
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ db_release_unused_handles -dbn $dbn
+ break
+ }
+ 4 {
+ # TCL_CONTINUE - just ignore.
+ }
+ default {
+ # TCL_ERROR or unknown error code: Its a real error.
+ set err_p 1
+ }
+ }
+
+ if { $err_p || [db_abort_transaction_p -dbn $dbn]} {
+ # An error was triggered or the transaction has been aborted.
+ db_abort_transaction -dbn $dbn
+ if { [info exists on_error] && $on_error ne "" } {
+
+ if {"postgresql" eq [db_type]} {
+
+ # JCD: with postgres we abort the transaction prior to
+ # executing the on_error block since there is nothing
+ # you can do to "fix it" and keeping it meant things like
+ # queries in the on_error block would then fail.
+ #
+ # Note that the semantics described in the proc doc
+ # are not possible to support on PostgreSQL.
+
+ # DRB: I removed the db_release_unused_handles call that
+ # this patch included because additional aborts further
+ # down triggered an illegal db handle error. I'm going to
+ # have the code start a new transaction as well. If we
+ # don't, if a transaction fails and the on_error block
+ # fails, the on_error block DML will have been committed.
+ # Starting a new transaction here means that DML by both
+ # the transaction and on_error clause will be rolled back.
+ # On the other hand, if the on_error clause doesn't fail,
+ # any DML in that block will be committed. This seems more
+ # useful than simply punting ...
+
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ ns_db dml $dbh "begin transaction"
+ ns_cache_transaction_begin
+
+ }
+
+ # An on_error block exists, so execute it.
+
+ set errno [catch {
+ uplevel 1 $on_error
+ } on_errmsg]
+
+ # Determine what do with the error.
+ set err_p 0
+ switch -- $errno {
+ 0 {
+ # TCL_OK
+ }
+
+ 2 {
+ # TCL_RETURN
+ }
+ 3 {
+ # TCL_BREAK
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ db_release_unused_handles
+ break
+ }
+ 4 {
+ # TCL_CONTINUE - just ignore.
+ }
+ default {
+ # TCL_ERROR or unknown error code: Its a real error.
+ set err_p 1
+ }
+ }
+
+ if { $err_p } {
+ # An error was generated from the $on_error block.
+ if { $level == 1} {
+ # We're at the top level, so we abort the transaction.
+ set db_state(db_abort_p,$dbh) 0
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ }
+ # We throw this error because it was thrown from the error handling code that the programmer must fix.
+ error $on_errmsg $::errorInfo $::errorCode
+ } else {
+ # Good, no error thrown by the on_error block.
+ if { [db_abort_transaction_p -dbn $dbn] } {
+ # This means we should abort the transaction.
+ if { $level == 1 } {
+ set db_state(db_abort_p,$dbh) 0
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ # We still have the transaction generated error. We don't want to throw it, so we log it.
+ ns_log Error "Aborting transaction due to error:\n$errmsg"
+ } else {
+ # Propagate the error up to the next level.
+ error $errmsg $::errorInfo $::errorCode
+ }
+ } else {
+ # The on_error block has resolved the transaction error. If we're at the top, commit and exit.
+ # Otherwise, we continue on through the lower transaction levels.
+ if { $level == 1} {
+ ns_db dml $dbh "end transaction"
+ ns_cache_transaction_commit
+ }
+ }
+ }
+ } else {
+ # There is no on_error block, yet there is an error, so we propagate it.
+ if { $level == 1 } {
+ set db_state(db_abort_p,$dbh) 0
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ error "Transaction aborted: $errmsg" $::errorInfo $::errorCode
+ } else {
+ db_abort_transaction -dbn $dbn
+ error $errmsg $::errorInfo $::errorCode
+ }
+ }
+ } else {
+ # There was no error from the transaction code.
+ if { [db_abort_transaction_p -dbn $dbn] } {
+ # The user requested the transaction be aborted.
+ if { $level == 1 } {
+ set db_state(db_abort_p,$dbh) 0
+ ns_db dml $dbh "abort transaction"
+ ns_cache_transaction_rollback
+ }
+ } elseif { $level == 1 } {
+ # Success! No errors and no requested abort. Commit.
+ ns_db dml $dbh "end transaction"
+ ns_cache_transaction_commit
+ }
+ }
+}
+
+
+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".
+
+ @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
+
+ db_with_handle -dbn $dbn db {
+ # We set the abort flag to true.
+ set db_state(db_abort_p,$db) 1
+ }
+}
+
+
+ad_proc -private db_abort_transaction_p {{-dbn ""}} {
+ @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
+
+ db_with_handle -dbn $dbn db {
+ if { [info exists db_state(db_abort_p,$db)] } {
+ return $db_state(db_abort_p,$db)
+ } else {
+ # No abort flag registered, so we assume everything is ok.
+ return 0
+ }
+ }
+}
+
+
+ad_proc -public db_name {{-dbn ""}} {
+
+ @return the name of the database as reported by the driver.
+
+ @param dbn The database name to use. If empty_string, uses the default database.
+} {
+ db_with_handle -dbn $dbn db {
+ set dbtype [ns_db dbtype $db]
+ }
+ return $dbtype
+}
+
+
+ad_proc -public db_get_username {{-dbn ""}} {
+ @return the username parameter from the driver section of the
+ first database pool for the dbn.
+
+ @param dbn The database name to use. If empty_string, uses the default database.
+} {
+ set pool [lindex [db_available_pools $dbn] 0]
+ return [ns_config "ns/db/pool/$pool" User]
+}
+
+ad_proc -public db_get_password {{-dbn ""}} {
+ @return the password parameter from the driver section of the
+ first database pool for the dbn.
+
+ @param dbn The database name to use. If empty_string, uses the default database.
+} {
+ set pool [lindex [db_available_pools $dbn] 0]
+ return [ns_config "ns/db/pool/$pool" Password]
+}
+
+ad_proc -public db_get_sql_user {{-dbn ""}} {
+ Oracle only.
+
+ + @return a valid Oracle user@database/password string to access a + database through sqlplus. + +
+ This proc may well work for databases other than Oracle, + but its return value won't really be of any use. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set pool [lindex [db_available_pools $dbn] 0] + set datasource [ns_config "ns/db/pool/$pool" DataSource] + if { $datasource ne "" && ![string is space $datasource] } { + return "[ns_config ns/db/pool/$pool User]/[ns_config ns/db/pool/$pool Password]@$datasource" + } else { + return "[ns_config ns/db/pool/$pool User]/[ns_config ns/db/pool/$pool Password]" + } +} + +ad_proc -public db_get_pgbin {{-dbn ""}} { + PostgreSQL only. + +
+ @return the pgbin parameter from the driver section of the first database pool. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set pool [lindex [db_available_pools $dbn] 0] + set driver [ns_config "ns/db/pool/$pool" Driver] + return [ns_config "ns/db/driver/$driver" pgbin] +} + + +ad_proc -public db_get_port {{-dbn ""}} { + PostgreSQL only. + +
+ @return the port number from the first database pool. It assumes the + datasource is properly formatted since we've already verified that we + can connect to the pool. + It returns an empty string for an empty port value. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set pool [lindex [db_available_pools $dbn] 0] + set datasource [ns_config "ns/db/pool/$pool" DataSource] + set last_colon_pos [string last ":" $datasource] + if { $last_colon_pos == -1 } { + ns_log Error "datasource contains no \":\"? datasource = $datasource" + return "" + } + set first_colon_pos [string first ":" $datasource] + + if { $first_colon_pos == $last_colon_pos || ($last_colon_pos - $first_colon_pos) == 1 } { + # No port specified + return "" + } + + return [string range $datasource $first_colon_pos+1 $last_colon_pos-1] +} + + +ad_proc -public db_get_database {{-dbn ""}} { + PostgreSQL only. + +
+ @return the database name from the first database pool. It assumes the + datasource is properly formatted since we've already verified that we + can connect to the pool. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set pool [lindex [db_available_pools $dbn] 0] + set datasource [ns_config "ns/db/pool/$pool" DataSource] + set last_colon_pos [string last ":" $datasource] + if { $last_colon_pos == -1 } { + ns_log Error "datasource contains no \":\"? datasource = $datasource" + return "" + } + return [string range $datasource $last_colon_pos+1 end] +} + + +ad_proc -public db_get_dbhost { + {-dbn ""} +} { + PostgreSQL only. + +
+ @return the name of the database host from the first database pool. + It assumes the datasource is properly formatted since we've already + verified that we can connect to the pool. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set pool [lindex [db_available_pools $dbn] 0] + set datasource [ns_config "ns/db/pool/$pool" DataSource] + set first_colon_pos [string first ":" $datasource] + if { $first_colon_pos == -1 } { + ns_log Error "datasource contains no \":\"? datasource = $datasource" + return "" + } + return [string range $datasource 0 $first_colon_pos-1] +} + +ad_proc -public db_source_sql_file { + {-dbn ""} + {-callback apm_ns_write_callback} + file +} { + Sources a SQL file into Oracle (SQL*Plus format file) or + PostgreSQL (psql format file). + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set proc_name {db_source_sql_file} + set driverkey [db_driverkey $dbn] + + switch -- $driverkey { + + oracle { + set user_pass [db_get_sql_user -dbn $dbn] + cd [file dirname $file] + set fp [open "|[file join $::env(ORACLE_HOME) bin sqlplus] $user_pass @$file" "r+"] + fconfigure $fp -buffering line + puts $fp "exit" + + while { [gets $fp line] >= 0 } { + # Don't bother writing out lines which are purely whitespace. + if { ![string is space $line] } { + apm_callback_and_log $callback "[ns_quotehtml $line]\n" + } + } + close $fp + } + + postgresql { + set file_name [file tail $file] + + set pguser [db_get_username] + if { $pguser ne "" } { + set pguser "-U $pguser" + } + + set pgport [db_get_port] + if { $pgport ne "" } { + set pgport "-p $pgport" + } + + set pgpass [db_get_password] + if { $pgpass ne "" } { + set pgpass "<<$pgpass" + } + + # DRB: Submitted patch was in error - the driver opens a -h hostname connection + # unless the hostname is localhost. We need to do the same here. The submitted + # patch checked for a blank hostname, which fails in the driver. Arguably the + # driver's wrong but a lot of non-OpenACS folks use it, and even though I'm the + # maintainer we shouldn't break existing code over such trivialities... + # GN: windows requires $pghost "-h ..." + + if { ([db_get_dbhost] eq "localhost" || [db_get_dbhost] eq "") + && $::tcl_platform(platform) ne "windows" + } { + set pghost "" + } else { + set pghost "-h [db_get_dbhost]" + } + + set errno [catch { + cd [file dirname $file] + set fp [open "|[file join [db_get_pgbin] psql] $pghost $pgport $pguser -f $file [db_get_database] $pgpass" "r"] + } errorMsg] + + if {$errno > 0} { + set error_found 1 + set error_lines $errorMsg + } else { + while { [gets $fp line] >= 0 } { + # Don't bother writing out lines which are purely whitespace. + if { ![string is space $line] } { + apm_callback_and_log $callback "[ns_quotehtml $line]\n" + } + } + + # PSQL dumps errors and notice information on stderr, and has no option to turn + # this off. So we have to chug through the "error" lines looking for those that + # really signal an error. + + set errno [ catch { + close $fp + } error] + + if { $errno == 2 } { + return $error + } + + # Just filter out the "NOTICE" lines, so we get the stack dump along with real + # ERRORs. This could be done with a couple of opaque-looking regexps... + + set error_found 0 + foreach line [split $error "\n"] { + if { [string first NOTICE $line] == -1 } { + append error_lines "$line\n" + set error_found [expr { $error_found + || [string first ERROR $line] != -1 + || [string first FATAL $line] != -1 } ] + } + } + } + + if { $error_found } { + return -code error -errorinfo $error_lines -errorcode $::errorCode $error_lines + } + + } + + nsodbc { + error "$proc_name is not supported for this database." + } + default { + error "$proc_name is not supported for this database." + } + } +} + +ad_proc -public db_load_sql_data { + {-dbn ""} + {-callback apm_ns_write_callback} + file +} { + Loads a CSV formatted file into a table using PostgreSQL's COPY command or + Oracle's SQL*Loader utility. The file name format consists of a sequence + number used to control the order in which tables are loaded, and the table + name with "-" replacing "_". This is a bit of a kludge but greatly speeds + the loading of large amounts of data, such as is done when various "ref-*" + packages are installed. + + @param dbn The database name to use. If empty_string, uses the default database. + @param file Filename in the format dd-table-name.ctl where 'dd' is a sequence number + used to control the order in which data is loaded. This file is an + RDBMS-specific data loader control file. + +} { + + switch [db_driverkey $dbn] { + + oracle { + set user_pass [db_get_sql_user -dbn $dbn] + set tmpnam [ad_tmpnam] + + set fd [open $file r] + set file_contents [read $fd] + close $fd + + set file_contents [subst $file_contents] + + set fd1 [open "${tmpnam}.ctl" w] + puts $fd1 $file_contents + close $fd1 + + cd [file dirname $file] + + set fd [open "|[file join $::env(ORACLE_HOME) bin sqlldr] userid=$user_pass control=$tmpnam" "r"] + + while { [gets $fd line] >= 0 } { + # Don't bother writing out lines which are purely whitespace. + if { ![string is space $line] } { + apm_callback_and_log $callback "[ns_quotehtml $line]\n" + } + } + close $fd + } + + postgresql { + set pguser [db_get_username] + if { $pguser ne "" } { + set pguser "-U $pguser" + } + + set pgport [db_get_port] + if { $pgport ne "" } { + set pgport "-p $pgport" + } + + set pgpass [db_get_password] + if { $pgpass ne "" } { + set pgpass "<<$pgpass" + } + + if { [db_get_dbhost] eq "localhost" || [db_get_dbhost] eq "" } { + set pghost "" + } else { + set pghost "-h [db_get_dbhost]" + } + + set fd [open $file r] + set copy_command [subst -nobackslashes [read $fd]] + close $fd + set copy_file [ns_mktemp [ad_tmpdir]/psql-copyfile-XXXXXX] + set fd [open $copy_file "CREAT EXCL WRONLY" 0600] + puts $fd $copy_command + close $fd + + if { $::tcl_platform(platform) eq "windows" } { + set fp [open "|[file join [db_get_pgbin] psql] -f $copy_file $pghost $pgport $pguser [db_get_database]" "r"] + } else { + set fp [open "|[file join [db_get_pgbin] psql] -f $copy_file $pghost $pgport $pguser [db_get_database] $pgpass" "r"] + } + + while { [gets $fp line] >= 0 } { + # Don't bother writing out lines which are purely whitespace. + if { ![string is space $line] } { + apm_callback_and_log $callback "[ns_quotehtml $line]\n" + } + } + + # PSQL dumps errors and notice information on stderr, and has no option to turn + # this off. So we have to chug through the "error" lines looking for those that + # really signal an error. + + set errno [ catch { + close $fp + } error] + + # remove the copy file. + file delete -force -- $copy_file + + if { $errno == 2 } { + return $error + } + + # Just filter out the "NOTICE" lines, so we get the stack dump along with real + # ERRORs. This could be done with a couple of opaque-looking regexps... + + set error_found 0 + foreach line [split $error "\n"] { + if { [string first NOTICE $line] == -1 } { + append error_lines "$line\n" + set error_found [expr { $error_found + || [string first ERROR $line] != -1 + || [string first FATAL $line] != -1 } ] + } + } + + if { $error_found } { + return -code error -errorinfo $error_lines -errorcode $::errorCode $error_lines + } + + } + + nsodbc { + error "db_load_sql_data is not supported for this database." + } + default { + error "db_load_sql_data is not supported for this database." + } + } +} + +ad_proc -public db_source_sqlj_file { + {-dbn ""} + {-callback apm_ns_write_callback} + file +} { + Oracle only. +
+ Sources a SQLJ file using loadjava. + + @param dbn The database name to use. If empty_string, uses the default database. +} { + set user_pass [db_get_sql_user -dbn $dbn] + set fp [open "|[file join $::env(ORACLE_HOME) bin loadjava] -verbose -user $user_pass $file" "r"] + + # Despite the fact that this works, the text does not get written to the stream. + # The output is generated as an error when you attempt to close the input stream as + # done below. + while { [gets $fp line] >= 0 } { + # Don't bother writing out lines which are purely whitespace. + if { ![string is space $line] } { + apm_callback_and_log $callback "[ns_quotehtml $line]\n" + } + } + if { [catch { + close $fp + } errmsg] } { + apm_callback_and_log $callback "[ns_quotehtml $errmsg]\n" + } +} + + +ad_proc -public db_tables { + -pattern + {-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. + + @author Don Baccus (dhogaza@pacifier.com) + @author Lars Pind (lars@pinds.com) + + @change-log yon@arsdigita.com 20000711 changed to return lower case table names +} { + set proc_name {db_tables} + set driverkey [db_driverkey $dbn] + + switch -- $driverkey { + oracle { + set sql_table_names_with_pattern { + select lower(table_name) as table_name + from user_tables + where table_name like upper(:pattern) + } + set sql_table_names_without_pattern { + select lower(table_name) as table_name + from user_tables + } + } + + postgresql { + set sql_table_names_with_pattern { + select relname as table_name + from pg_class + where relname like lower(:pattern) and + relname !~ '^pg_' and relkind = 'r' + } + set sql_table_names_without_pattern { + select relname as table_name + from pg_class + where relname !~ '^pg_' and relkind = 'r' + } + } + + nsodbc - + default { + error "$proc_name is not supported for this database." + } + } + + set tables [list] + if { [info exists pattern] } { + db_foreach -dbn $dbn table_names_with_pattern \ + $sql_table_names_with_pattern { + lappend tables $table_name + } + } else { + db_foreach -dbn $dbn table_names_without_pattern \ + $sql_table_names_without_pattern { + lappend tables $table_name + } + } + + return $tables +} + + +ad_proc -public db_table_exists {{-dbn ""} table_name } { + @return 1 if a table with the specified name exists in the database, otherwise 0. + + @param dbn The database name to use. If empty_string, uses the default database. + + @author Don Baccus (dhogaza@pacifier.com) + @author Lars Pind (lars@pinds.com) +} { + set proc_name {db_table_exists} + set driverkey [db_driverkey $dbn] + + switch -- $driverkey { + oracle { + set n_rows [db_string -dbn $dbn table_count { + select count(*) from user_tables + where table_name = upper(:table_name) + }] + } + + postgresql { + set n_rows [db_string -dbn $dbn table_count { + select count(*) from pg_class + where relname = lower(:table_name) and + relname !~ '^pg_' and relkind = 'r' + }] + } + + nsodbc - + default { + error "$proc_name is not supported for this database." + } + } + + return $n_rows +} + + +ad_proc -public db_columns {{-dbn ""} table_name } { + @return a Tcl list of all the columns in the table with the given name. + + @param dbn The database name to use. If empty_string, uses the default database. + + @author Lars Pind (lars@pinds.com) + + @change-log yon@arsdigita.com 20000711 changed to return lower case column names +} { + set columns [list] + + # Works for both Oracle and PostgreSQL: + db_foreach -dbn $dbn table_column_names { + select lower(column_name) as column_name + from user_tab_columns + where table_name = upper(:table_name) + } { + lappend columns $column_name + } + + return $columns +} + + +ad_proc -public db_column_exists {{-dbn ""} table_name column_name } { + @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] + + # Works for both Oracle and PostgreSQL: + set n_rows [db_string -dbn $dbn column_exists { + select count(*) + from user_tab_columns + where table_name = upper(:table_name) + and column_name = upper(:column_name) + }] + + return [expr {$n_rows > 0}] +} + + +ad_proc -public db_column_type {{-dbn ""} {-complain:boolean} table_name column_name } { + + @return the Oracle Data Type for the specified column. + @return -1 if the table or column doesn't exist. + @return an error if table or column doesn't exist and -complain flag was specified + + @param dbn The database name to use. If empty_string, uses the default database. + @param complain throw an error when datatype is not found + + @author Yon Feldman (yon@arsdigita.com) + + @change-log 10 July, 2000: changed to return error + if column name doesn't exist + (mdettinger@arsdigita.com) + + @change-log 11 July, 2000: changed to return lower case data types + (yon@arsdigita.com) + + @change-log 11 July, 2000: changed to return error using the db_string default clause + (yon@arsdigita.com) + +} { + # Works for both Oracle and PostgreSQL: + set datatype [db_string -dbn $dbn column_type_select " + select data_type as data_type + from user_tab_columns + where upper(table_name) = upper(:table_name) + and upper(column_name) = upper(:column_name) + " -default "-1"] + if {$complain_p && $datatype == -1} { + error "Datatype for $table_name.$column_name not found." + } else { + return $datatype + } +} + + +ad_proc -public ad_column_type {{-dbn ""} table_name column_name } { + + @return 'numeric' for number type columns, 'text' otherwise + Throws an error if no such column exists. + + @param dbn The database name to use. If empty_string, uses the default database. + + @author Yon Feldman (yon@arsdigita.com) + +} { + set column_type [db_column_type -dbn $dbn $table_name $column_name] + + if { $column_type == -1 } { + return "Either table $table_name doesn't exist or column $column_name doesn't exist" + } elseif {$column_type ne "NUMBER" } { + return "numeric" + } else { + return "text" + } +} + + +ad_proc -public db_write_clob {{-dbn ""} statement_name sql args } { + @param dbn The database name to use. If empty_string, uses the default database. +} { + ad_arg_parser { bind } $args + set proc_name {db_write_clob} + set driverkey [db_driverkey $dbn] + + # TODO: Below, is db_qd_get_fullname necessary? Why this + # difference between Oracle and Postgres code? + # --atp@piskorski.com, 2003/04/09 10:00 EDT + + switch -- $driverkey { + oracle { + set full_statement_name [db_qd_get_fullname $statement_name] + db_with_handle -dbn $dbn db { + db_exec write_clob $db $full_statement_name $sql + } + } + + postgresql { + db_with_handle -dbn $dbn db { + db_exec write_clob $db $statement_name $sql + } + } + + nsodbc - + default { + error "$proc_name is not supported for this database." + } + } +} + + +ad_proc -public db_write_blob {{-dbn ""} statement_name sql args } { + @param dbn The database name to use. If empty_string, uses the default database. +} { + ad_arg_parser { bind } $args + set full_statement_name [db_qd_get_fullname $statement_name] + db_with_handle -dbn $dbn db { + db_exec_lob write_blob $db $full_statement_name $sql + } +} + + +ad_proc -public db_blob_get_file {{-dbn ""} statement_name sql args } { + @param dbn The database name to use. If empty_string, uses the default database. + +
+ TODO:
+ This proc should probably be changed to take a final
+ file argument, only, rather than the current
+ args variable length argument list. Currently, it is
+ called only 4 places in OpenACS, and each place args,
+ if used at all, is always "-file $file". However,
+ such a change might break custom code... I'm not sure.
+ --atp@piskorski.com, 2003/04/09 11:39 EDT
+
+} {
+ ad_arg_parser { bind file args } $args
+ set proc_name {db_blob_get_file}
+ set driverkey [db_driverkey $dbn]
+
+ set full_statement_name [db_qd_get_fullname $statement_name]
+
+ switch -- $driverkey {
+ oracle {
+ db_with_handle -dbn $dbn db {
+ db_exec_lob blob_get_file $db $full_statement_name $sql $file
+ }
+ }
+
+ postgresql {
+ db_with_handle -dbn $dbn db {
+ db_exec_lob blob_select_file $db $full_statement_name $sql $file
+ }
+ }
+
+ nsodbc -
+ default {
+ error "$proc_name is not supported for this database."
+ }
+ }
+}
+
+
+ad_proc -public db_blob_get {{-dbn ""} statement_name sql args } {
+ PostgreSQL only.
+
+ @param dbn The database name to use. If empty_string, uses the default database.
+} {
+ ad_arg_parser { bind } $args
+ set proc_name {db_blob_get}
+ set driverkey [db_driverkey $dbn]
+
+ switch -- $driverkey {
+
+ postgresql {
+ set full_statement_name [db_qd_get_fullname $statement_name]
+ db_with_handle -dbn $dbn db {
+ set data [db_exec_lob blob_get $db $full_statement_name $sql]
+ }
+ return $data
+ }
+
+ oracle {
+ set pre_sql $sql
+ set full_statement_name [db_qd_get_fullname $statement_name]
+ set sql [db_qd_replace_sql $full_statement_name $pre_sql]
+
+ # insert Tcl variable values (borrowed from Dan W - olah)
+ if {$sql ne $pre_sql } {
+ set sql [uplevel 2 [list subst -nobackslashes $sql]]
+ }
+
+ set data [db_string dummy_statement_name $sql]
+ return $data
+ }
+
+ nsodbc -
+ default {
+ error "$proc_name is not supported for this database."
+ }
+ }
+}
+
+
+ad_proc -private db_exec_lob {
+ {-ulevel 2}
+ type
+ db
+ statement_name
+ pre_sql
+ {file ""}
+} {
+ A helper procedure to execute a SQL statement, potentially binding
+ depending on the value of the $bind variable in the calling environment
+ (if set).
+} {
+ set proc_name {db_exec_lob}
+ set driverkey [db_driverkey -handle_p 1 $db]
+
+ # Note: db_exec_lob is marked as private and in the entire
+ # toolkit, is ONLY called from a few other procs defined in this
+ # same file. So we definitely could change it to take a -dbn
+ # switch and remove the passed in db handle altogether, and call
+ # 'db_driverkey -dbn' rather than 'db_driverkey -handle'. But,
+ # db_exec NEEDS 'db_driverkey -handle', so we might as well use it
+ # here too. --atp@piskorski.com, 2003/04/09 12:13 EDT
+
+ # TODO: Using this as a wrapper for the separate _oracle and
+ # _postgresql versions of this proc is ugly. But also simplest
+ # and safest at this point, as it let me change as little as
+ # possible of those two relatively complex procs.
+ # --atp@piskorski.com, 2003/04/09 11:55 EDT
+
+ switch -- $driverkey {
+ oracle {
+ set which_proc {db_exec_lob_oracle}
+ }
+ postgresql {
+ set which_proc {db_exec_lob_postgresql}
+ }
+
+ nsodbc -
+ default {
+ error "$proc_name is not supported for this database."
+ }
+ }
+
+ ns_log Debug "$proc_name: $which_proc -ulevel [expr {$ulevel +1}] $type $db $statement_name $pre_sql $file"
+ return [$which_proc -ulevel [expr {$ulevel +1}] $type $db $statement_name $pre_sql $file]
+}
+
+
+ad_proc -private db_exec_lob_oracle {
+ {-ulevel 2}
+ type
+ db
+ statement_name
+ pre_sql
+ {file ""}
+} {
+ A helper procedure to execute a SQL statement, potentially binding
+ depending on the value of the $bind variable in the calling environment
+ (if set).
+} {
+ set start_time [expr {[clock clicks -microseconds]/1000.0}]
+
+ set sql [db_qd_replace_sql $statement_name $pre_sql]
+
+ # insert Tcl variable values (OpenACS - Dan)
+ if {$sql ne $pre_sql } {
+ set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
+ }
+
+ set file_storage_p 0
+ upvar $ulevel storage_type storage_type
+
+ if {[info exists storage_type] && $storage_type eq "file"} {
+ set file_storage_p 1
+ set original_type $type
+ set qtype 1row
+ ns_log Debug "db_exec_lob: file storage in use"
+ } else {
+ set qtype $type
+ ns_log Debug "db_exec_lob: blob storage in use"
+ }
+
+ set errno [catch {
+ upvar bind bind
+
+ # Below, note that 'ns_ora blob_get_file' takes 3 parameters,
+ # while 'ns_ora write_blob' takes only 2. So if file is empty
+ # string (which it always will/should be for $qtype
+ # write_blob), we must not pass any 3rd parameter to the
+ # ns_ora command: --atp@piskorski.com, 2003/04/09 15:10 EDT
+
+ if { [info exists bind] && [llength $bind] != 0 } {
+ if { [llength $bind] == 1 } {
+ if { $file eq "" } {
+ # gn: not sure, why the eval was ever needed (4 times)
+ set selection [eval [list ns_ora $qtype $db -bind $bind $sql]]
+ } else {
+ set selection [eval [list ns_ora $qtype $db -bind $bind $sql $file]]
+ }
+
+ } else {
+ set bind_vars [ns_set create]
+ foreach { name value } $bind {
+ ns_set put $bind_vars $name $value
+ }
+ if { $file eq "" } {
+ set selection [eval [list ns_ora $qtype $db -bind $bind_vars $sql]]
+ } else {
+ set selection [eval [list ns_ora $qtype $db -bind $bind_vars $sql $file]]
+ }
+ }
+
+ } else {
+ if { $file eq "" } {
+ set selection [uplevel $ulevel [list ns_ora $qtype $db $sql]]
+ } else {
+ set selection [uplevel $ulevel [list ns_ora $qtype $db $sql $file]]
+ }
+ }
+
+ if {$file_storage_p} {
+ set content [ns_set value $selection 0]
+ for {set i 0} {$i < [ns_set size $selection]} {incr i} {
+ set name [ns_set key $selection $i]
+ if {$name eq "content"} {
+ set content [ns_set value $selection $i]
+ }
+ }
+
+ switch -- $original_type {
+
+ blob_get_file {
+ if {[file exists $content]} {
+ file copy -- $content $file
+ return $selection
+ } else {
+ error "file: $content doesn't exist"
+ }
+ }
+
+ write_blob {
+
+ if {[file exists $content]} {
+ set ofp [open $content r]
+ fconfigure $ofp -encoding binary
+ ns_writefp $ofp
+ close $ofp
+ return $selection
+ } else {
+ error "file: $content doesn't exist"
+ }
+ }
+ }
+ } else {
+ return $selection
+ }
+
+ } error]
+
+ ds_collect_db_call $db $type $statement_name $sql $start_time $errno $error
+ if { $errno == 2 } {
+ return $error
+ }
+
+ return -code $errno -errorinfo $::errorInfo -errorcode $::errorCode $error
+}
+
+
+ad_proc -private db_exec_lob_postgresql {
+ {-ulevel 2}
+ type
+ db
+ statement_name
+ pre_sql
+ {file ""}
+} {
+ A helper procedure to execute a SQL statement, potentially binding
+ depending on the value of the $bind variable in the calling environment
+ (if set).
+
+ Low level replacement for db_exec which emulates blob handling.
+
+} {
+ set start_time [expr {[clock clicks -microseconds]/1000.0}]
+
+ # Query Dispatcher (OpenACS - ben)
+ set sql [db_qd_replace_sql $statement_name $pre_sql]
+
+ # insert Tcl variable values (OpenACS - Dan)
+ if {$sql ne $pre_sql } {
+ set sql [uplevel $ulevel [list subst -nobackslashes $sql]]
+ }
+ # create a function definition statement for the inline code
+ # binding is emulated in tcl. (OpenACS - Dan)
+
+ set errno [catch {
+ upvar bind bind
+ if { [info exists bind] && [llength $bind] != 0 } {
+ if { [llength $bind] == 1 } {
+ set bind_vars [list]
+ set len [ns_set size $bind]
+ for {set i 0} {$i < $len} {incr i} {
+ lappend bind_vars [ns_set key $bind $i] \
+ [ns_set value $bind $i]
+ }
+ set lob_sql [db_bind_var_substitution $sql $bind_vars]
+ } else {
+ set lob_sql [db_bind_var_substitution $sql $bind]
+ }
+ } else {
+ set lob_sql [uplevel $ulevel [list db_bind_var_substitution $sql]]
+ }
+
+ # get the content - asssume it is in column 0, or optionally it can
+ # be returned as "content" with the storage type indicated by the
+ # "storage_type" column.
+
+ set selection [ns_db 1row $db $lob_sql]
+ set content [ns_set value $selection 0]
+ for {set i 0} {$i < [ns_set size $selection]} {incr i} {
+ set name [ns_set key $selection $i]
+ if {$name eq "storage_type"} {
+ set storage_type [ns_set value $selection $i]
+ } elseif {$name eq "content"} {
+ set content [ns_set value $selection $i]
+ }
+ }
+
+ # this is an ugly hack, but it allows content to be written
+ # to a file/connection if it is stored as a lob or if it is
+ # stored in the content-repository as a file. (DanW - Openacs)
+
+ switch -- $type {
+
+ blob_get {
+
+ if {[info exists storage_type]} {
+ switch -- $storage_type {
+ file {
+ if {[file exists $content]} {
+ set ifp [open $content r]
+
+ # DRB: this could be made faster by setting the buffersize
+ # to the size of the file, but for very large files allocating
+ # that much more memory on top of that needed by Tcl for storage
+ # of the data might not be wise.
+
+ fconfigure $ifp -translation binary
+
+ set data [read $ifp]
+ close $ifp
+ return $data
+ } else {
+ error "file: $content doesn't exist"
+ }
+ }
+
+ lob {
+ if {[regexp {^[0-9]+$} $content match]} {
+ return [ns_pg blob_get $db $content]
+ } else {
+ error "invalid lob_id: should be an integer"
+ }
+ }
+
+ default {
+ error "invalid storage type"
+ }
+ }
+ } elseif {[file exists $content]} {
+ set ifp [open $content r]
+ fconfigure $ifp -translation binary
+ set data [read $ifp]
+ close $ifp
+ return $data
+ } elseif {[regexp {^[0-9]+$} $content match]} {
+ return [ns_pg blob_get $db $content]
+ } else {
+ error "invalid query"
+ }
+ }
+
+ blob_select_file {
+
+ if {[info exists storage_type]} {
+ switch -- $storage_type {
+ file {
+ if {[file exists $content]} {
+ file copy -- $content $file
+ } else {
+ error "file: $content doesn't exist"
+ }
+ }
+
+ lob {
+ if {[regexp {^[0-9]+$} $content match]} {
+ ns_pg blob_select_file $db $content $file
+ } else {
+ error "invalid lob_id: should be an integer"
+ }
+ }
+
+ default {
+ error "invalid storage type"
+ }
+ }
+ } elseif {[file exists $content]} {
+ file copy -- $content $file
+ } elseif {[regexp {^[0-9]+$} $content match]} {
+ ns_pg blob_select_file $db $content $file
+ } else {
+ error "invalid query"
+
+ # TODO: Page /file-storage/download-archive/index
+ # fails here on cvs head both before and after my
+ # mult-db db_* API work, I don't know why. See bug:
+ # http://openacs.org/bugtracker/openacs/com/file-storage/bug?bug%5fnumber=427
+ # --atp@piskorski.com, 2003/04/09 18:04 EDT
+ }
+ }
+
+ write_blob {
+
+ if {[info exists storage_type]} {
+ switch -- $storage_type {
+ file {
+ if {[file exists $content]} {
+ set ofp [open $content r]
+ fconfigure $ofp -encoding binary
+ ns_writefp $ofp
+ close $ofp
+ } else {
+ error "file: $content doesn't exist"
+ }
+ }
+
+ text {
+ ns_write $content
+ }
+
+ lob {
+ if {[regexp {^[0-9]+$} $content match]} {
+ ns_pg blob_write $db $content
+ } else {
+ error "invalid lob_id: should be an integer"
+ }
+ }
+
+ default {
+ error "invalid storage type"
+ }
+ }
+ } elseif {[file exists $content]} {
+ set ofp [open $content r]
+ fconfigure $ofp -encoding binary
+ ns_writefp $ofp
+ close $ofp
+ } elseif {[regexp {^[0-9]+$} $content match]} {
+ ns_pg blob_write $db $content
+ } else {
+ ns_write $content
+ }
+ }
+ }
+
+ return
+
+ } error]
+
+ set errinfo $::errorInfo
+ set errcode $::errorCode
+
+ ds_collect_db_call $db 0or1row $statement_name $sql $start_time $errno $error
+
+ if { $errno == 2 } {
+ return $error
+ }
+
+ 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)
+
+} {
+ #
+ # If the key pattern has meta characters, iterate over the entries.
+ # Otherwise, make a direct lookup, without retrieving the all keys
+ # from the cache, which can cause large mutex lock times.
+ #
+ if {[regexp {[*\]\[]} $cache_key_pattern]} {
+ foreach key [ns_cache names $cache_pool $cache_key_pattern] {
+ ns_cache flush $cache_pool $key
+ }
+ } else {
+ ns_cache flush $cache_pool $cache_key_pattern
+ }
+}
+
+ad_proc -public db_bounce_pools {{-dbn ""}} {
+ @return Call ns_db bouncepool on all pools for the named database.
+ @param dbn The database name to use. Uses the default database if not supplied.
+} {
+ foreach pool [db_available_pools $dbn] {
+ ns_db bouncepool $pool
+ }
+}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End: