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.89.2.6 -r1.89.2.7 --- openacs-4/packages/xotcl-core/xotcl-core.info 12 Nov 2013 10:03:11 -0000 1.89.2.6 +++ openacs-4/packages/xotcl-core/xotcl-core.info 11 Feb 2014 11:53:08 -0000 1.89.2.7 @@ -10,7 +10,7 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) 2013-09-08 @@ -48,7 +48,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.72.2.10 -r1.72.2.11 --- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 27 Jan 2014 10:01:28 -0000 1.72.2.10 +++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 11 Feb 2014 11:53:08 -0000 1.72.2.11 @@ -19,8 +19,6 @@ ::xotcl::Object instproc qn ::xotcl::Object instproc serialize ::xotcl::Object instproc show-object - ::xotcl::Object instforward db_1row - ::xotcl::Object instforward db_0or1row ::xotcl::Object instproc destroy_on_cleanup ::xotcl::Object instproc set_instance_vars_defaults ::xotcl::nonposArgs proc integer @@ -144,9 +142,27 @@ } } -::xotcl::Object instforward db_1row -objscope -::xotcl::Object instforward db_0or1row -objscope +if {[info exists ::acs::preferdbi]} { + ::xotcl::Object instforward dbi_1row -objscope ::dbi_1row + ::xotcl::Object instforward dbi_0or1row -objscope ::dbi_0or1row + ::xotcl::Object instproc db_1row {. sql} {my dbi_1row $sql} + ::xotcl::Object instproc db_0or1row {. sql} {my dbi_0or1row $sql} + ::Serializer exportMethods { + ::xotcl::Object instforward dbi_1row + ::xotcl::Object instforward dbi_0or1row + ::xotcl::Object instproc db_1row + ::xotcl::Object instproc db_0or1row + } +} else { + ::xotcl::Object instforward db_1row -objscope + ::xotcl::Object instforward db_0or1row -objscope + ::Serializer exportMethods { + ::xotcl::Object instforward db_1row + ::xotcl::Object instforward db_0or1row + } +} + ::xotcl::Object instproc serialize {} { ::Serializer deepSerialize [self] } @@ -263,7 +279,8 @@ } ::xotcl::Object instproc qn query_name { - set qn "dbqd.[my uplevel [list self class]]-[my uplevel [list self proc]].$query_name" + #set qn "dbqd.[my uplevel [list self class]]-[my uplevel [list self proc]].$query_name" + set qn "dbqd.[my uplevel {info level 0}].$query_name" return $qn } namespace eval ::xo { @@ -436,6 +453,7 @@ } proc at_cleanup {args} { + ::xo::dc profile off ::xo::broadcast receive #ns_log notice "*** start of cleanup <$args> ([array get ::xo::cleanup])" set at_end "" @@ -932,3 +950,10 @@ #ns_log notice "*** FREECONN? [ns_ictl gettraces freeconn]" #ns_ictl trace freeconn {ns_log notice "*** FREECONN isconnected=[ns_conn isconnected]"} #ns_ictl oncleanup {ns_log notice "*** ONCLEANUP isconnected=[ns_conn isconnected]"} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: 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.97.2.4 -r1.97.2.5 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 5 Oct 2013 12:36:52 -0000 1.97.2.4 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 11 Feb 2014 11:53:08 -0000 1.97.2.5 @@ -6,182 +6,622 @@ @cvs-id $Id$ } - namespace eval ::xo::db { + + ########################################################################## # - # The ns_caches below should exist, before any cached objects are - # created. Under most conditions, it is sufficient to do this in - # object-cache-init.tcl, which is performed after xotcl-core procs - # are read, but before applications using it (e.g. xowiki). However, - # if e.g. xowiki is loaded via install.xml, the -init methods of - # xotcl-core are not executed (probably a bug). Without the - # ns_cache, creating objects fails with an error. So, we moved the - # cache creation here and create caches, when they do not exist - # already. This change makes the object-cache-init.tcl - # obsolete. + # XOTcl based Database Abstraction Layer # - # Unfortunately, ns_cache has no command to check, whether - # a cache exists, so we use the little catch below to check. + # The communication to the database is determined by + # - the SQL Dialect + # - the database driver # - if {[catch {ns_cache flush xotcl_object_cache NOTHING}]} { - ns_log notice "xotcl-core: creating xotcl-object caches" + # The following classes define means to compose the behavior in + # connection objects based on these two aspects. The default + # database connection is configured in an object ::xo::dc (for + # database context) quite similar to ::xo::cc (the default + # connection context). In general ::xo::dc can be reconfigured at + # runtime, and multiple database context can be established, + # although there is no high level support to connect to multiple + # different OpenACS databases at the same time. + # + ########################################################################## - ns_cache create xotcl_object_cache \ - -size [parameter::get_from_package_key \ - -package_key xotcl-core \ - -parameter XOTclObjectCacheSize \ - -default 400000] + # + # Backend language specific (SQL Dialects) + # + ::xotcl::Class create ::xo::db::SQL + ::xo::db::SQL abstract instproc map_datatype {type} + ::xo::db::SQL abstract instproc select {type} + ::xo::db::SQL abstract instproc date_trunc {type} + ::xo::db::SQL abstract instproc date_trunc_expression {type} - ns_cache create xotcl_object_type_cache \ - -size [parameter::get_from_package_key \ - -package_key xotcl-core \ - -parameter XOTclObjectTypeCacheSize \ - -default 10000] - } - # - # A few helper functions + # generic (fallback) methods # - # Constaint names are limited in oracle to 30 characters; - # Postgres has no such limits. Therefore, we use different - # rules depending on whether we are running under Oracle or not. + ::xo::db::SQL instproc map_function_name {sql} {return $sql} + ::xo::db::SQL instproc datatype_constraint {type table att} {return ""} + ::xo::db::SQL instproc interval {interval} { + return [clock format [clock scan "-$interval"] -format "%Y-%m-%d %T"] + } + ::xo::db::SQL instproc since_interval_condition {var interval} { + set since '[clock format [clock scan "-$interval"] -format "%Y-%m-%d %T"]' + return "$var > TO_TIMESTAMP($since,'YYYY-MM-DD HH24:MI:SS')" + } + ::xo::db::SQL instproc has_ltree {} {return 0} + ::xo::db::SQL instproc has_hstore {} {return 0} + ::xo::db::SQL instproc mk_sql_constraint_name {table att suffix} { + return ${table}_${att}_$suffix + } + + + ########################################################################## # - if {[db_driverkey ""] eq "oracle"} { - proc mk_sql_constraint_name {table att suffix} { - set name ${table}_${att}_$suffix - if {[string length $name]>30} { - set sl [string length $suffix] - set name [string range ${table}_${att} 0 [expr {28 - $sl}]]_$suffix + # PostgreSQL specific methods + # + ########################################################################## + + ::xotcl::Class create ::xo::db::postgresql -superclass ::xo::db::SQL + + ::xo::db::postgresql instproc map_datatype {type} { + switch -- $type { + string { set type text } + long_text { set type text } + date { set type "timestamp with time zone" } + ltree { set type [expr {[my has_ltree] ? "ltree" : "text" }] } + } + return $type + } + + ::xo::db::postgresql instproc select { + -vars:required + -from:required + {-where ""} + {-groupby ""} + {-limit ""} + {-offset ""} + {-start ""} + {-orderby ""} + {-map_function_names false} + } { + set where_clause [expr {$where ne "" ? "WHERE $where" : ""}] + set offset_clause [expr {$offset ne "" ? "OFFSET $offset" : ""}] + set limit_clause [expr {$limit ne "" ? "LIMIT $limit" : ""}] + set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}] + set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}] + return "SELECT $vars FROM $from $where_clause $group_clause $order_clause $limit_clause $offset_clause" + } + + ::xo::db::postgresql instproc date_trunc {field date} { + return "date_trunc('$field',$date)" + } + ::xo::db::postgresql instproc date_trunc_expression {field date date_string} { + return "date_trunc('$field',$date) = '$date_string'" + } + + ::xo::db::postgresql instproc has_ltree {} { + ns_cache eval xotcl_object_cache [self]::has_ltree { + if {[my get_value check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"] > 0} { + return 1 } - return [string toupper $name] + return 0 } + } + ::xo::db::postgresql instproc has_hstore {} { + ns_cache eval xotcl_object_cache [self]::has_hstore { + if {[my get_value check_ltree "select count(*) from pg_proc where proname = 'hstore_in'"] > 0} { + return 1 + } + return 0 + } + } - # - # In case, we have no postgres, provide an adapter to the - # traditional db-operations - # - proc ::xo::db_0or1row {qn sql} { - uplevel [list ::db_0or1row [uplevel [list my qn $qn]] $sql] + namespace eval ::db {} + ::xo::db::postgresql instproc nextval {sequence} { + if {![info exists ::db::sequences]} { + ns_log notice "-- creating per thread sequence table" + foreach s [::xo::dc list relnames "select relname from pg_class where relkind = 'S'"] { + set ::db::sequences($s) 1 + } } - proc ::xo::db_1row {qn sql} { - uplevel [list ::db_1row [uplevel [list my qn $qn]] $sql] + if {[info exists ::db::sequences(t_$sequence)]} { + #ns_log notice "-- found t_$sequence" + set sequenceName t_$sequence + set nextval [::xo::dc get_value nextval "select nextval(:sequenceName)"] + } elseif {[info exists ::db::sequences($sequence)]} { + #ns_log notice "-- found $sequence" + set sequenceName $sequence + set nextval [::xo::dc get_value nextval "select nextval(:sequenceName)"] + } elseif { [::xo::dc db_0or1row 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 + # + } 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 [::xo::dc get_value nextval "select nextval from :sequence"] } - proc ::xo::db_string {qn sql {default ""}} { - uplevel [list ::db_string [uplevel [list my qn $qn]] $sql -default $default] + return $nextval + } + + + ########################################################################## + # + # Oracle specific methods + # + ########################################################################## + + ::xotcl::Class create ::xo::db::oracle -superclass ::xo::db::SQL + + ::xo::db::oracle instproc map_function_name {sql} { + return [string map [list "__" .] $sql] + } + + ::xo::db::oracle instproc map_datatype {type} { + switch -- $type { + string { set type varchar2(1000) } + text { set type varchar2(4000) } + long_text { set type clob } + boolean { set type char(1) } + ltree { set type varchar2(1000) } } - proc ::xo::db_list {qn sql} { - uplevel [list ::db_list [uplevel [list my qn $qn]] $sql] + return $type + } + ::xo::db::oracle instproc datatype_constraint {type table att} { + set constraint "" + switch -- $type { + boolean { + set cname [my mk_sql_constraint_name $table $att _ck] + set constraint "constraint $cname check ($att in ('t','f'))"} } - proc ::xo::db_list_of_lists {qn sql} { - uplevel [list ::db_list_of_lists [uplevel [list my qn $qn]] $sql] + return $constraint + } + + ::xo::db::oracle instproc select { + -vars:required + -from:required + {-where ""} + {-groupby ""} + {-limit ""} + {-offset ""} + {-start ""} + {-orderby ""} + {-map_function_names false} + } { + # "-start" not used so far + set where_clause [expr {$where ne "" ? "WHERE $where" : ""}] + set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}] + set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}] + if {$map_function_names} {set vars [my map_function_name $vars]} + set sql "SELECT $vars FROM $from $where_clause $group_clause" + if {$limit ne "" || $offset ne ""} { + if {$offset eq ""} { + set limit_clause "ROWNUM <= $limit" + } elseif {$limit eq ""} { + set limit_clause "ROWNUM >= $offset" + } else { + set limit_clause "ROWNUM BETWEEN $offset and [expr {$offset+$limit}]" + } + # for pagination, we will need an "inner" sort, such as + # SELECT * FROM (SELECT ...., ROW_NUMBER() OVER (ORDER BY ...) R FROM table) WHERE R BETWEEN 0 and 100 + set sql "SELECT * FROM ($sql $order_clause) WHERE $limit_clause" + } else { + append sql " " $order_clause } - } else { + my log "--returned sql = $sql" + return $sql + } + ::xo::db::oracle instproc date_trunc {field date} { + return "to_char(trunc($date,'$field'), 'YYYY-MM-DD HH24:MI:SS')" + } + ::xo::db::oracle instproc date_trunc_expression {field date date_string} { + return "trunc($date,'$field') = trunc(to_date('$date_string','YYYY-MM-DD'),'$field')" + } + ::xo::db::oracle instproc mk_sql_constraint_name {table att suffix} { + # + # Constaint names are limited in oracle to 30 characters; + # Postgres has no such limits. Therefore, we use different + # rules depending on whether we are running under Oracle or not. + # + set name ${table}_${att}_$suffix + if {[string length $name] > 30} { + set sl [string length $suffix] + set name [string range ${table}_${att} 0 [expr {28 - $sl}]]_$suffix + } + return [string toupper $name] + } - proc mk_sql_constraint_name {table att suffix} { - set name ${table}_${att}_$suffix - return $name + ::xo::db::oracle instproc nextval {sequence} { + return [xo::dc get_value nextval "select $sequence.nextval from dual"] + } + + ########################################################################## + # + # Database Driver + # + # Abstract form the Tcl interface that the drivers are offering to + # issue SQL commands and to perform profiling. + # + + ::xotcl::Class create ::xo::db::Driver + ::xo::db::Driver abstract instproc sets {{-dbn ""} qn sql} + ::xo::db::Driver abstract instproc 0or1row {{-dbn ""} qn sql} + ::xo::db::Driver abstract instproc 1row {{-dbn ""} qn sql} + ::xo::db::Driver abstract instproc list_of_lists {{-dbn ""} qn sql} + ::xo::db::Driver abstract instproc list {{-dbn ""} qn sql} + ::xo::db::Driver abstract instproc dml {{-dbn ""} qn sql} + ::xo::db::Driver abstract instproc foreach {{-dbn ""} qn sql script} + ::xo::db::Driver abstract instproc transaction {{-dbn ""} script} + ::xo::db::Driver abstract instproc ds {onOff} + + # + # Driver specific and Driver/Dialect specific hooks + # + ::xotcl::Class create ::xo::db::DB -superclass ::xo::db::Driver + ::xotcl::Class create ::xo::db::DB-postgresql -superclass {::xo::db::DB ::xo::db::postgresql} + ::xotcl::Class create ::xo::db::DB-oracle -superclass {::xo::db::DB ::xo::db::oracle} + + ::xotcl::Class create ::xo::db::DBI -superclass ::xo::db::Driver + ::xotcl::Class create ::xo::db::DBI-postgresql -superclass {::xo::db::DBI ::xo::db::postgresql} + + ########################################################################## + # + # DBI support + # + ::xo::db::DBI instproc profile {onOff} { + if {$onOff} { + my mixin ::xo::db::DBI::Profile + } else { + if {[my info mixin] ne ""} {my mixin ""} } + } - # - # In case, we have postgres, we can provide an much faster - # interface under ::xo::*, which can make the SQL queries - # interface up to twice as fast (depending on the complexity of - # the query). In many cases of the SQL-queries in xowiki, we see - # an improvement of 25-30%. - # + ::xo::db::DBI instproc sets {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + return [my uplevel [list dbi_rows -result sets $sql]] + } - proc ::xo::db::pg_0or1row {sql} { - ::db_with_handle h { - return [uplevel [list ns_pg_bind 0or1row $h $sql]] - } + # + # foreach based on "dbi_rows + results avlists" + # + ::xo::db::DBI instproc foreach {{-dbn ""} qn sql body} { + if {$sql eq ""} {set sql [my get_sql $qn]} + #my uplevel [list dbi_foreach $sql $body] + set avlists [my uplevel [list dbi_rows -result avlists -- $sql]] + foreach avlist $avlists { + foreach {a v} $avlist {my uplevel [list set $a $v]} + my uplevel $body } + } + # + # foreach based on "dbi_eval" + # + ::xo::db::DBI instproc foreach {{-dbn ""} qn sql body} { + if {$sql eq ""} {set sql [my get_sql $qn]} + my uplevel [list dbi_foreach $sql $body] + } - proc ::xo::db_0or1row {qn sql} { - set answers [uplevel [list ::xo::db::pg_0or1row $sql]] - if {$answers ne ""} { - foreach {att val} [ns_set array $answers] { uplevel [list set $att $val] } - ns_set free $answers - return 1 - } - return 0 + ::xo::db::DBI instproc 0or1row {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + return [my uplevel [list ::dbi_0or1row $sql]] + } + ::xo::db::DBI instproc 1row {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + return [my uplevel [list ::dbi_1row $sql]] + } + ::xo::db::DBI instproc list_of_lists {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + return [my uplevel [list ::dbi_rows -result lists -max 1000000 $sql]] + } + ::xo::db::DBI instproc list {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + set flat [my uplevel [list ::dbi_rows -columns __columns $sql]] + if {[my uplevel {llength $__columns}] > 1} {error "query is returing more than one column"} + return $flat + } + ::xo::db::DBI instproc dml {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + return [my uplevel [list ::dbi_dml $sql]] + } + ::xo::db::DBI instproc transaction {{-dbn ""} script} { + return [my uplevel [list ::dbi_eval -transaction committed $script]] + } + + ::xo::db::DBI instproc get_value {{-dbn ""} qn sql {default ""}} { + if {$sql eq ""} {set sql [my get_sql $qn]} + set answers [my uplevel [list ::dbi_rows -result sets -max 1 $sql]] + if {$answers ne ""} { + set result [ns_set value $answers 0] + ns_set free $answers + return $result } + return $default + } - proc ::xo::db_1row {qn sql} { - set answers [uplevel [list ::xo::db::pg_0or1row $sql]] - if {$answers ne ""} { - foreach {att val} [ns_set array $answers] { uplevel [list set $att $val] } - ns_set free $answers - return 1 - } - error "query $sql did not return an answer" + ::xo::db::DBI instproc get_sql {{-dbn ""} qn} { + set full_statement_name [db_qd_get_fullname $qn 2] + set full_query [db_qd_fetch $full_statement_name $dbn] + return [db_fullquery_get_querytext $full_query] + } + + # + # DBI profiling with developer support + # + ::xotcl::Class create ::xo::db::DBI::Profile + + foreach call {sets 0or1row 1row list_of_lists list dml} { + + ::xo::db::DBI::Profile instproc $call {{-dbn ""} qn sql} { + if {$sql eq ""} {set sql [my get_sql $qn]} + set start_time [expr {[clock clicks -microseconds]/1000.0}] + set result [next] + ds_add db $dbn [my ds_map [self proc]] $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 "" + return $result } + } - proc ::xo::db_string {qn sql {default ""}} { - set answers [uplevel [list ::xo::db::pg_0or1row $sql]] - if {$answers ne ""} { - set result [ns_set value $answers 0] - return $result - } - return $default + # + # foreach based on "dbi_rows + results avlists" + # + ::xo::db::DBI::Profile instproc foreach {{-dbn ""} qn sql body} { + if {$sql eq ""} {set sql [my get_sql $qn]} + set start_time [expr {[clock clicks -microseconds]/1000.0}] + set avlists [my uplevel [list dbi_rows -result avlists -- $sql]] + ds_add db $dbn "exec foreach" $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 "" + foreach avlist $avlists { + foreach {a v} $avlist {my uplevel [list set $a $v]} + my uplevel $body } + } - proc ::xo::db_list {qn sql} { - db_with_handle db { - set result [list] - set answers [uplevel [list ns_pg_bind select $db $sql]] - while { [::db_getrow $db $answers] } { - lappend result [ns_set value $answers 0] - } - ns_set free $answers + # + # foreach based on "dbi_foreach" + # + #::xo::db::DBI::Profile instproc foreach {{-dbn ""} qn sql body} { + # if {$sql eq ""} {set sql [my get_sql $qn]} + # set start_time [expr {[clock clicks -microseconds]/1000.0}] + # set result [next] + # ds_add db $dbn "exec [self proc]" $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 "" + # return $result + #} + + ::xo::db::DBI::Profile instproc ds_map {name} { + if {$name in {dml exec 1row 0or1row select}} {return $name} + return "exec $name" + } + + # The following should not be necessary, but there seems to be a bad + # interaction when "ns_cache eval" calls 1row with a mixin, doing a + # :uplevel (the mixin should be transparant). Without "ns_cache eval" + # things look fine. + ::xo::db::DBI::Profile instproc 1row {{-dbn ""} qn sql} { + set start_time [expr {[clock clicks -microseconds]/1000.0}] + set result [my uplevel [list ::dbi_1row $sql]] + ds_add db $dbn [my ds_map [self proc]] $qn $sql $start_time [expr {[clock clicks -microseconds]/1000.0}] 0 "" + return $result + } + + + ########################################################################## + # + # DB support + # + ::xo::db::DB instproc profile {onOff} { + # built-in + } + + ::xo::db::DB instproc sets {{-dbn ""} qn sql} { + set qn [uplevel [list [self] qn $qn]] + db_with_handle -dbn $dbn db { + set result [list] + set answers [uplevel [list ns_pg_bind select $db $sql]] + while { [::db_getrow $db $answers] } { + lappend result [ns_set copy $answers] } - return $result } + return $result + } - proc ::xo::db_list_of_lists {qn sql} { - db_with_handle db { - set result [list] - set answers [uplevel [list ns_pg_bind select $db $sql]] - while { [db_getrow $db $answers] } { - set row [list] - foreach {att value} [ns_set array $answers] {lappend row $value} - lappend result $row - } - ns_set free $answers - } - return $result + ::xo::db::DB instproc foreach {{-dbn ""} qn sql body} { + set qn [uplevel [list [self] qn $qn]] + uplevel [list ::db_foreach -dbn $dbn $qn $sql $body] + } + + ::xo::db::DB instproc exec_0or1row {sql} { + # Helper, used from several postgres-spefic one-tuple queries + ::db_with_handle h { + return [uplevel [list ns_pg_bind 0or1row $h $sql]] } + } - ad_proc has_ltree {} { - Check, whether ltree is available (postgres only) - } { - ns_cache eval xotcl_object_cache ::xo::has_ltree { - if {[db_driverkey ""] eq "postgresql" && - [::xo::db_string check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"]} { - return 1 - } - return 0 + ::xo::db::DB instproc 0or1row {{-dbn ""} qn sql} { + uplevel [list ::db_0or1row [uplevel [list [self] qn $qn]] $sql] + } + ::xo::db::DB instproc 1row {{-dbn ""} qn sql} { + uplevel [list ::db_1row [uplevel [list [self] qn $qn]] $sql] + } + ::xo::db::DB instproc dml {{-dbn ""} qn sql} { + uplevel [list ::db_dml [uplevel [list [self] qn $qn]] $sql] + return [db_resultrows] + } + ::xo::db::DB instproc get_value {{-dbn ""} qn sql {default ""}} { + uplevel [list ::db_string [uplevel [list [self] qn $qn]] $sql -default $default] + } + ::xo::db::DB instproc list_of_lists {qn sql} { + uplevel [list ::db_list_of_lists [uplevel [list [self] qn $qn]] $sql] + } + ::xo::db::DB instproc list {qn sql} { + uplevel [list ::db_list [uplevel [list [self] qn $qn]] $sql] + } + + proc ::xo::db::pg_0or1row {sql} { + ns_log notice "::xo::db::pg_0or1row decprecated" + ::db_with_handle h { + return [uplevel [list ns_pg_bind 0or1row $h $sql]] + } + } + + # + # The view-insert operation is an operation inserting into a view as eg. in + # + # insert into xowiki_form_pagei (...) values (...) + # + # Depending on the version of the CR and the driver, we need + # different calls to the driver. The default operation is "dml", but + # in the DB-postgres combo, we need 0or1row. + # Provide the appropriate db_* call for the view update. Earlier + # versions up to 5.3.0d1 used db_dml, newer versions (since around + # july 2006) have to use 0or1row, when the patch for deadlocks + # and duplicate items was applied... + # + apm_version_get -package_key acs-content-repository -array info + array get info + if {[apm_version_names_compare $info(version_name) 5.3.0d1] >= 1} { + ::xo::db::DB-postgresql instproc insert-view-operation {} { return 0or1row } + } + array unset info + + # the default insert-view operation + ::xo::db::Driver instproc insert-view-operation {} { return dml } + + + # + # DB driver functions, optimized for PostgreSQL + # + ::xo::db::DB-postgresql instproc 0or1row {qn sql} { + set answers [uplevel [list [self] exec_0or1row $sql]] + if {$answers ne ""} { + foreach {att val} [ns_set array $answers] { uplevel [list set $att $val] } + ns_set free $answers + return 1 + } + return 0 + } + ::xo::db::DB-postgresql instproc 1row {qn sql} { + set answers [uplevel [list [self] exec_0or1row $sql]] + if {$answers ne ""} { + foreach {att val} [ns_set array $answers] { uplevel [list set $att $val] } + ns_set free $answers + return 1 + } + error "query $sql did not return an answer" + } + ::xo::db::DB-postgresql instproc get_value {qn sql {default ""}} { + set answers [uplevel [list [self] exec_0or1row $sql]] + if {$answers ne ""} { + set result [ns_set value $answers 0] + ns_set free $answers + return $result + } + return $default + } + ::xo::db::DB-postgresql instproc list_of_lists {qn sql} { + db_with_handle db { + set result [list] + set answers [uplevel [list ns_pg_bind select $db $sql]] + while { [db_getrow $db $answers] } { + set row [list] + foreach {att value} [ns_set array $answers] {lappend row $value} + lappend result $row } + ns_set free $answers } - - ad_proc has_hstore {} { - Check, whether hstore is available (postgres only) - } { - ns_cache eval xotcl_object_cache ::xo::has_hstore { - if {[db_driverkey ""] eq "postgresql" && - [::xo::db_string check_hstore "select count(*) from pg_proc where proname = 'hstore_in'"]} { - return 1 - } - return 0 + return $result + } + ::xo::db::DB-postgresql instproc list {qn sql} { + db_with_handle db { + set result [list] + set answers [uplevel [list ns_pg_bind select $db $sql]] + while { [::db_getrow $db $answers] } { + lappend result [ns_set value $answers 0] } + ns_set free $answers } + return $result } - + + ########################################################################## # + # Depending on the configured and available driver, select the SQL + # interface. For the time being, we use just a single DB backend + # per server and therefore a single database connection object, + # namely ::xo::dc + # + ########################################################################## + + if {[info exists ::acs::preferdbi]} { + ::xo::db::DBI-postgresql create ::xo::dc + } elseif {[db_driverkey ""] eq "postgresql"} { + ::xo::db::DB-postgresql create ::xo::dc + } else { + ::xo::db::DB-oracle create ::xo::dc + } + + + + ########################################################################## + # + # The ns_caches below should exist, before any cached objects are + # created. Under most conditions, it is sufficient to do this in + # object-cache-init.tcl, which is performed after xotcl-core procs + # are read, but before applications using it (e.g. xowiki). However, + # if e.g. xowiki is loaded via install.xml, the -init methods of + # xotcl-core are not executed (probably a bug). Without the + # ns_cache, creating objects fails with an error. So, we moved the + # cache creation here and create caches, when they do not exist + # already. This change makes the object-cache-init.tcl + # obsolete. + # + # Unfortunately, ns_cache has no command to check, whether + # a cache exists, so we use the little catch below to check. + # + if {[catch {ns_cache flush xotcl_object_cache NOTHING}]} { + ns_log notice "xotcl-core: creating xotcl-object caches" + + ns_cache create xotcl_object_cache \ + -size [parameter::get_from_package_key \ + -package_key xotcl-core \ + -parameter XOTclObjectCacheSize \ + -default 400000] + + ns_cache create xotcl_object_type_cache \ + -size [parameter::get_from_package_key \ + -package_key xotcl-core \ + -parameter XOTclObjectTypeCacheSize \ + -default 10000] + } + + + + ad_proc -deprecated has_ltree {} { + Check, whether ltree is available (postgres only) + } { + ::xo::dc has_ltree + } + + ad_proc -deprecated has_hstore {} { + Check, whether hstore is available (postgres only) + } { + ::xo::dc has_hstore + } + + + # # The object require provides an interface to create certain # resources in case they are not created already. # ::xotcl::Object create require - + #require set postgresql_table_exists {select 1 from pg_tables where tablename = '$name'} require set postgresql_table_exists {select 1 from pg_class where relname = '$name' and\ pg_table_is_visible(oid)} @@ -190,27 +630,27 @@ require set oracle_table_exists {select 1 from user_tables where table_name = '$name'} require set oracle_view_exists {select 1 from user_views where view_name = '$name'} require set oracle_index_exists {select 1 from user_indexes where index_name = '$name'} - + require proc exists_table {name} { if {[db_driverkey ""] eq "oracle"} { set name [string toupper $name] } else { set name [string tolower $name] } - ::xo::db_0or1row "" [subst [my set [db_driverkey ""]_table_exists]] + ::xo::dc 0or1row "" [subst [my set [db_driverkey ""]_table_exists]] } - + require proc table {name definition} { if {![my exists_table $name]} { #my log "--table $name does not exist, creating with $definition" - db_dml [my qn create-table-$name] "create table $name ($definition)" + ::xo::dc dml create-table-$name "create table $name ($definition)" } } require proc view {name definition} { if {[db_driverkey ""] eq "oracle"} {set name [string toupper $name]} - if {![::xo::db_0or1row "" [subst [my set [db_driverkey ""]_view_exists]]]} { - db_dml [my qn create-view-$name] "create view $name AS $definition" + if {![::xo::dc 0or1row "" [subst [my set [db_driverkey ""]_view_exists]]]} { + ::xo::dc dml create-view-$name "create view $name AS $definition" } } @@ -219,24 +659,24 @@ regsub -all ", *" $colpart _ colpart set suffix [expr {$unique ? "un_idx" : "idx"}] set uniquepart [expr {$unique ? "UNIQUE" : ""}] - set name [::xo::db::mk_sql_constraint_name $table $colpart $suffix] - if {![::xo::db_0or1row "" [subst [my set [db_driverkey ""]_index_exists]]]} { + set name [::xo::dc mk_sql_constraint_name $table $colpart $suffix] + if {![::xo::dc 0or1row "" [subst [my set [db_driverkey ""]_index_exists]]]} { if {[db_driverkey ""] eq "oracle"} {set using ""} set using [expr {$using ne "" ? "using $using" : ""}] - db_dml [my qn create-index-$name] \ + ::xo::dc dml create-index-$name \ "create $uniquepart index $name ON $table $using ($col)" } } require proc package {package_key} { if {![my exists required_package($package_key)]} { foreach path [apm_get_package_files \ - -package_key $package_key \ - -file_types tcl_procs] { + -package_key $package_key \ + -file_types tcl_procs] { # Use apm_source instead of source to prevent double # sourcing by the apm_loader (temporary solution, double # sourcing should no happen) - uplevel #1 apm_source "[acs_root_dir]/packages/$package_key/$path" + uplevel #1 apm_source "[acs_root_dir]/packages/$package_key/$path" } my set required_package($package_key) 1 } @@ -262,184 +702,49 @@ if {[db_driverkey ""] eq "postgresql"} { # only necessary with postgres if {[info exists kernel_older_than]} { - if {[apm_version_names_compare \ - $kernel_older_than [ad_acs_version]] < 1} { - # nothing to do - return - } + if {[apm_version_names_compare \ + $kernel_older_than [ad_acs_version]] < 1} { + # nothing to do + return + } } if {[info exists package_key_and_version_older_than]} { - set p [split $package_key_and_version_older_than] - if {[llength $p] != 2} { - error "package_key_and_version_older_than should be\ + set p [split $package_key_and_version_older_than] + if {[llength $p] != 2} { + error "package_key_and_version_older_than should be\ of the form 'package_key version'" - } - lassign $p package_key version - set installed_version [apm_highest_version_name $package_key] - if {[apm_version_names_compare $installed_version $version] > -1} { - # nothing to do - return - } + } + lassign $p package_key version + set installed_version [apm_highest_version_name $package_key] + if {[apm_version_names_compare $installed_version $version] > -1} { + # nothing to do + return + } } if {[info exists check_function]} { - set check_function [string toupper $check_function] - set function_exists [::xo::db_string query_version { - select 1 from acs_function_args where function = :check_function - limit 1 - } 0] - if {$function_exists} { - # nothing to do - return - } + set check_function [string toupper $check_function] + set function_exists [::xo::dc get_value query_version { + select 1 from acs_function_args where function = :check_function + limit 1 + } 0] + if {$function_exists} { + # nothing to do + return + } } if {[file readable $sql_file]} { - my log "Sourcing '$sql_file'" - db_source_sql_file $sql_file - ::xo::db::Class create_all_functions - return 1 + my log "Sourcing '$sql_file'" + db_source_sql_file $sql_file + ::xo::db::Class create_all_functions + return 1 } else { - my log "Could not source '$sql_file'" + my log "Could not source '$sql_file'" } } return 0 } - ########################################################## - # - # ::xo::db::sql is used for interfacing with the database - # - # Many of the differences between postgres and oracle - # are handled by this object. Most prominently, - # - # ::xo::db::sql select ... - # - # provides a portable interface for creating SQL - # statments for postgres or oracle, handling e.g. - # limit/offset, etc. in a generic way. - ::xotcl::Object create sql - - if {[db_driverkey ""] eq "postgresql"} { - - # - # PostgresSQL specific functions - # - - sql proc map_function_name {sql} { - return $sql - } - - sql proc map_datatype {type} { - switch -- $type { - string { set type text } - long_text { set type text } - date { set type "timestamp with time zone" } - ltree { set type [expr {[::xo::db::has_ltree] ? "ltree" : "text" }] } - } - return $type - } - sql proc datatype_constraint {type table att} { - # for postgres, we do not need type specific constraints - return "" - } - - sql proc select { - -vars:required - -from:required - {-where ""} - {-groupby ""} - {-limit ""} - {-offset ""} - {-start ""} - {-orderby ""} - {-map_function_names false} - } { - set where_clause [expr {$where ne "" ? "WHERE $where" : ""}] - set offset_clause [expr {$offset ne "" ? "OFFSET $offset" : ""}] - set limit_clause [expr {$limit ne "" ? "LIMIT $limit" : ""}] - set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}] - set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}] - return "SELECT $vars FROM $from $where_clause $group_clause $order_clause $limit_clause $offset_clause" - } - - sql proc date_trunc {field date} { - return "date_trunc('$field',$date)" - } - sql proc date_trunc_expression {field date date_string} { - return "date_trunc('$field',$date) = '$date_string'" - } - - } else { ;# Oracle - - sql proc map_function_name {sql} { - return [string map [list "__" .] $sql] - } - - sql proc map_datatype {type} { - switch -- $type { - string { set type varchar2(1000) } - text { set type varchar2(4000) } - long_text { set type clob } - boolean { set type char(1) } - ltree { set type varchar2(1000) } - } - return $type - } - sql proc datatype_constraint {type table att} { - set constraint "" - switch -- $type { - boolean { - set cname [::xo::db::mk_sql_constraint_name $table $att _ck] - set constraint "constraint $cname check ($att in ('t','f'))"} - } - return $constraint - } - - sql proc select { - -vars:required - -from:required - {-where ""} - {-groupby ""} - {-limit ""} - {-offset ""} - {-start ""} - {-orderby ""} - {-map_function_names false} - } { - # "-start" not used so far - set where_clause [expr {$where ne "" ? "WHERE $where" : ""}] - set order_clause [expr {$orderby ne "" ? "ORDER BY $orderby" : ""}] - set group_clause [expr {$groupby ne "" ? "GROUP BY $groupby" : ""}] - if {$map_function_names} {set vars [my map_function_name $vars]} - set sql "SELECT $vars FROM $from $where_clause $group_clause" - if {$limit ne "" || $offset ne ""} { - if {$offset eq ""} { - set limit_clause "ROWNUM <= $limit" - } elseif {$limit eq ""} { - set limit_clause "ROWNUM >= $offset" - } else { - set limit_clause "ROWNUM BETWEEN $offset and [expr {$offset+$limit}]" - } - # for pagination, we will need an "inner" sort, such as - # SELECT * FROM (SELECT ...., ROW_NUMBER() OVER (ORDER BY ...) R FROM table) WHERE R BETWEEN 0 and 100 - set sql "SELECT * FROM ($sql $order_clause) WHERE $limit_clause" - } else { - append sql " " $order_clause - } - my log "--returned sql = $sql" - return $sql - } - sql proc date_trunc {field date} { - return "to_char(trunc($date,'$field'), 'YYYY-MM-DD HH24:MI:SS')" - } - sql proc date_trunc_expression {field date date_string} { - return "trunc($date,'$field') = trunc(to_date('$date_string','YYYY-MM-DD'),'$field')" - } - } - sql proc since_interval_condition {var interval} { - set since [clock format [clock scan "-$interval"] -format "%Y-%m-%d %T"] - return "$var > TO_TIMESTAMP('$since','YYYY-MM-DD HH24:MI:SS')" - } } @@ -488,7 +793,7 @@ @return 0 or 1 } { - return [::xo::db_string select_object { + return [::xo::dc get_value select_object { select 1 from acs_objects where object_id = :id } 0] } @@ -509,7 +814,7 @@ @return object_type, typically an XOTcl class } { return [ns_cache eval xotcl_object_type_cache $id { - ::xo::db_1row get_class "select object_type from acs_objects where object_id=$id" + ::xo::dc 1row get_class "select object_type from acs_objects where object_id=:id" return $object_type }] } @@ -545,7 +850,7 @@ @return table_name } { - return [::xo::db_string get_table_name { + return [::xo::dc get_value get_table_name { select lower(table_name) as table_name from acs_object_types where object_type = :object_type } ""] } @@ -555,7 +860,7 @@ @return 0 or 1 } { - return [::xo::db_string check_type { + return [::xo::dc get_value check_type { select 1 from acs_object_types where object_type = :object_type } 0] } @@ -571,9 +876,9 @@ set table_name [::xo::db::Class get_table_name -object_type $object_type] if {$table_name ne ""} { if {[catch { - db_dml [my qn delete_instances] "delete from $table_name" + ::xo::dc dml delete_instances "delete from $table_name" if {$drop_table} { - db_dml [my qn drop_table] "drop table $table_name" + ::xo::dc dml drop_table "drop table $table_name" } } errorMsg]} { my log "error during drop_type" @@ -589,7 +894,7 @@ } { set table_name [::xo::db::Class get_table_name -object_type $object_type] if {$table_name ne ""} { - db_dml delete_instances {delete from :table_name} + ::xo::dc dml delete_instances {delete from :table_name} } } @@ -607,7 +912,7 @@ } { # some table_names and id_columns in acs_object_types are unfortunately upper case, # so we have to convert to lower case here.... - ::xo::db_1row fetch_class { + ::xo::dc 1row fetch_class { select object_type, supertype, pretty_name, lower(id_column) as id_column, lower(table_name) as table_name from acs_object_types where object_type = :object_type } @@ -627,7 +932,7 @@ } else { #my log "--db we have a class $classname" } - set attributes [::xo::db_list_of_lists get_atts { + set attributes [::xo::dc list_of_lists get_atts { select attribute_name, pretty_name, pretty_plural, datatype, default_value, min_n_values, max_n_values from acs_attributes where object_type = :object_type @@ -667,249 +972,262 @@ # interface for stored procedures # - if {[db_driverkey ""] eq "postgresql"} { + ::xo::db::postgresql instproc get_all_package_functions {} { # - # PostgreSQL + # Load defintions in one step from function args; only for + # those definitions where we do not have function args, we parse + # the function arg aliases. # - -# ::xo::db::Class proc get_all_package_functions {} { -# # -# # Get all package functions (package name, object name) from manually -# # maintained function args (created via define_function_args) -# # -# return [db_list_of_lists [my qn [self proc]] { -# select distinct -# substring(function from 0 for position('__' in function)) as package_name, -# substring(function from position('__' in function)+2) as object_name -# from acs_function_args -# }] -# } - - ::xo::db::Class proc get_all_package_functions {} { - # - # Load defintions in one swap fropm function args; only for - # those definitions where we do not have function args, we parse - # the function arg aliases. - # - set definitions [::xo::db_list_of_lists get_all_package_functions0 { - select - args.function, - args.arg_name, - args.arg_default - from acs_function_args args - order by function, arg_seq - }] - set last_function "" - set function_args {} - foreach definition $definitions { - lassign $definition function arg_name default - if {$last_function ne "" && $last_function ne $function} { - set ::xo::db::sql::fnargs($last_function) $function_args - #puts stderr "$last_function [list $function_args]" - set function_args {} - } - lappend function_args [list $arg_name $default] - set last_function $function + set definitions [::xo::dc list_of_lists get_all_package_functions0 { + select + args.function, + args.arg_name, + args.arg_default + from acs_function_args args + order by function, arg_seq + }] + set last_function "" + set function_args {} + foreach definition $definitions { + lassign $definition function arg_name default + if {$last_function ne "" && $last_function ne $function} { + set ::xo::db::fnargs($last_function) $function_args + #puts stderr "$last_function [list $function_args]" + set function_args {} } - set ::xo::db::sql::fnargs($last_function) $function_args - #puts stderr "$last_function [list $function_args]" - ns_log notice "loaded [array size ::xo::db::sql::fnargs] definitions from function args" - #ns_log notice "... [lsort [array names ::xo::db::sql::fnargs *__*]]" - - # - # Get all package functions (package name, object name) from PostgreSQL - # system catalogs. - # - return [::xo::db_list_of_lists [self proc] { - select distinct - upper(substring(proname from 0 for position('__' in proname))) as package_name, - upper(substring(proname from position('__' in proname)+2)) as object_name - from pg_proc - where strpos(proname,'__') > 1 - }] + lappend function_args [list $arg_name $default] + set last_function $function } + set ::xo::db::fnargs($last_function) $function_args + #puts stderr "$last_function [list $function_args]" + ns_log notice "loaded [array size ::xo::db::fnargs] definitions from function args" + #ns_log notice "... [lsort [array names ::xo::db::fnargs *__*]]" -# ::xo::db::Class instproc get_function_args {package_name object_name} { -# # -# # Get function_args for a single sql-function from manually -# # maintained function args (created via define_function_args) -# # -# return [db_list_of_lists [my qn get_function_params] { -# select args.arg_name, args.arg_default -# from acs_function_args args -# where args.function = upper(:package_name) || '__' || upper(:object_name) -# order by function, arg_seq -# }] -# } + # + # Get all package functions (package name, object name) from PostgreSQL + # system catalogs. + # + return [::xo::dc list_of_lists [self proc] { + select distinct + upper(substring(proname from 0 for position('__' in proname))) as package_name, + upper(substring(proname from position('__' in proname)+2)) as object_name + from pg_proc + where strpos(proname,'__') > 1 + }] + } - ::xo::db::Class instproc get_function_args {package_name object_name} { - set key [string toupper ${package_name}__${object_name}] + ::xo::db::postgresql instproc get_function_args {package_name object_name} { + set key [string toupper ${package_name}__${object_name}] + # + # If we have function ares already loaded, there is nothing to do + # + if {[info exists ::xo::db::fnargs($key)]} { + return $::xo::db::fnargs($key) + } + ns_log notice "obtain fnargs for $key from PostgreSQL via parsing function definition" - if {[info exists ::xo::db::sql::fnargs($key)]} { - return $::xo::db::sql::fnargs($key) - } - - # - # Get function_args for a single sql-function from PostgreSQL - # system catalogs. We retrieve always the longest function for - # our definition, since we use an interface with non positional - # arguments, where in most situations, many arguments are - # optional. In cases, where more function with the samenumber - # of arguments are available, we sort by the type as well to - # obtain a predictable ordering and to give string interfaces - # (text, varchar) a higher priority than integer or boolean - # arguments (e.g. int4, int8m bool). - # - # Note: based on the ordering, char has lower priority over int* which - # is probably a bug, but is not a problem in OpenACS. - # - # Note, that we can as well get the type in future versions. - # - db_foreach [my qn get_function_params] { - select proname, pronargs, proargtypes, prosrc - from pg_proc - where proname = lower(:package_name) || '__' || lower(:object_name) - order by pronargs desc, proargtypes desc - } { - set n 1 - set function_args [list] - foreach line [split $prosrc \n] { - if {[regexp -nocase "alias +for +\\\$$n" $line]} { - regexp {^[^a-zA-Z]+([a-zA-Z0-9_]+)\s} $line _ fq_name - if {![info exists fq_name]} { - ns_log notice "--***** Could not retrieve argument name for $proname\ + # + # Get function_args for a single sql-function from PostgreSQL + # system catalogs by retrieving the function source code and + # passing it. We retrieve always the function with the longest + # argument list for our definition, since we use an interface with + # non positional arguments, where in most situations, many + # arguments are optional. In cases, where more function with the + # same number of arguments are available, we sort by the type as + # well to obtain a predictable ordering and to give string + # interfaces (text, varchar) a higher priority than integer or + # boolean arguments (e.g. int4, int8m bool). + # + # Note: based on the ordering, char has lower priority over int* + # which is probably a bug, but is not a problem in OpenACS. + # + # Note, that we can as well get the type in future versions. + # + ::xo::dc foreach get_function_params { + select proname, pronargs, proargtypes, prosrc + from pg_proc + where proname = lower(:package_name) || '__' || lower(:object_name) + order by pronargs desc, proargtypes desc + } { + set n 1 + set function_args [list] + foreach line [split $prosrc \n] { + if {[regexp -nocase "alias +for +\\\$$n" $line]} { + regexp {^[^a-zA-Z]+([a-zA-Z0-9_]+)\s} $line _ fq_name + if {![info exists fq_name]} { + ns_log notice "--***** Could not retrieve argument name for $proname\ argument $n from line '$line' in $prosrc'" - set fq_name arg$n - } - #lappend fq_names $fq_name - set name $fq_name - set default "" - if {![regexp {^.+__(.+)$} $fq_name _ name]} { - regexp {^[vp]_(.+)$} $fq_name _ name - } - if {[regexp {^.*-- default +([^, ]+) *$} $line _ default]} { - set default [string trim $default '\n\r] - } - lappend function_args [list [string toupper $name] $default] - if {[incr n]>$pronargs} break + set fq_name arg$n } + set name $fq_name + set default "" + if {![regexp {^.+__(.+)$} $fq_name _ name]} { + regexp {^[vp]_(.+)$} $fq_name _ name + } + if {[regexp {^.*-- default +([^, ]+) *$} $line _ default]} { + set default [string trim $default '\n\r] + } + lappend function_args [list [string toupper $name] $default] + if {[incr n]>$pronargs} break } - if {$n == 1 && $pronargs > 0} { - set comment [string map [list \n "\n----\t"] $prosrc] - ns_log notice "---- no aliases for $proname/$pronargs $comment" - continue - } - break } - return $function_args + if {$n == 1 && $pronargs > 0} { + set comment [string map [list \n "\n----\t"] $prosrc] + ns_log notice "---- no aliases for $proname/$pronargs $comment" + #continue + } + #break } + return $function_args + } - ::xo::db::Class instproc generate_psql {package_name object_name} { - set function_args [my get_function_args $package_name $object_name] - set function_args [my fix_function_args $function_args $package_name $object_name] - set psql_args [my sql-arguments $function_args $package_name $object_name] - #ns_log notice "-- select ${package_name}__${object_name} ($psql_args)" - my set sql [subst { - select ${package_name}__${object_name}($psql_args) - }] - return {ns_set value [ns_pg_bind 0or1row $db $sql] 0} + # + # The generation of the code interface code is driver specifc, since + # e.q. dbi supports option "-autonull", which simplified the + # interface code significantly + # + + # + # DBI interface method generation (with autonull): + # + + ::xo::db::DBI instproc generate_psql {package_name object_name} { + set function_args [my get_function_args $package_name $object_name] + set function_args [my fix_function_args $function_args $package_name $object_name] + set sql_info [my sql_arg_info $function_args $package_name $object_name] + #ns_log notice "-- select ${package_name}__${object_name}($psql_args)" + dict set sql_info sql [subst { select ${package_name}__${object_name}([dict get $sql_info psql_args]) }] + dict set sql_info sql_cmd [subst {dbi_1row -autonull {[dict get $sql_info sql] as result}}] + dict set sql_info body [subst { + #function_args: $function_args + [dict get [set sql_info] sql_cmd] + return \$result + }] + return $sql_info + } + + ::xo::db::DBI instproc sql_arg_info {function_args package_name object_name} { + set defined {} + set psql_args [list] + set arg_order [list] + # TODO function args not needed in dict + foreach arg $function_args { + lassign $arg arg_name default_value + lappend psql_args :[string tolower $arg_name] + lappend arg_order $arg_name + lappend defined $arg_name $default_value } + return [list \ + psql_args [join $psql_args ", "] \ + arg_order $arg_order \ + defined $defined \ + function_args $function_args] + } - ::xo::db::Class instproc generate_proc_body {} { - return { - #function_args: [my set function_args] - foreach var \[list [my set arg_order]\] { - set varname \[string tolower $var\] - if {\[info exists $varname\]} { - set $var \[set $varname\] - set _$var :$var - } else { - set _$var null - } + # + # DB and Postgres interface method generation (no autonull): + # + + ::xo::db::DB-postgresql instproc generate_psql {package_name object_name} { + set function_args [my get_function_args $package_name $object_name] + set function_args [my fix_function_args $function_args $package_name $object_name] + set sql_info [my sql_arg_info $function_args $package_name $object_name] + #ns_log notice "-- select ${package_name}__${object_name} ($psql_args)" + set sql [subst { + select ${package_name}__${object_name}([dict get $sql_info psql_args]) + }] + set sql_cmd {ns_set value [ns_pg_bind 0or1row $db $sql] 0} + dict set sql_info body [subst { + #function_args: $function_args + foreach var \[list [dict get $sql_info arg_order]\] { + set varname \[string tolower \$var\] + if {\[info exists \$varname\]} { + set \$var \[set \$varname\] + set _\$var :\$var + } else { + set _\$var null } - set sql "[my set sql]" - db_with_handle -dbn $dbn db { - #ns_log notice "--sql=$sql" - return \[ [set sql_command] \] - } } - } + set sql "$sql" + db_with_handle -dbn \$dbn db { + #ns_log notice "--sql=$sql" + return \[ $sql_cmd \] + } + }] + return $sql_info + } - } else { + # + # DB and Oracle interface method generation (no autonull): + # + + ::xo::db::DB-oracle instproc get_all_package_functions {} { # - # Oracle + # Get all package functions (package name, object name) from Oracle + # system catalogs. # + return [::xo::dc list_of_lists [self proc] { + select distinct package_name, object_name + from user_arguments args + where args.position > 0 and package_name is not null + }] + } - ::xo::db::Class proc get_all_package_functions {} { - # - # Get all package functions (package name, object name) from Oracle - # system catalogs. - # - return [::xo::db_list_of_lists [self proc] { - select distinct package_name, object_name - from user_arguments args - where args.position > 0 and package_name is not null - }] - } + ::xo::db::DB-oracle instproc get_function_args {package_name object_name} { + # + # In Oracle, args.default_value appears to be defunct and useless. + # for now, we simply return a constant "unknown", otherwise the + # argument would be required + return [::xo::dc list_of_lists get_function_params { + select args.argument_name, 'NULL' + from user_arguments args + where args.position > 0 + and args.object_name = upper(:object_name) + and args.package_name = upper(:package_name) + order by args.position + }] + } - ::xo::db::Class instproc get_function_args {package_name object_name} { - # In Oracle, args.default_value appears to be defunct and useless. - # for now, we simply return a constant "unknown", otherwise the - # argument would be required - return [::xo::db_list_of_lists get_function_params { - select args.argument_name, 'NULL' - from user_arguments args - where args.position > 0 - and args.object_name = upper(:object_name) - and args.package_name = upper(:package_name) - order by args.position - }] - } + ::xo::db::DB-oracle instproc generate_psql {package_name object_name} { + # + # in Oracle, we have to distinguish between functions and procs + # + set is_function [::xo::dc 0or1row is_function { + select 1 from dual + where exists (select 1 from user_arguments where + package_name = upper(:package_name) + and object_name = upper(:object_name) + and position = 0) + }] - ::xo::db::Class instproc generate_psql {package_name object_name} { - # - # in Oracle, we have to distinguish between functions and procs - # - set is_function [::xo::db_0or1row is_function { - select 1 from dual - where exists (select 1 from user_arguments where - package_name = upper(:package_name) - and object_name = upper(:object_name) - and position = 0) - }] + set function_args [my get_function_args $package_name $object_name] + set function_args [my fix_function_args $function_args $package_name $object_name] + set sql_info [my sql_info $function_args $package_name $object_name] - set function_args [my get_function_args $package_name $object_name] - set function_args [my fix_function_args $function_args $package_name $object_name] - set psql_args [my sql-arguments $function_args $package_name $object_name] - - if {$is_function} { - my set sql [subst {BEGIN :1 := ${package_name}.${object_name}(\$sql_args); END;}] - return {ns_ora exec_plsql_bind $db $sql 1 ""} - } else { - my set sql [subst {BEGIN ${package_name}.${object_name}(\$sql_args); END;}] - #return {ns_set value [ns_ora select $db $sql] 0} - return {ns_ora dml $db $sql} - } + if {$is_function} { + set sql [subst {BEGIN :1 := ${package_name}.${object_name}(\$sql_args); END;}] + set sql_cmd {ns_ora exec_plsql_bind $db $sql 1 ""} + } else { + set sql [subst {BEGIN ${package_name}.${object_name}(\$sql_args); END;}] + set sql_cmd {ns_ora dml $db $sql} } - ::xo::db::Class instproc generate_proc_body {} { - return { - #function_args: [my set function_args] - set sql_args \[list\] - foreach var \[list [my set arg_order]\] { - set varname \[string tolower $var\] - if {\[info exists $varname\]} { - lappend sql_args "$varname => :$varname" - } - } - set sql_args \[join $sql_args ,\] - set sql "[my set sql]" - db_with_handle -dbn $dbn db { - #my log "sql=$sql, sql_command=[set sql_command]" - return \[ [set sql_command] \] - } + dict set sql_info body return [subst { + #function_args: $function_args + set sql_args \[list\] + foreach var \[list [dict get $sql_info arg_order]\] { + set varname \[string tolower \$var\] + if {\[info exists \$varname\]} { + lappend sql_args "\$varname => :\$varname" + } } - } - + set sql_args \[join \$sql_args ,\] + set sql "$sql" + db_with_handle -dbn \$dbn db { + #my log "sql=$sql, sql_command=$sql_cmd" + return \[ $sql_cmd \] + } + }] + return $sql_info } # Some stored procedures like content_item__new do currently not @@ -918,7 +1236,7 @@ # is to define the correct default values in the database with # define_function_args() - ::xo::db::Class array set fallback_defaults { + ::xo::db::SQL array set fallback_defaults { "content_item__new" { RELATION_TAG null DESCRIPTION null TEXT null CREATION_IP null NLS_LANGUAGE null LOCALE null CONTEXT_ID null @@ -946,18 +1264,18 @@ } } - ::xo::db::Class instproc fix_function_args {function_args package_name object_name} { + ::xo::db::SQL instproc fix_function_args {function_args package_name object_name} { # # Load fallback defaults for buggy function args. The values # provided here are only used for function args without specified # defaults. This is a transitional solution; actually, the # function args should be fixed. # - if {![[self class] exists fallback_defaults(${package_name}__$object_name)]} { + + if {![::xo::db::SQL exists fallback_defaults(${package_name}__$object_name)]} { return $function_args } - - array set additional_defaults [[self class] set fallback_defaults(${package_name}__$object_name)] + array set additional_defaults [::xo::db::SQL set fallback_defaults(${package_name}__$object_name)] set result [list] foreach arg $function_args { lassign $arg arg_name default_value @@ -970,21 +1288,26 @@ return $result } - ::xo::db::Class instproc sql-arguments {function_args package_name object_name} { - my array unset defined + + + + ::xo::db::SQL instproc sql_arg_info {function_args package_name object_name} { + set defined {} set psql_args [list] - my set arg_order [list] - my set function_args $function_args + set arg_order [list] foreach arg $function_args { lassign $arg arg_name default_value lappend psql_args \$_$arg_name - my lappend arg_order $arg_name - my set defined($arg_name) $default_value + lappend arg_order $arg_name + lappend defined $arg_name $default_value } - return [join $psql_args ", "] + return [list \ + psql_args [join $psql_args ", "] \ + arg_order $arg_order \ + defined $defined \ + function_args $function_args] } - ::xo::db::Class instproc dbproc_nonposargs {object_name} { # # This method compiles a stored procedure into a xotcl method @@ -1002,12 +1325,15 @@ # Object names have the form of e.g. ::xo::db::apm_parameter. # Therefore, we use the namspace tail as sql_package_name. # - set package_name [my sql_package_name [namespace tail [self]]] - set sql_command [my generate_psql $package_name $object_name] - set proc_body [my generate_proc_body] + set package_name [my sql_package_name [namespace tail [self]]] + set sql_info [::xo::dc generate_psql $package_name $object_name] + + # puts "sql_command=$sql_command" + # puts "sql_info=$sql_info" + array set defined [dict get $sql_info defined] set nonposarg_list [list [list -dbn ""]] - foreach arg_name [my set arg_order] { + foreach arg_name [dict get $sql_info arg_order] { # special rule for DBN ... todo: proc has to handle this as well set nonposarg_name [expr {$arg_name eq "DBN" ? "DBN" : [string tolower $arg_name]}] # @@ -1016,7 +1342,7 @@ # - value different from NULL --> make it default # - otherwise: non-required argument # - set default_value [my set defined($arg_name)] + set default_value $defined($arg_name) if {$default_value eq ""} { set arg -$nonposarg_name:required } elseif {[string tolower $default_value] ne "null"} { @@ -1028,19 +1354,21 @@ } # When the new method is executed within a contains, -childof is # appended. we have to added it here to avoid complains. xotcl 2.0 - # should find better ways to handle contain or the news invocation. + # should find better ways to handle contain or the new invocation. if {$object_name eq "new"} {lappend nonposarg_list -childof} #my log "-- define $object_name $nonposarg_list" - my ad_proc $object_name $nonposarg_list {Automatically generated method} [subst -novariables $proc_body] + #ns_log notice final=[dict get $sql_info body] + my ad_proc $object_name $nonposarg_list {Automatically generated method} [dict get $sql_info body] } ::xo::db::Class instproc unknown {m args} { error "Error: unknown database method '$m' for [self]" } - + ::xo::db::Class proc create_all_functions {} { - foreach item [my get_all_package_functions] { + + foreach item [::xo::dc get_all_package_functions] { lassign $item package_name object_name set class_name ::xo::db::sql::[string tolower $package_name] if {![my isobject $class_name]} { ::xo::db::Class create $class_name } @@ -1105,7 +1433,7 @@ } ::xo::db::Class instproc init_type_hierarchy {} { my instvar object_type - my set object_type_key [::xo::db_list get_tree_sortkey { + my set object_type_key [::xo::dc list get_tree_sortkey { select tree_sortkey from acs_object_types where object_type = :object_type }] @@ -1137,7 +1465,7 @@ @return list of object_types } { - return [::xo::db_list get_object_types \ + return [::xo::dc list get_object_types \ [my object_types_query -subtypes_first $subtypes_first]] } @@ -1248,10 +1576,10 @@ } if {[llength $updates] == 0} return my instproc save {} [subst { - db_transaction { + ::xo::dc transaction { next my instvar object_id $vars - db_dml dbqd..update_[my table_name] {update [my table_name] + ::xo::dc dml update_[my table_name] {update [my table_name] set [join $updates ,] where [my id_column] = :object_id } } @@ -1274,7 +1602,7 @@ lappend __atts [$__slot column_name] } } - db_dml dbqd..insert_$__table_name "insert into $__table_name + ::xo::dc dml insert_$__table_name "insert into $__table_name ([join $__atts ,]) values (:[join $__vars ,:])" } } @@ -1433,7 +1761,7 @@ @return fully qualified object } { my get_context package_id creation_user creation_ip - db_transaction { + ::xo::dc transaction { set id [my new_acs_object \ -package_id $package_id \ -creation_user $creation_user \ @@ -1483,12 +1811,12 @@ @named_objects If this flag is true, the value of the id_column is used for the name of the created objects (object will be named - e.g. ::13738). Otherwise, objects are created with the XOTcl "new" + e.g. ::13738). Otherwise, objects are created with the XOTcl "new" method to avoid object name clashes. @destroy_on_cleanup If this flag is true, the objects (and ordered - composite) will be automatically destroyed on cleaup (typically - after the request was processed). + composite) will be automatically destroyed on cleaup (typically + after the request was processed). @initialize can be used to avoid full initialization, when a large series of of objects is loaded. Per default, these objects @@ -1510,51 +1838,47 @@ } } - db_with_handle -dbn $dbn db { - set selection [db_exec select $db $full_statement_name $sql] - while {1} { - set continue [ns_db getrow $db $selection] - if {!$continue} break - if {$named_objects} { - set object_name ::[ns_set get $selection $object_named_after] - set o [$object_class create $object_name] - } else { - set o [$object_class new] - } - if {$as_ordered_composite} { - $__result add $o - } else { - if {$destroy_on_cleanup} { - $o destroy_on_cleanup - } - lappend __result $o - } - foreach {att val} [ns_set array $selection] {$o set $att $val} - if {[$o exists object_type]} { - # set the object type if it looks like managed from XOTcl - if {[string match "::*" [set ot [$o set object_type]] ]} { - $o class $ot - } - } - if {$initialize && [$o istype ::xo::db::Object]} { - if {![$o exists package_id]} { - if {[$o exists object_package_id]} { - $o set package_id [$o set object_package_id] - } else { - ns_log warning "[namespace tail [$o info class]] $o has no package_id and no object_package_id" - } - } - if {[catch {$o initialize_loaded_object} errorMsg]} { - ns_log error "$o initialize_loaded_object => [$o info vars] -> $errorMsg" + set sets [uplevel [list ::xo::dc sets -dbn $dbn [self proc] $sql]] + foreach selection $sets { + if {$named_objects} { + set object_name ::[ns_set get $selection $object_named_after] + set o [$object_class create $object_name] + } else { + set o [$object_class new] + } + if {$as_ordered_composite} { + $__result add $o + } else { + if {$destroy_on_cleanup} { + $o destroy_on_cleanup + } + lappend __result $o + } + foreach {att val} [ns_set array $selection] {$o set $att $val} + if {[$o exists object_type]} { + # set the object type if it looks like managed from XOTcl + if {[string match "::*" [set ot [$o set object_type]] ]} { + $o class $ot + } + } + if {$initialize && [$o istype ::xo::db::Object]} { + if {![$o exists package_id]} { + if {[$o exists object_package_id]} { + $o set package_id [$o set object_package_id] + } else { + ns_log warning "[namespace tail [$o info class]] $o has no package_id and no object_package_id" } - } - #my log "--DB more = $continue [$o serialize]" + } + if {[catch {$o initialize_loaded_object} errorMsg]} { + ns_log error "$o initialize_loaded_object => [$o info vars] -> $errorMsg" + } } + #my log "--DB more = $continue [$o serialize]" } return $__result } - + ::xo::db::Class instproc fetch_query {id} { set tables [list] set attributes [list] @@ -1595,7 +1919,7 @@ Returns the SQL-query to select ACS Objects of the object_type of the class. @select_attributes attributes for the SQL query to be retrieved. - if no attributes are specified, all attributes are retrieved. + if no attributes are specified, all attributes are retrieved. @param orderby for ordering the solution set @param where_clause clause for restricting the answer set @param count return the query for counting the solutions @@ -1643,7 +1967,7 @@ set offset "" } - set sql [::xo::db::sql select \ + set sql [::xo::dc select \ -vars [join $select_attributes ,] \ -from "[join $tables ,] $from_clause" \ -where [string trim "[join $join_expressions { and }] $where_clause"] \ @@ -1704,7 +2028,7 @@ set package_id [my package_id] } [my info class] get_context package_id modifying_user modifying_ip - db_dml dbqd..update_object {update acs_objects + ::xo::dc dml update_object {update acs_objects set modifying_user = :modifying_user, modifying_ip = :modifying_ip where object_id = :object_id} } @@ -1721,7 +2045,7 @@ set package_id [my package_id] } [my info class] get_context package_id creation_user creation_ip - db_transaction { + ::xo::dc transaction { set id [[my info class] new_acs_object \ -package_id $package_id \ -creation_user $creation_user \ @@ -1742,18 +2066,6 @@ } - if {[db_driverkey ""] eq "postgresql"} { - ::xo::db::Object instproc db_1row {qn sql} { - set answers [uplevel [list ::xo::db::pg_0or1row $sql]] - if {$answers ne ""} { - foreach {att val} [ns_set array $answers] { my set $att $val } - ns_set free $answers - return 1 - } - error "query $sql did not return an answer" - } - } - ############## ::xotcl::MetaSlot create ::xo::db::Attribute \ -superclass {::xo::Attribute} \ @@ -1771,7 +2083,7 @@ my instvar datatype pretty_name min_n_values max_n_values domain column_name set object_type [$domain object_type] - if {[::xo::db_string check_att {select 0 from acs_attributes where + if {[::xo::dc get_value check_att {select 0 from acs_attributes where attribute_name = :column_name and object_type = :object_type} 1]} { if {![::xo::db::Class object_type_exists_in_db -object_type $object_type]} { @@ -1801,7 +2113,7 @@ ::xo::db::Attribute instproc column_spec {{-id_column false}} { my instvar sqltype name references default set column_spec "" - append column_spec " " [::xo::db::sql map_datatype $sqltype] + append column_spec " " [::xo::dc map_datatype $sqltype] if {[info exists default]} {append column_spec " DEFAULT '$default'" } # # References @@ -1820,10 +2132,10 @@ set table_name [[my domain] table_name] if {$id_column} { # add automatically a constraint for the id_column - set cname [::xo::db::mk_sql_constraint_name $table_name $name pk] + set cname [::xo::dc mk_sql_constraint_name $table_name $name pk] append column_spec "\n\tCONSTRAINT $cname PRIMARY KEY" } - append column_spec " " [::xo::db::sql datatype_constraint $sqltype $table_name $name] + append column_spec " " [::xo::dc datatype_constraint $sqltype $table_name $name] return $column_spec } @@ -1853,7 +2165,7 @@ } #my log "check attribute $column_name ot=$object_type, domain=$domain" - if {[::xo::db_string check_att {select 0 from acs_attributes where + if {[::xo::dc get_value check_att {select 0 from acs_attributes where attribute_name = :column_name and object_type = :object_type} 1]} { if {![::xo::db::Class object_type_exists_in_db -object_type $object_type]} { @@ -1896,16 +2208,16 @@ # When the table exists already, simply insert into it ... if {[::xo::db::require exists_table [my name]]} { - db_dml . "insert into [my name] ([my vars]) ([my query])" + ::xo::dc dml . "insert into [my name] ([my vars]) ([my query])" } else { # ... otherwise, create the table with the data in one step - db_dml [my qn get_n_most_recent_contributions] $sql_create[my query] + ::xo::dc dml get_n_most_recent_contributions $sql_create[my query] } } ::xo::db::temp_table instproc destroy {} { # A session spans multiple connections in OpenACS. # We want to get rid the data when we are done. - db_dml [my qn truncate_temp_table] "truncate table [my name]" + ::xo::dc dml truncate_temp_table "truncate table [my name]" next } @@ -1928,3 +2240,9 @@ } +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl,v diff -u -r1.29 -r1.29.6.1 --- openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 11 Aug 2011 13:04:24 -0000 1.29 +++ openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 11 Feb 2014 11:53:08 -0000 1.29.6.1 @@ -22,7 +22,7 @@ } { my instvar package_key if {[info exists privilege]} { - set sql [::xo::db::sql select -vars package_id \ + set sql [::xo::dc select -vars package_id \ -from "apm_packages, acs_object_party_privilege_map ppm, site_nodes s" \ -where { package_key = :package_key @@ -31,7 +31,7 @@ and ppm.party_id = :party_id and ppm.privilege = :privilege } -limit 1] - db_string [my qn get_package_id] $sql + ::xo::dc get_value get_package_id $sql } else { ::xo::parameter get_package_id_from_package_key -package_key $package_key } @@ -44,10 +44,10 @@ } { my instvar package_key if {$include_unmounted} { - set result [db_list [my qn get_xowiki_packages] {select package_id \ + set result [::xo::dc list get_xowiki_packages {select package_id \ from apm_packages where package_key = :package_key}] } else { - set result [db_list [my qn get_mounted_packages] {select package_id \ + set result [::xo::dc list get_mounted_packages {select package_id \ from apm_packages p, site_nodes s \ where package_key = :package_key and s.object_id = p.package_id}] } @@ -248,7 +248,7 @@ my package_key $info(package_key) my instance_name $info(instance_name) } else { - db_1row [my qn package_info] { + ::xo::dc 1row package_info { select package_key, instance_name from apm_packages where package_id = :id } my package_key $package_key @@ -377,4 +377,11 @@ #ns_log notice [::xo::Package serialize] -} \ No newline at end of file +} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl,v diff -u -r1.15.6.1 -r1.15.6.2 --- openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 30 Sep 2013 11:38:40 -0000 1.15.6.1 +++ openacs-4/packages/xotcl-core/tcl/06-param-procs.tcl 11 Feb 2014 11:53:08 -0000 1.15.6.2 @@ -163,16 +163,16 @@ -package_id:required } { return [ns_cache eval xotcl_object_type_cache package_key-$package_id { - db_string [my qn get_package_key] \ - "select package_key from apm_packages where package_id = $package_id" + ::xo::dc get_value get_package_key \ + "select package_key from apm_packages where package_id = :package_id" }] } parameter proc get_package_id_from_package_key { -package_key:required } { return [ns_cache eval xotcl_object_type_cache package_id-$package_key { - db_string [my qn get_package_id] \ - [::xo::db::sql select -vars package_id -from apm_packages \ + ::xo::dc get_value get_package_id \ + [::xo::dc select -vars package_id -from apm_packages \ -where "package_key = :package_key" -limit 1] }] } @@ -363,7 +363,7 @@ parameter proc initialize_parameters {} { # Get those parameter values, which are different from the default and # remember theses per package_id. - db_foreach [my qn get_non_default_values] { + xo::dc foreach get_non_default_values { select p.parameter_id, p.package_key, v.package_id, p.parameter_name, p.default_value, v.attr_value from apm_parameters p, apm_parameter_values v @@ -455,4 +455,11 @@ # $p save # $p delete -} \ No newline at end of file +} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/chat-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/chat-procs.tcl,v diff -u -r1.20.2.2 -r1.20.2.3 --- openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 30 Sep 2013 11:38:40 -0000 1.20.2.2 +++ openacs-4/packages/xotcl-core/tcl/chat-procs.tcl 11 Feb 2014 11:53:08 -0000 1.20.2.3 @@ -80,7 +80,7 @@ } Chat instproc nr_active_users {} { - expr { [llength [nsv_array get [my set array]-login]] / 2 } + expr { [llength [nsv_array get [my set array]-login]] / 2 } } Chat instproc last_activity {} { @@ -118,7 +118,7 @@ } my render } - + Chat instproc get_all {} { my instvar array now session_id foreach {key value} [nsv_array get $array] { @@ -185,7 +185,7 @@ set userlink [my user_link -user_id $user_id] append output "$userlink$diff\n" } - } + } return $output } @@ -303,8 +303,6 @@ return $result } - - ############################################################################ # Chat meta class, since we need to define general class-specific methods ############################################################################ @@ -322,11 +320,12 @@ ChatClass method initialize_nsvs {} { # read the last_activity information at server start into a nsv array - db_foreach [my qn get_rooms] { + ::xo::dc foreach get_rooms { select room_id, to_char(max(creation_date),'HH24:MI:SS YYYY-MM-DD') as last_activity - from chat_msgs group by room_id} { - ::xo::clusterwide nsv_set [self]-$room_id-seen last [clock scan $last_activity] - } + from chat_msgs group by room_id + } { + ::xo::clusterwide nsv_set [self]-$room_id-seen last [clock scan $last_activity] + } } ChatClass method flush_messages {-chat_id:required} { @@ -343,3 +342,9 @@ } } +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v diff -u -r1.63.2.2 -r1.63.2.3 --- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 30 Sep 2013 11:38:40 -0000 1.63.2.2 +++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 11 Feb 2014 11:53:08 -0000 1.63.2.3 @@ -226,6 +226,10 @@ return } + if {[info exists ::ds_show_p] && [ds_database_enabled_p]} { + ::xo::dc profile on + } + if {![info exists url]} { #my log "--CONN ns_conn url" set url [ns_conn url] @@ -561,4 +565,11 @@ return $query } -} \ No newline at end of file +} + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/cr-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/cr-procs.tcl,v diff -u -r1.50.2.5 -r1.50.2.6 --- openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 21 Oct 2013 06:17:01 -0000 1.50.2.5 +++ openacs-4/packages/xotcl-core/tcl/cr-procs.tcl 11 Feb 2014 11:53:08 -0000 1.50.2.6 @@ -58,11 +58,11 @@ set object_type [ns_cache eval xotcl_object_type_cache \ [expr {$item_id ? $item_id : $revision_id}] { if {$item_id} { - ::xo::db_1row get_class_from_item_id \ - "select content_type as object_type from cr_items where item_id=$item_id" + ::xo::dc 1row get_class_from_item_id \ + "select content_type as object_type from cr_items where item_id=:item_id" } else { - ::xo::db_1row get_class_from_revision_id \ - "select object_type from acs_objects where object_id=$revision_id" + ::xo::dc 1row get_class_from_revision_id \ + "select object_type from acs_objects where object_id=:revision_id" } return $object_type }] @@ -94,7 +94,7 @@ } { # TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki #if {[my isobject ::$item_id]} {return [::$item_id parent_id]} - ::xo::db_1row get_parent "select parent_id from cr_items where item_id = :item_id" + ::xo::dc 1row get_parent "select parent_id from cr_items where item_id = :item_id" return $parent_id } @@ -109,7 +109,7 @@ } { # TODO: the following line is deactivated, until we get rid of the "folder object" in xowiki #if {[my isobject ::$item_id]} {return [::$item_id parent_id]} - ::xo::db_1row get_name "select name from cr_items where item_id = :item_id" + ::xo::dc 1row get_name "select name from cr_items where item_id = :item_id" return $name } @@ -123,7 +123,7 @@ @return list of item_ids } { set items [list] - foreach item_id [::xo::db_list get_child_items \ + foreach item_id [::xo::dc list get_child_items \ "select item_id from cr_items where parent_id = :item_id"] { lappend items $item_id {*}[my [self proc] -item_id $item_id] } @@ -139,7 +139,7 @@ @return item_id } { - return [::xo::db_string entry_exists_select { + return [::xo::dc get_value entry_exists_select { select item_id from cr_items where name = :name and parent_id = :parent_id } 0] } @@ -168,7 +168,7 @@ # # PostgreSQL # - set pg_version [::xo::db_string get_version { + set pg_version [::xo::dc get_value get_version { select substring(version() from 'PostgreSQL #"[0-9]+.[0-9+]#".%' for '#') }] ns_log notice "--Postgres Version $pg_version" if {$pg_version < 8.2} { @@ -177,7 +177,7 @@ # We define a locking function, really locking the tables... # CrClass instproc lock {tablename mode} { - db_dml [my qn lock_objects] "LOCK TABLE $tablename IN $mode MODE" + ::xo::dc lock_objects "LOCK TABLE $tablename IN $mode MODE" } } else { # No locking needed for newer versions of PostgreSQL @@ -242,7 +242,7 @@ operation should be applied on subtypes as well } { my instvar object_type - db_foreach [my qn all_folders] { + xo::dc foreach all_folders { select folder_id from cr_folder_type_map where content_type = :object_type } { @@ -293,7 +293,7 @@ } if {![info exists pretty_plural]} {set pretty_plural $pretty_name} - db_transaction { + ::xo::dc transaction { ::xo::db::sql::content_type create_type \ -content_type $object_type \ -supertype $supertype \ @@ -315,7 +315,7 @@ undoes everying what create_object_type has produced. } { my instvar object_type table_name - db_transaction { + ::xo::dc transaction { my folder_type unregister ::xo::db::sql::content_type drop_type \ -content_type $object_type \ @@ -450,31 +450,33 @@ } } if {$revision_id} { + $object set revision_id $revision_id $object db_1row [my qn fetch_from_view_revision_id] "\ select [join $atts ,], i.parent_id \ from [my set table_name]i n, cr_items i,acs_objects o \ - where n.revision_id = $revision_id \ + where n.revision_id = :revision_id \ and i.item_id = n.item_id \ - and o.object_id = $revision_id" + and o.object_id = n.revision_id" } else { # We fetch the creation_user and the modifying_user by returning the # creation_user of the automatic view as modifying_user. In case of # troubles, comment next line out. lappend atts "n.creation_user as modifying_user" + $object set item_id $item_id $object db_1row [my qn fetch_from_view_item_id] "\ select [join $atts ,], i.parent_id \ from [my set table_name]i n, cr_items i, acs_objects o \ - where i.item_id = $item_id \ + where i.item_id = :item_id \ and n.[my id_column] = coalesce(i.live_revision, i.latest_revision) \ and o.object_id = i.item_id" } - # db_1row treats all newly created variables as instance variables, + # the method db_1row treats all newly created variables as instance variables, # so we can see vars like __db_sql, __db_lst that we do not want to keep foreach v [$object info vars __db_*] {$object unset $v} if {[apm_version_names_compare [ad_acs_version] 5.2] <= -1} { - $object set package_id [::xo::db_string get_pid \ + $object set package_id [::xo::dc get_value get_pid \ "select package_id from cr_folders where folder_id = [$object set parent_id]"] } @@ -619,7 +621,7 @@ set offset "" } - set sql [::xo::db::sql select \ + set sql [::xo::dc select \ -vars $attribute_selection \ -from "$acs_objects_table cr_items ci, $base_table bt $from_clause" \ -where [join $cond " and "] \ @@ -716,16 +718,6 @@ # # PostgreSQL # - # Provide the appropriate db_* call for the view update. Earlier - # versions up to 5.3.0d1 used db_dml, newer versions (since around - # july 2006) have to use db_0or1row, when the patch for deadlocks - # and duplicate items is applied... - - apm_version_get -package_key acs-content-repository -array info - array get info - CrItem set insert_view_operation \ - [expr {[apm_version_names_compare $info(version_name) 5.3.0d1] < 1 ? "db_dml" : "db_0or1row"}] - array unset info # # INSERT statements differ between PostgreSQL and Oracle @@ -745,9 +737,9 @@ # my msg "$slot_name [$cls table_name] [$cls id_column] length=[string length $content]" #} if {$storage_type eq "file"} { - db_dml [my qn fix_content_length] "update cr_revisions \ + ::xo::dc dml fix_content_length "update cr_revisions \ set content_length = [file size [my set import_file]] \ - where revision_id = $revision_id" + where revision_id = :revision_id" } } @@ -761,9 +753,9 @@ if {$storage_type eq "file"} { my log "--update_content not implemented for type file" } else { - db_dml [my qn update_content] "update cr_revisions \ + ::xo::dc dml update_content "update cr_revisions \ set content = :content \ - where revision_id = $revision_id" + where revision_id = :revision_id" } } @@ -773,13 +765,12 @@ set sql "update [$domain table_name] \ set [$slot column_name] = :value \ where [$domain id_column] = $revision_id" - db_dml [my qn update_attribute_from_slot] $sql + ::xo::dc dml update_attribute_from_slot $sql } } else { # # Oracle # - CrItem set insert_view_operation db_dml CrClass instproc insert_statement {atts vars} { # @@ -808,13 +799,13 @@ CrItem instproc fix_content {{-only_text false} revision_id content} { [my info class] instvar storage_type if {$storage_type eq "file"} { - db_dml [my qn fix_content_length] "update cr_revisions \ + ::xo::dc dml fix_content_length "update cr_revisions \ set content_length = [file size [my set import_file]] \ - where revision_id = $revision_id" + where revision_id = :revision_id" } elseif {$storage_type eq "text"} { - db_dml [my qn fix_content] "update cr_revisions \ + ::xo::dc dml fix_content "update cr_revisions \ set content = empty_blob(), content_length = [string length $content] \ - where revision_id = $revision_id \ + where revision_id = :revision_id \ returning content into :1" -blobs [list $content] } if {!$only_text} { @@ -843,35 +834,28 @@ set domain [$slot domain] set att [$slot column_name] if {[$slot sqltype] eq "long_text"} { - db_dml [my qn att-$att] "update [$domain table_name] \ + ::xo::dc dml att-$att "update [$domain table_name] \ set $att = empty_clob() \ - where [$domain id_column] = $revision_id \ + where [$domain id_column] = :revision_id \ returning $att into :1" -clobs [list $value] } else { set sql "update [$domain table_name] \ set $att = :value \ where [$domain id_column] = $revision_id" - db_dml [my qn update_attribute-$att] $sql + ::xo::dc dml $att $sql } } } - # - # Uncomment the following line, if you want to force db_0or1row for - # update operations (e.g. when using the provided patch for the - # content repository in a 5.2 installation) - # - # CrItem set insert_view_operation db_0or1row - CrItem instproc update_revision {{-quoted false} revision_id attribute value} { # # This method can be use to update arbitrary fields of # an revision. # if {$quoted} {set val $value} {set val :value} - db_dml [my qn update_content] "update cr_revisions \ - set $attribute = $val \ - where revision_id = $revision_id" + ::xo::dc dml update_content "update cr_revisions \ + set $attribute = :val \ + where revision_id = :revision_id" } CrItem instproc current_user_id {} { @@ -919,18 +903,18 @@ lappend __vars $__slot_name } - [self class] instvar insert_view_operation - db_transaction { + ::xo::dc transaction { [my info class] instvar storage_type - set revision_id [db_nextval acs_object_id_seq] + set revision_id [xo::dc nextval acs_object_id_seq] if {$storage_type eq "file"} { my instvar import_file set text [cr_create_content_file $item_id $revision_id $import_file] } - $insert_view_operation [my qn revision_add] \ + ::xo::dc [::xo::dc insert-view-operation] revision_add \ [[my info class] insert_statement $__atts $__vars] my fix_content $revision_id $text + if {$live_p} { ::xo::db::sql::content_item set_live_revision \ -revision_id $revision_id \ @@ -950,10 +934,8 @@ #set revision_id $old_revision_id } my set modifying_user $creation_user - my db_1row [my qn get_dates] { - select last_modified - from acs_objects where object_id = :revision_id - } + my set last_modified [::xo::dc get_value get_last_modified \ + {select last_modified from acs_objects where object_id = :revision_id}] } return $item_id } @@ -988,7 +970,6 @@ ::xo::clusterwide ns_cache flush xotcl_object_cache ::[my item_id] } - CrItem ad_instproc save_new { -package_id -creation_user @@ -1025,12 +1006,10 @@ lappend __vars $__slot_name } - [self class] instvar insert_view_operation - - db_transaction { + ::xo::dc transaction { $__class instvar storage_type object_type [self class] lock acs_objects "SHARE ROW EXCLUSIVE" - set revision_id [db_nextval acs_object_id_seq] + set revision_id [xo::dc nextval acs_object_id_seq] if {![my exists name] || $name eq ""} { # we have an autonamed item, use a unique value for the name @@ -1048,7 +1027,7 @@ set text [cr_create_content_file $item_id $revision_id $import_file] } - $insert_view_operation [my qn revision_add] \ + ::xo::dc [::xo::dc insert-view-operation] revision_add \ [[my info class] insert_statement $__atts $__vars] my fix_content $revision_id $text @@ -1062,6 +1041,7 @@ } } my set revision_id $revision_id + my db_1row [my qn get_dates] { select creation_date, last_modified from acs_objects where object_id = :revision_id @@ -1081,8 +1061,9 @@ CrItem ad_instproc rename {-old_name:required -new_name:required} { Rename a content item } { - db_dml [my qn update_rename] "update cr_items set name = :new_name \ - where item_id = [my item_id]" + my instvar item_id + ::xo::dc dml update_rename \ + "update cr_items set name = :new_name where item_id = :item_id" } CrItem instproc revisions {} { @@ -1112,7 +1093,7 @@ set live_revision_id [::xo::db::sql::content_item get_live_revision -item_id $page_id] my instvar package_id set base [$package_id url] - set sql [::xo::db::sql select \ + set sql [::xo::dc select \ -map_function_names true \ -vars "ci.name, r.revision_id as version_id,\ person__name(o.creation_user) as author, \ @@ -1131,7 +1112,7 @@ and m.privilege = 'read')" \ -orderby "r.revision_id desc"] - db_foreach [my qn revisions_select] $sql { + ::xo::dc foreach revisions_select $sql { if {$content_length < 1024} { if {$content_length eq ""} {set content_length 0} set content_size_pretty "[lc_numeric $content_length] [_ file-storage.bytes]" @@ -1359,7 +1340,7 @@ set offset "" } - set sql [::xo::db::sql select \ + set sql [::xo::dc select \ -vars $attribute_selection \ -from "$acs_objects_table cr_folders cf $from_clause" \ -where [join $cond " and "] \ @@ -1472,7 +1453,7 @@ [list description [my set description]]\ ] my get_context package_id user_id ip - ::xo::db_1row _ "select acs_object__update_last_modified(:folder_id,$user,'$ip')" + ::xo::dc 1row _ "select acs_object__update_last_modified(:folder_id,$user,'$ip')" } ::xo::db::CrFolder instproc is_package_root_folder {} { @@ -1661,4 +1642,9 @@ #::xo::library source_dependent - +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/generic-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/generic-procs.tcl,v diff -u -r1.94.6.1 -r1.94.6.2 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 13 Oct 2013 18:15:14 -0000 1.94.6.1 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 11 Feb 2014 11:53:09 -0000 1.94.6.2 @@ -95,7 +95,7 @@ $data set $__var [my var $__var] } $data initialize_loaded_object - db_transaction { + xo::dc transaction { $data save set old_name [::xo::cc form_parameter __object_name ""] set new_name [$data set name] @@ -211,16 +211,8 @@ append new_data { category::map_object -remove_old -object_id $item_id $category_ids - #ns_log notice "-- new data category::map_object -remove_old -object_id $item_id $category_ids" - #db_dml [my qn insert_asc_named_object] \ - # "insert into acs_named_objects (object_id,object_name,package_id) \ - # values (:item_id, :name, :package_id)" } append edit_data { - #db_dml [my qn update_asc_named_object] \ - # "update acs_named_objects set object_name = :name, \ - # package_id = :package_id where object_id = :item_id" - #ns_log notice "-- edit data category::map_object -remove_old -object_id $item_id $category_ids" category::map_object -remove_old -object_id $item_id $category_ids } append on_submit { @@ -239,6 +231,12 @@ } } namespace import -force ::Generic::* +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: Index: openacs-4/packages/xotcl-core/tcl/policy-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/policy-procs.tcl,v diff -u -r1.22.2.1 -r1.22.2.2 --- openacs-4/packages/xotcl-core/tcl/policy-procs.tcl 17 Sep 2013 17:49:24 -0000 1.22.2.1 +++ openacs-4/packages/xotcl-core/tcl/policy-procs.tcl 11 Feb 2014 11:53:09 -0000 1.22.2.2 @@ -96,6 +96,7 @@ } Policy instproc get_permission {{-check_classes true} object method} { + # ns_log notice "[self] [self proc] [self args] // object=$object" set permission "" set o [self]::[namespace tail $object] set key require_permission($method) @@ -105,6 +106,7 @@ set permission [$o set default_permission] } elseif {$check_classes} { # we have no object specific policy information, check the classes + #ns_log notice "---check [list $object info class]" set c [$object info class] foreach class [concat $c [$c info heritage]] { set c [self]::[namespace tail $class] @@ -214,4 +216,4 @@ return $allowed } -} \ No newline at end of file +}