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.2 -r1.2.2.1 --- openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 29 Dec 2006 16:58:10 -0000 1.2 +++ openacs-4/packages/xotcl-core/tcl/05-db-procs.tcl 15 Jan 2007 08:49:58 -0000 1.2.2.1 @@ -39,7 +39,7 @@ proc has_ltree {} { ns_cache eval xotcl_object_cache ::xo::has_ltree { - if {[catch {db_1row check_ltree "select * from pg_proc where proname = 'ltree_in'"}]} { + if {[db_string check_ltree "select count(*) from pg_proc where proname = 'ltree_in'"] == 0} { return 0 } return 1 Index: openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl,v diff -u -r1.7 -r1.7.2.1 --- openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 12 Dec 2006 09:32:15 -0000 1.7 +++ openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 15 Jan 2007 08:49:58 -0000 1.7.2.1 @@ -63,7 +63,7 @@ #my log "--W destroying children [my set __children]" foreach c [my set __children] { $c destroy } } - #show_stack;my log "-- children murdered, now next, chlds=[my info children]" + #show_stack;my log "--W children murdered, now next, chlds=[my info children]" namespace eval [self] {namespace forget *} ;# for pre 1.4.0 versions next } @@ -94,4 +94,46 @@ Class OrderedComposite::Child -instproc __after_insert {} {;} -} \ No newline at end of file + Class OrderedComposite::IndexCompare + OrderedComposite::IndexCompare instproc __compare {a b} { + set by [my set __orderby] + set x [$a set $by] + set y [$b set $by] + #my log "--value compare $x $y] => [my __value_compare $x $y 0]" + return [my __value_compare $x $y 0] + } + OrderedComposite::IndexCompare instproc __value_compare {x y def} { + set xp [string first . $x] + set yp [string first . $y] + if {$xp == -1 && $yp == -1} { + if {$x < $y} { + return -1 + } elseif {$x > $y} { + return 1 + } else { + return $def + } + } elseif {$xp == -1} { + set yh [string range $y 0 [expr {$yp-1}]] + return [my __value_compare $x $yh -1] + } elseif {$yp == -1} { + set xh [string range $x 0 [expr {$xp-1}]] + return [my __value_compare $xh $y 1] + } else { + set xh [string range $x 0 $xp] + set yh [string range $y 0 $yp] + #puts "xh=$xh yh=$yh" + if {$xh < $yh} { + return -1 + } elseif {$xh > $yh} { + return 1 + } else { + incr xp + incr yp + #puts "rest [string range $x $xp end] [string range $y $yp end]" + return [my __value_compare [string range $x $xp end] [string range $y $yp end] $def] + } + } + } +} + 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.6 -r1.6.2.1 --- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 13 Oct 2006 07:06:40 -0000 1.6 +++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 15 Jan 2007 08:49:58 -0000 1.6.2.1 @@ -295,9 +295,18 @@ my exists form_parameter($name) } + ConnectionContext instproc set_parameter {name value} { + my set perconnectionparam($name) $value + } + ConnectionContext instproc get_parameter {name {default ""}} { + my instvar perconnectionparam + return [expr {[info exists perconnectionparam($name)] ? $perconnectionparam($name) : $default}] + } + ConnectionContext instproc exists_parameter {name} { + my exists perconnectionparam($name) + } - # # Meta-Class for Application Package Classes # 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.40 -r1.40.2.1 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 30 Dec 2006 12:03:46 -0000 1.40 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 15 Jan 2007 08:49:58 -0000 1.40.2.1 @@ -137,7 +137,8 @@ ) } if {[my cr_attributes] ne ""} { - set o [::xo::OrderedComposite new -volatile -contains [my cr_attributes]] + set o [::xo::OrderedComposite new -contains [my cr_attributes]] + $o destroy_on_cleanup foreach att [$o children] { $att instvar attribute_name datatype pretty_name sqltype db_1row create_att { @@ -258,7 +259,8 @@ my set superclass [[my info superclass] set object_type] } set sql_attribute_names [list] - set o [xo::OrderedComposite new -volatile -contains [my cr_attributes]] + set o [::xo::OrderedComposite new -contains [my cr_attributes]] + $o destroy_on_cleanup foreach att [$o children] { lappend sql_attribute_names [$att attribute_name] } @@ -483,10 +485,11 @@ {-sql ""} {-full_statement_name ""} } { - Return a set of instances of folder objects. If the ... + Return a set of instances of folder objects. + The container and contained objects are automatically + destroyed on cleanup of the connection thread } { - set __result [::xo::OrderedComposite new] - uplevel #1 [list $__result volatile] + set __result [::xo::OrderedComposite new -destroy_on_cleanup] #$__result proc destroy {} {my log "-- "; next} db_with_handle -dbn $dbn db { Index: openacs-4/packages/xotcl-core/www/cache.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/cache.adp,v diff -u -r1.1 -r1.1.2.1 --- openacs-4/packages/xotcl-core/www/cache.adp 17 Aug 2006 01:27:54 -0000 1.1 +++ openacs-4/packages/xotcl-core/www/cache.adp 15 Jan 2007 08:49:59 -0000 1.1.2.1 @@ -2,7 +2,6 @@ @title;noquote@ @context;noquote@ -

@title@

Memory Caches

Index: openacs-4/packages/xotcl-core/www/cache.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/cache.tcl,v diff -u -r1.1 -r1.1.2.1 --- openacs-4/packages/xotcl-core/www/cache.tcl 17 Aug 2006 01:27:54 -0000 1.1 +++ openacs-4/packages/xotcl-core/www/cache.tcl 15 Jan 2007 08:49:59 -0000 1.1.2.1 @@ -1,9 +1,10 @@ ad_page_contract { Cache Viewer } { - {cache:optional 0} - {item:optional 0} - {flush:optional 0} + {cache:optional 0} + {item:optional 0} + {flush:optional 0} + {flushall:optional 0} } -properties { title:onevalue context:onevalue @@ -23,10 +24,18 @@ set title "Show Caches" set context [list "Cache Statistics"] -if { $flush ne 0 } { +if { $flush ne "0" } { ns_cache flush $cache $flush ad_returnredirect "[ns_conn url]?cache=$cache" ad_script_abort +} + +if {$flushall == 1} { + foreach i [ns_cache names $cache] { + ns_cache flush $cache $i + } + ad_returnredirect "[ns_conn url]?cache=$cache" + ad_script_abort } if { $cache == 0 } { @@ -57,6 +66,8 @@ } else { set item_list [ns_cache names $cache] set item_count [llength $item_list] + append output "flush all items of $cache" + append output "

Items in cache $cache ($item_count) with size [ns_cache_size $cache]