Index: openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl,v diff -u -r1.148.2.62 -r1.148.2.63 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 9 Jan 2023 17:11:17 -0000 1.148.2.62 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 13 Jan 2023 17:16:56 -0000 1.148.2.63 @@ -554,6 +554,101 @@ } } + ::xo::db::DB-postgresql instproc multirow { + {-dbn ""} + {-bind ""} + {-local false} + {-upvar_level 1} + {-extend {}} + -prepare + var_name + qn + sql + {body {}} + } { + if { $local } { + set level_up [expr {$upvar_level + 1}] + } else { + set level_up \#[::template::adp_level] + } + + if {$sql eq ""} {set sql [:get_sql $qn]} + if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""} + + set multirow_exists_p [::template::multirow -local -ulevel $level_up exists $var_name] + + if {$multirow_exists_p && [llength $extend] > 0} { + ::template::multirow -local -ulevel $level_up extend $var_name {*}$extend + } + + set multirow_size [::template::multirow -local -ulevel $level_up size $var_name] + set i [expr {$multirow_size == 0 ? 1 : $multirow_size + 1}] + + db_with_handle -dbn $dbn db { + if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]} + set result [list] + + set answers [uplevel 1 [list ns_pg_bind select $db {*}$bindOpt $sql]] + set cols [concat [ns_set keys $answers] $extend] + if {$multirow_exists_p} { + # + # We enforce here, that appending to an existing multirow + # can only happen when we are extracting the same columns. + # + set existing_cols [::template::multirow -local -ulevel $level_up columns $var_name] + if {$cols ne $existing_cols} { + error "Cannot append to a multirow with different columns" + } + } else { + ::template::multirow -local -ulevel $level_up create $var_name {*}$cols + set multirow_exists_p true + } + + while { [::db_getrow $db $answers] } { + foreach att $cols { + uplevel 1 [list set $att [ns_set get $answers $att]] + } + + if {[llength $body] > 0} { + try { + + uplevel 1 $body + + } on error {errMsg} { + + error $errMsg $::errorInfo $::errorCode + + } on return {} { + + error "Cannot return from inside a ::xo::dc multirow loop" + + } on break {} { + + break + + } on continue {} { + + # Just ignore and continue looping. + + } + } + + # + # Add an empty row, then set the values individually, so we do + # not need to loop through the multirow columns twice. + # + ::template::multirow -local -ulevel $level_up append $var_name + foreach att $cols { + if {[uplevel 1 [list info exists $att]]} { + set value [uplevel 1 [list set $att]] + ::template::multirow -local -ulevel $level_up set $var_name $i $att $value + } + } + incr i + } + } + } + ::xo::db::DB instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql body} { #if {$sql eq ""} {set sql [:get_sql $qn]} if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""} @@ -567,6 +662,26 @@ uplevel [list ::db_foreach -dbn $dbn $qn $sql $body {*}$bindOpt] } + ::xo::db::DB instproc multirow { + {-dbn ""} + {-bind ""} + {-local false} + {-upvar_level 1} + {-extend {}} + -prepare + var_name + qn + sql + {body ""} + } { + if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""} + set qn [uplevel [list [self] qn $qn]] + set local [expr {$local ? "-local" : ""}] + uplevel [list ::db_multirow -dbn $dbn {*}$local \ + -upvar_level $upvar_level -extend $extend $var_name \ + $qn $sql $body {*}$bindOpt] + } + ::xo::db::DB instproc exec_0or1row {-prepare {-bind ""} sql} { # Helper, used from several postgres-specific one-tuple queries if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}