Index: openacs-4/packages/xotcl-core/xotcl-core.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v
diff -u -r1.92.2.23 -r1.92.2.24
--- openacs-4/packages/xotcl-core/xotcl-core.info 28 Jan 2017 18:05:53 -0000 1.92.2.23
+++ openacs-4/packages/xotcl-core/xotcl-core.info 3 Feb 2017 12:52:00 -0000 1.92.2.24
@@ -10,7 +10,7 @@
t
xotcl
-
+
Gustaf Neumann
XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)
2016-09-10
@@ -43,7 +43,7 @@
BSD-Style
2
-
+
Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v
diff -u -r1.78.2.24 -r1.78.2.25
--- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 13 Jan 2017 14:46:50 -0000 1.78.2.24
+++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 3 Feb 2017 12:52:00 -0000 1.78.2.25
@@ -32,6 +32,7 @@
::xotcl::Object instproc www-show-object
::xotcl::Object instproc destroy_on_cleanup
::xotcl::Object instproc set_instance_vars_defaults
+ ::xotcl::Object instproc mset
::xotcl::Class instproc extend_slot
}
@@ -175,6 +176,13 @@
}
}
+::xotcl::Object instproc mset {pairs} {
+ #
+ # Import all attribute value pairs into the current XOTcl object.
+ #
+ nsf::directdispatch [self] -frame object ::lassign [dict values $pairs] {*}[dict keys $pairs]
+}
+
::xotcl::Object instproc www-show-object {} {
#
# Allow to show an arbitrary object via API-browser. Per-default,
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.103.2.30 -r1.103.2.31
--- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 2 Feb 2017 22:24:08 -0000 1.103.2.30
+++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 3 Feb 2017 12:52:00 -0000 1.103.2.31
@@ -275,7 +275,7 @@
::xo::db::Driver abstract instproc foreach {{-dbn ""} {-bind ""} -prepare qn sql script}
::xo::db::Driver abstract instproc transaction {{-dbn ""} script args}
::xo::db::Driver abstract instproc ds {onOff}
- ::xo::db::Driver abstract instproc prepare {{-dbn ""} {-argtypes ""} sql}
+ ::xo::db::Driver abstract instproc prepare {-handle {-argtypes ""} sql}
#
# Driver specific and Driver/Dialect specific hooks
@@ -377,7 +377,7 @@
return [my uplevel [list ::dbi_eval -transaction committed $script]]
}
}
- ::xo::db::DBI instproc prepare {{-dbn ""} {-argtypes ""} sql} {
+ ::xo::db::DBI instproc prepare {-handle {-argtypes ""} sql} {
return $sql
}
::xo::db::DBI instproc get_value {{-dbn ""} -prepare qn sql {default ""}} {
@@ -462,15 +462,15 @@
::xo::db::DB instproc transaction {{-dbn ""} script args} {
return [my uplevel [list ::db_transaction -dbn $dbn $script {*}$args]]
}
- ::xo::db::DB instproc prepare {{-dbn ""} {-argtypes ""} sql} {
+ ::xo::db::DB instproc prepare {-handle {-argtypes ""} sql} {
return $sql
}
::xo::db::DB instproc sets {{-dbn ""} {-bind ""} -prepare qn sql} {
if {$sql eq ""} {set sql [my get_sql $qn]}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
db_with_handle -dbn $dbn db {
+ if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
set result [list]
set answers [uplevel [list ns_pg_bind select $db {*}$bindOpt $sql]]
while { [::db_getrow $db $answers] } {
@@ -487,15 +487,16 @@
#
# the prepare in the next line works probably only with inline sql statements
#
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
+ #if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
#ns_log notice "### [list ::db_foreach -dbn $dbn $qn $sql $body {*}$bindOpt]"
uplevel [list ::db_foreach -dbn $dbn $qn $sql $body {*}$bindOpt]
}
- ::xo::db::DB instproc exec_0or1row {{-bind ""} sql} {
+ ::xo::db::DB instproc exec_0or1row {-prepare {-bind ""} sql} {
# Helper, used from several postgres-spefic one-tuple queries
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
::db_with_handle h {
+ if {[info exists prepare]} {set sql [:prepare -handle $h -argtypes $prepare $sql]}
return [uplevel [list ns_pg_bind 0or1row $h {*}$bindOpt $sql]]
}
}
@@ -511,7 +512,6 @@
::xo::db::DB instproc dml {{-dbn ""} {-bind ""} -prepare qn sql} {
if {$sql eq ""} {set sql [my get_sql $qn]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
uplevel [list ::db_dml [uplevel [list [self] qn $qn]] $sql {*}$bindOpt]
return [db_resultrows]
}
@@ -546,8 +546,8 @@
#
::xo::db::DB-postgresql instproc 0or1row {{-dbn ""} {-bind ""} -prepare qn sql} {
if {$sql eq ""} {set sql [my get_sql $qn]}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
- set answers [uplevel [list [self] exec_0or1row -bind $bind $sql]]
+ set prepOpt [expr {[info exists prepare] ? [list -prepare $prepare] : ""}]
+ set answers [uplevel [list [self] exec_0or1row {*}$prepOpt -bind $bind $sql]]
if {$answers ne ""} {
foreach {att val} [ns_set array $answers] { uplevel [list set $att $val] }
ns_set free $answers
@@ -557,8 +557,8 @@
}
::xo::db::DB-postgresql instproc 1row {{-dbn ""} {-bind ""} -prepare qn sql} {
if {$sql eq ""} {set sql [my get_sql $qn]}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
- set answers [uplevel [list [self] exec_0or1row -bind $bind $sql]]
+ set prepOpt [expr {[info exists prepare] ? [list -prepare $prepare] : ""}]
+ set answers [uplevel [list [self] exec_0or1row {*}$prepOpt -bind $bind $sql]]
if {$answers ne ""} {
foreach {att val} [ns_set array $answers] { uplevel [list set $att $val] }
ns_set free $answers
@@ -568,8 +568,8 @@
}
::xo::db::DB-postgresql instproc get_value {{-dbn ""} {-bind ""} -prepare qn sql {default ""}} {
if {$sql eq ""} {set sql [my get_sql $qn]}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
- set answers [uplevel [list [self] exec_0or1row -bind $bind $sql]]
+ set prepOpt [expr {[info exists prepare] ? [list -prepare $prepare] : ""}]
+ set answers [uplevel [list [self] exec_0or1row {*}$prepOpt -bind $bind $sql]]
if {$answers ne ""} {
set result [ns_set value $answers 0]
ns_set free $answers
@@ -579,9 +579,9 @@
}
::xo::db::DB-postgresql instproc list_of_lists {{-dbn ""} {-bind ""} -prepare qn sql} {
if {$sql eq ""} {set sql [my get_sql $qn]}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
db_with_handle db {
+ if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
set result [list]
set answers [uplevel [list ns_pg_bind select $db {*}$bindOpt $sql]]
while { [db_getrow $db $answers] } {
@@ -595,9 +595,9 @@
}
::xo::db::DB-postgresql instproc list {{-dbn ""} {-bind ""} -prepare qn sql} {
if {$sql eq ""} {set sql [my get_sql $qn]}
- if {[info exists prepare]} {set sql [:prepare -dbn $dbn -argtypes $prepare $sql]}
if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
db_with_handle db {
+ if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
set result [list]
set answers [uplevel [list ns_pg_bind select $db {*}$bindOpt $sql]]
while { [::db_getrow $db $answers] } {
@@ -607,13 +607,24 @@
}
return $result
}
+ ::xo::db::DB-postgresql instproc dml {{-dbn ""} {-bind ""} -prepare qn sql} {
+ if {$sql eq ""} {set sql [my get_sql $qn]}
+ if {$bind ne ""} {set bindOpt [list -bind $bind]} {set bindOpt ""}
+ set bind $bindOpt
+ db_with_handle -dbn $dbn db {
+ if {[info exists prepare]} {set sql [:prepare -handle $db -argtypes $prepare $sql]}
+ ::db_exec dml $db [uplevel [list [self] qn $qn]] $sql 2
+ }
+ return [db_resultrows]
+ }
- ::xo::db::DB-postgresql instproc prepare {{-dbn ""} {-argtypes ""} sql} {
+ ::xo::db::DB-postgresql instproc prepare {-handle:required {-argtypes ""} sql} {
#
# Define a md5 key for the prepared statement in nsv based on the
# sql statement.
#
set key [ns_md5 $sql]
+
if {[nsv_exists pepared_statement $key]} {
#
# The perepared statement exists already
@@ -648,29 +659,34 @@
}
#
- # Get the DB-handle.
- #
- db_with_handle -dbn $dbn db {set handle $db}
-
- #
# Cache the information, whether the prepared statement was
- # defined per pg sesson in a namespaced per-thread variable, which
- # survives multiple queries.
+ # defined per pg session. Depending on the version of the driver,
+ # we can obtain a session_id from the the db driver. If we can't,
+ # we fall back to a per request-cache (via toplevel variable).
#
- #set varName ::xo::prepared($handle,$key)
- set varName __prepared($key)
+ catch {set session_id [ns_db session_id $handle]}
+ if {[info exists session_id]} {
+ ns_log notice "=== $handle $session_id"
+ set varName ::xo::prepared($session_id,$key)
+ } else {
+ set session_id "-"
+ set varName __prepared($key)
+ }
+
if {![info exists $varName]} {
#
- # We have to check for the prepared statement and to create the
- # prepared statement if necessary.
+ # We have to check for the prepared statement in the current
+ # session and we have to create it if necessary there.
#
- if {![::xo::dc 0or1row -dbn $dbn check_prepared {select 1 from pg_prepared_statements where name = :prepName}]} {
- ns_log notice "do prepare $prepare"
- ::xo::dc dml -dbn $dbn create_prepared $prepare
+ if {[ns_pg_bind 0or1row $handle {
+ select 1 from pg_prepared_statements where name = :prepName
+ }] eq ""} {
+ ns_log notice "=== do prepare handle $handle $prepare session_id $session_id"
+ ::db_exec dml $handle qn..create_preapared $prepare
set $varName 1
}
}
- #ns_log notice "execute $execute"
+ ns_log notice "=== pepare done, handle $handle execute $execute session_id $session_id"
return $execute
}
@@ -2259,12 +2275,6 @@
}
}
- #
- # This should go into 01-sebug procs, but serializer does not
- # export aliases for xotcl objects.
- #
- nsf::method::alias ::xotcl::Object lassign -frame object ::lassign
-
set sets [uplevel [list ::xo::dc sets -dbn $dbn [self proc] $sql]]
foreach selection $sets {
if {$named_objects} {
@@ -2286,8 +2296,7 @@
lappend __result $o
}
#foreach {att val} [ns_set array $selection] {$o set $att $val}
- set selection [ns_set array $selection]
- $o lassign [dict values $selection] {*}[dict keys $selection]
+ $o mset [ns_set array $selection]
if {[$o exists object_type]} {
# set the object type if it looks like managed from XOTcl