- imported latest version

tcl/01-debug-procs.tcl

@@ -11,6 +11,7 @@ package require xotcl::serializer
   ::xotcl::Object instproc debug
   ::xotcl::Object instproc qn
   ::xotcl::Object instproc serialize
+  ::xotcl::Object instproc show-object
   ::xotcl::Object instforward db_1row
   ::xotcl::Object instproc destroy_on_cleanup
   ::xotcl::Object instproc set_instance_vars_defaults
@@ -32,7 +33,7 @@ if {$::xotcl::version < 1.5} {
   # XOTcl 1.5 or newer supports slots. Here we have to 
   # emulate slots up to a certain point
   namespace eval ::xo {
-    Class create ::xo::Attribute \
+    ::xotcl::MetaSlot create ::xo::Attribute \
       -parameter {
         {name "[namespace tail [::xotcl::self]]"}
         {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"}
@@ -52,7 +53,7 @@ if {$::xotcl::version < 1.5} {
 } else {
   namespace eval ::xo {
     # create xo::Attribute as a subclass of the slot ::xotcl::Attribute
-    Class create ::xo::Attribute \
+    ::xotcl::MetaSlot create ::xo::Attribute \
         -superclass ::xotcl::Attribute \
         -parameter {
           spec
@@ -81,12 +82,15 @@ if {[info command ::nx::Object] ne ""} {
   ::nx::Slot public method exists {var}   {::nsf::existsvar [self] $var}
   ::nx::Object public method serialize {} {::Serializer deepSerialize [self]}
   ::nx::Object method set_instance_vars_defaults {} {:configure}
+  ::nx::Object public method destroy_on_cleanup {} {set ::xo::cleanup([self]) [list [self] destroy]}
   ::xotcl::Object instproc set_instance_vars_defaults {} {:configure}
   ::xotcl::Object proc setExitHandler {code} {::nsf::exithandler set $code}
 
   ::Serializer exportMethods {
     ::nx::Object method serialize
+    ::nx::Object method show-object
     ::nx::Object method set_instance_vars_defaults
+    ::nx::Object method destroy_on_cleanup
     ::nx::Slot method istype
     ::nx::Slot method exists
     ::nx::Slot method set
@@ -129,6 +133,19 @@ namespace eval ::xo {
   ::Serializer deepSerialize [self]
 }
 
+::xotcl::Object instproc show-object {} {
+  #
+  # Allow to show an arbitrary object via API-browser.  Per-default,
+  # e.g. site-wide can use e.g. /xowiki/index?m=show-object
+  #
+  set form [rp_getform]
+  ns_set update $form object [self]
+  ns_set update $form show_source    [::xo::cc query_parameter "show_source" 1]
+  ns_set update $form show_methods   [::xo::cc query_parameter "show_methods" 2]
+  ns_set update $form show_variables [::xo::cc query_parameter "show_variables" 1]
+  rp_internal_redirect /packages/xotcl-core/www/show-object
+}
+
 namespace eval ::xo {
   proc slotobjects cl {
     set so [list]

tcl/05-db-procs.tcl

@@ -923,6 +923,7 @@ namespace eval ::xo::db {
     switch -glob -- $name {
       ::xo::db::Object   {return acs_object}
       ::xo::db::CrItem   {return content_revision}
+      ::xo::db::image    {return image}
       ::xo::db::CrFolder {return content_folder}
       ::xo::db::*        {return [string range $name 10 end]}
       default            {return $name}
@@ -1591,7 +1592,7 @@ namespace eval ::xo::db {
   }
 
   ##############
-  ::xotcl::Class create ::xo::db::Attribute \
+  ::xotcl::MetaSlot create ::xo::db::Attribute \
       -superclass {::xo::Attribute} \
       -parameter {
         {sqltype} 
@@ -1673,7 +1674,7 @@ namespace eval ::xo::db {
   }
 
   ##############
-  ::xotcl::Class create ::xo::db::CrAttribute \
+  ::xotcl::MetaSlot create ::xo::db::CrAttribute \
       -superclass {::xo::db::Attribute} \
 
   ::xo::db::CrAttribute instproc create_attribute {} {

tcl/20-Ordered-Composite-procs.tcl

@@ -86,7 +86,20 @@ namespace eval ::xo {
     } else { 
       set insert 0
     }
-    set errorOccurred [catch {namespace eval [self] $cmds} errorMsg]
+    #
+    [self class]::ChildManager instvar composite
+    # push the active composite
+    lappend composite [self]
+    # check, if we have Tcl's apply available
+    if {$::tcl_version >= 8.5 && [info proc ::apply] eq ""} {
+      set errorOccurred [catch {::apply [list {} $cmds [self]]} errorMsg]
+    } else {
+      set errorOccurred [catch {namespace eval [self] $cmds} errorMsg]
+    }
+
+    # pop the last active composite
+    set composite [lrange $composite 0 end-1]
+
     if {$insert} {
       Object instmixin delete [self class]::ChildManager
     }
@@ -94,10 +107,13 @@ namespace eval ::xo {
   }
   Class OrderedComposite::ChildManager -instproc init args {
     set r [next]
-    set parent [self callingobject] ;# not a true calling object (ns-eval), but XOTcl 1 honors it
+    #set parent [self callingobject] ;# not a true calling object (ns-eval), but XOTcl 1 honors it
     #set parent [my info parent] ;# is ok in XOTcl 2, since the namespace is honored correctly
     #set parent [uplevel 2 self] ;# should work everywhere
     #puts stderr "-- CONTAINS p=$parent, co=[self callingobject] n=[uplevel 2 self]"
+    #
+    # get the top-most composite context as parent
+    set parent [lindex [[self class] set composite] end]
     $parent lappend __children [self]
     my set __parent $parent
     #my __after_insert

tcl/30-widget-procs.tcl

@@ -204,8 +204,9 @@ namespace eval ::xo {
 
   proc localize {text {inline 0}} {
     #ns_log notice "--local $text $inline"
-    if {![my exists __localizer]} {
-      my set __localizer [list]
+    set obj [uplevel self]
+    if {![$obj exists __localizer]} {
+      $obj set __localizer [list]
     }
     if {[string first \x002 $text] == -1} {
       return $text
@@ -242,7 +243,7 @@ namespace eval ::xo {
 	  set type missing
 	}
         if {!$inline} {
-          my lappend __localizer [::xo::Localizer new -type $type -key $key -url $url]
+          $obj lappend __localizer [::xo::Localizer new -type $type -key $key -url $url]
         } else {
           set l [::xo::Localizer new -type $type -key $key -url $url]
           append return_text [$l asHTML]
@@ -254,8 +255,9 @@ namespace eval ::xo {
   }
 
   proc render_localizer {} {
-    if {[my exists __localizer]} {
-      foreach l [my set __localizer] {
+    set obj [uplevel self]
+    if {[$obj exists __localizer]} {
+      foreach l [$obj set __localizer] {
 	$l render
 	$l destroy
       }
@@ -354,17 +356,17 @@ namespace eval ::xo {
   }
   Table instproc actions {cmd} {
     set M [OrderedComposite create [self]::__actions]
-    namespace eval $M {namespace import -force [self class]::*}
+    namespace eval $M [list namespace import -force [self class]::*]
     $M contains $cmd
   }
   Table instproc __bulkactions {cmd} {
     set M [OrderedComposite create [self]::__bulkactions]
-    namespace eval $M {namespace import -force [self class]::*}
+    namespace eval $M [list namespace import -force [self class]::*]
     $M contains $cmd
   }
   Table instproc columns {cmd} {
     set M [OrderedComposite create [self]::__columns]
-    namespace eval $M {namespace import -force [self class]::*}
+    namespace eval $M [list namespace import -force [self class]::*]
     $M contains $cmd
     set slots [list]
     foreach c [$M children] {
@@ -472,10 +474,11 @@ namespace eval ::xo {
 	-superclass ::xo::OrderedComposite::Child \
 	-parameter {name id {html {}}} \
         -instproc actions {cmd} {
-          my init
+          #my init
           set grandParent [[my info parent] info parent]
           if {![my exists name]} {my set name [namespace tail [self]]}
-          set M [::xo::OrderedComposite create ${grandParent}::__bulkactions]
+          #set M [::xo::OrderedComposite create ${grandParent}::__bulkactions]
+          set M [::xo::OrderedComposite create ${grandParent}::__bulkactions -noinit]
           namespace eval $M {namespace import -force ::xo::Table::*}
           $M contains $cmd
           $M set __belongs_to [self]

tcl/cr-procs.tcl

@@ -404,6 +404,7 @@ namespace eval ::xo::db {
     -item_id:required
     {-revision_id 0}
     -object:required
+    {-initialize true}
   } {
     Load a content item into the specified object. If revision_id is
     provided, the specified revision is returned, otherwise the live
@@ -467,6 +468,9 @@ namespace eval ::xo::db {
        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,
+    # 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 [db_string [my qn get_pid] \
@@ -474,7 +478,7 @@ namespace eval ::xo::db {
     }
 
     #my log "--AFTER FETCH\n[$object serialize]"
-    $object initialize_loaded_object
+    if {$initialize} {$object initialize_loaded_object}
     return $object
   }
 
@@ -1209,6 +1213,15 @@ namespace eval ::xo::db {
     return $allowed
   }
 
+  ::xo::db::CrClass create ::xo::db::image -superclass ::xo::db::CrItem \
+      -pretty_name "Image" \
+      -table_name "images" -id_column "image_id" \
+      -object_type image \
+      -slots {
+	::xo::db::CrAttribute create width  -datatype integer
+	::xo::db::CrAttribute create height -datatype integer
+      }
+
   #
   # CrFolder
   #
@@ -1384,6 +1397,7 @@ namespace eval ::xo::db {
     -item_id:required
     {-revision_id 0}
     -object:required
+    {-initialize true}
   } {
     We overwrite the default fetch_object method here.
     We join acs_objects, cr_items and cr_folders and fetch
@@ -1400,7 +1414,7 @@ namespace eval ::xo::db {
         JOIN acs_objects on cr_folders.folder_id = acs_objects.object_id
         WHERE folder_id = $item_id"
 
-    $object initialize_loaded_object
+    if {$initialize} {$object initialize_loaded_object}
     return $object
   }
 
@@ -1473,24 +1487,39 @@ namespace eval ::xo::db {
     -item_id:required
     {-revision_id 0}
     -object:required
+    {-initialize true}
   } {
-    set code [ns_cache eval xotcl_object_cache $object {
-      set created 1
-      #my log "--CACHE new new [self]"
-      set o [next]
+    set serialized_object [ns_cache eval xotcl_object_cache $object {
+      #my log "--CACHE true fetch [self args]" 
+      set loaded_from_db 1
+      # Call the showdowed method with initializing turned off. We
+      # want to store object before the after-load initialize in the
+      # cache to save storage.
+      set o [next -item_id $item_id -revision_id $revision_id -object $object -initialize 0]
       return [::Serializer deepSerialize $o]
     }]
     #my log "--CACHE: [self args], created [info exists created] o [info exists o]"
-    if {![info exists created]} {
+    if {[info exists loaded_from_db]} {
+      # The basic fetch_object method creates the object, we have
+      # just to run the after load init (if wanted)
+      if {$initialize} {$object initialize_loaded_object}
+    } else {
+      # The variable serialized_object contains the serialization of
+      # the object from the cache; check if the object exists already
+      # or create it.
       if {[my isobject $object]} {
-        my log "--!! $object exists already"
+	# There would have been no need to call this method. We could
+        # raise an error here.  
+	# my log "--!! $object exists already"
       } else {
-        set o [eval $code]
-	$object initialize_loaded_object
+	# Create the object from the serialization and initialize it
+        eval $serialized_object
+	if {$initialize} {$object initialize_loaded_object}
       }
     }
     return $object
   }
+
   CrCache instproc delete {-item_id} {
     next
     ::xo::clusterwide ns_cache flush xotcl_object_cache ::$item_id
@@ -1520,6 +1549,14 @@ namespace eval ::xo::db {
 
   ::xotcl::Class create CrCache::Item
   CrCache::Item set name_pattern {^::[0-9]+$}
+  CrCache::Item instproc remove_non_persistent_vars {} {
+    # we do not want to save __db__artefacts in the cache
+    foreach x [my info vars __db_*] {my unset $x}
+    # remove as well vars and array starting with "__", assuming these
+    # are volatile variables created by initialize_loaded_object or
+    # similar mechanisms
+    foreach x [my info vars __*] {if {[my array exists $x]} {my array unset $x} {my unset $x}}
+  }
   CrCache::Item instproc flush_from_cache_and_refresh {} {
     # cache only names with IDs
     set obj [self]
@@ -1538,6 +1575,7 @@ namespace eval ::xo::db {
       # session.
       set mixins [$obj info mixin]
       $obj mixin [list]
+      $obj remove_non_persistent_vars
       ns_cache set xotcl_object_cache $obj [$obj serialize]
       $obj mixin $mixins
     } else {

www/cache.tcl

@@ -78,12 +78,12 @@ if { $cache == 0 } {
   set entries "<ul>"
   set count 0
   foreach name [lsort -dictionary $item_list] {
-    set entry [ns_cache get $cache $name]
+    if {[catch {set entry [ns_cache get $cache $name]}]} continue
     if {$filter ne ""} {if {![regexp $filter $entry]} continue}
     incr count
     set n ""
     regexp -- {-set name ([^\\]+)\\} $entry _ n
-    append entries "<li><a href='?cache=$cache&item=$name'>$name</a> $n (<a href='?cache=$cache&flush=$name'>flush</a>)</li>"
+    append entries "<li><a href='?cache=$cache&item=$name'>$name</a> $n ([string length $entry] bytes, <a href='?cache=$cache&flush=$name'>flush</a>)</li>"
   }
   append entries "</ul>"
   if {$filter ne ""} {

www/show-object.tcl

@@ -187,6 +187,7 @@ if {$isclass} {
     if {$c eq "::xotcl::Object"} {continue}
     eval lappend class_hierarchy [$c info subclass]
   }
+  if {[llength $class_hierarchy]>5} {set class_hierarchy {}}
   eval lappend class_hierarchy [$object info heritage]
   if {[lsearch -exact $class_hierarchy $object] == -1} {lappend class_hierarchy $object}
   #::xotcl::Object msg class_hierarchy=$class_hierarchy

xotcl-core.info

@@ -10,10 +10,10 @@
     <inherit-templates-p>t</inherit-templates-p>
     <auto-mount>xotcl</auto-mount>
 
-    <version name="0.117" url="http://media.wu-wien.ac.at/download/xotcl-core-0.117.apm">
+    <version name="0.118" url="http://media.wu-wien.ac.at/download/xotcl-core-0.118.apm">
         <owner url="mailto:neumann@wu-wien.ac.at">Gustaf Neumann</owner>
         <summary>XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)</summary>
-        <release-date>2010-07-08</release-date>
+        <release-date>2011-01-14</release-date>
         <vendor>Gustaf Neumann, WU Wien</vendor>
         <description format="text/html">This component contains some core functionality for OpenACS
 applications using XOTcl. It includes
@@ -43,7 +43,7 @@ when components are reloaded.
         <license>BSD-Style</license>
         <maturity>0</maturity>
 
-        <provides url="xotcl-core" version="0.117"/>
+        <provides url="xotcl-core" version="0.118"/>
 
         <callbacks>
             <callback type="before-install"  proc="::xotcl-core::before_install_callback"/>