Examples:<@br> - <@pre class='code'>Serializer all -ignoreVarsRE {::b$} - Do not serialize any instance variable named b (of any object).
- <@pre class='code'>Serializer all -ignoreVarsRE {^::o1::.*text.*$|^::o2::x$} - Do not serialize any variable of c1 whose name contains - the string "text" and do not serialze the variable x of o2.
- <@pre class='code'>Serializer all -ignore obj1 obj2 ... - do not serizalze the specified objects - } - return "script" - } - - @ Serializer proc deepSerialize { - objs "Objects to be serialized" - ?-ignoreVarsRE RE? - "provide regular expression; matching vars are ignored" - ?-ignore obj1 obj2 ...? - "provide a list of objects to be omitted" - ?-map list? "translate object names in serialized code" - } { - Description { - Serialize object with all child objects (deep operation) - except the specified omissions. For the description of - <@tt>ignore and <@tt>igonoreVarsRE see - <@tt>Serizalizer all. <@tt>map can be used - in addition to provide pairs of old-string and new-string - (like in the tcl command <@tt>string map). This option - can be used to regenerate the serialized object under a different - object or under an different name, or to translate relative - object names in the serialized code.
- - Examples: - <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b ::x::y} - Serialize the object <@tt>c which is a child of <@tt>a::b; - the object will be reinitialized as object <@tt>::x::y::c, - all references <@tt>::a::b will be replaced by <@tt>::x::y.
- - <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b [self]} - The serizalized object can be reinstantiated under some current object, - under which the script is evaluated.
- - <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b::c ${var}} - The serizalized object will be reinstantiated under a name specified - by the variable <@tt>var<@tt> in the recreation context. - } - return "script" - } - - @ Serializer proc methodSerialize { - object "object or class" - method "name of method" - prefix "either empty or 'inst' (latter for instprocs)" - } { - Description { - Serialize the specified method. In order to serialize - an instproc, <@tt>prefix should be 'inst'; to serialze - procs, it should be empty.
- - Examples: - <@pre class='code'>Serializer methodSerialize Serializer deepSerialize "" - This command serializes the proc <@tt>deepSerialize - of the Class <@tt>Serializer.
- - <@pre class='code'>Serializer methodSerialize Serializer serialize inst - This command serializes the instproc <@tt>serialize - of the Class <@tt>Serializer.
- } - return {Script, which can be used to recreate the specified method} - } - @ Serializer proc exportMethods { - list "list of methods of the form 'object proc|instproc methodname'" - } { - Description { - This method can be used to specify methods that should be - exported in every <@tt>Serializer all<@/tt>. The rationale - behind this is that the serializer does not serialize objects - from the ::xotcl:: namespace, which is used for XOTcl internals - and volatile objects. It is however often useful to define - methods on ::xotcl::Class or ::xotcl::Objects, which should - be exported. One can export procs, instprocs, forward and instforward
- Example: - <@pre class='code'> Serializer exportMethods { - ::xotcl::Object instproc __split_arguments - ::xotcl::Object instproc __make_doc - ::xotcl::Object instproc ad_proc - ::xotcl::Class instproc ad_instproc - ::xotcl::Object forward expr - }<@/pre> - } - } - - - @ Serializer instproc serialize {entity "Object or Class"} { - Description { - Serialize the specified object or class. - } - return {Object or Class with all currently defined methods, - variables, invariants, filters and mixins} - } - - ################################################################################## - # real clode starts here..... - # ################################################################################ - Class Serializer -parameter {ignoreVarsRE map} - namespace export Serializer - - Serializer proc ignore args { - my set skip $args - } - Serializer instproc ignore args { - foreach i $args { - my set skip($i) 1 - # skip children of ignored objects as well - foreach j [$i info children] { - my ignore $j - } - } - } - Serializer instproc init {} { - my ignore [self] - if {[[self class] exists skip]} { - eval my ignore [[self class] set skip] - } - } - Serializer instproc method-serialize {o m prefix} { - my pcmd [my unescaped-method-serialize $o $m $prefix] - } - Serializer instproc unescaped-method-serialize {o m prefix} { - set arglist [list] - foreach v [$o info ${prefix}args $m] { - if {[$o info ${prefix}default $m $v x]} { - lappend arglist [list $v $x] } {lappend arglist $v} - } - lappend r ${prefix}proc $m \ - [concat [$o info ${prefix}nonposargs $m] $arglist] \ - [$o info ${prefix}body $m] - foreach p {pre post} { - if {[$o info ${prefix}$p $m] ne ""} {lappend r [$o info ${prefix}$p $m]} - } - return $r - } - Serializer instproc pcmd list { - foreach a $list { - if {[regexp -- {^-[[:alpha:]]} $a]} { - set mustEscape 1 - break - } - } - if {[info exists mustEscape]} { - return "\[list -$list\]" - } else { - return -$list - } - } - Serializer instproc Object-serialize o { - append cmd [list [$o info class] create [$o self] -noinit] " \\\n" - foreach i [$o info procs] { - append cmd " " [my method-serialize $o $i ""] " \\\n" - } - foreach i [$o info forward] { - set fwd [concat [list forward $i] [$o info forward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" - } - set vset {} - set nrVars 0 - foreach v [$o info vars] { - set setcmd [list] - if {![my exists ignoreVarsRE] || - ![regexp [my set ignoreVarsRE] ${o}::$v]} { - if {[$o array exists $v]} { - lappend setcmd array set $v [$o array get $v] - } else { - lappend setcmd set $v [$o set $v] - } - incr nrVars - append cmd \t [my pcmd $setcmd] " \\\n" - } - } - foreach x {mixin invar} { - set v [$o info $x] - if {$v ne ""} {my append postcmd [list $o $x set $v] "\n"} - } - set v [$o info filter -guards] - if {$v ne ""} {append cmd [my pcmd [list filter $v]] " \\\n"} - return $cmd - } - Serializer instproc Class-serialize o { - set cmd [my Object-serialize $o] - set p [$o info parameter] - if {$p ne ""} { - append cmd " " [my pcmd [list parameter $p]] " \\\n" - } - foreach i [$o info instprocs] { - append cmd " " [my method-serialize $o $i inst] " \\\n" - } - foreach i [$o info instforward] { - set fwd [concat [list instforward $i] [$o info instforward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" - } - foreach x {superclass instinvar} { - set v [$o info $x] - if {$v ne "" && "::xotcl::Object" ne $v } { - append cmd " " [my pcmd [list $x $v]] " \\\n" - } - } - foreach x {instmixin} { - set v [$o info $x] - if {$v ne "" && "::xotcl::Object" ne $v } { - my append postcmd [list $o $x set $v] "\n" - #append cmd " " [my pcmd [list $x $v]] " \\\n" - } - } - set v [$o info instfilter -guards] - if {$v ne ""} {append cmd [my pcmd [list instfilter $v]] " \\\n"} - return $cmd\n - } - - Serializer instproc args {o prefix m} { - foreach v [$o info ${prefix}args $m] { - if {[$o info ${prefix}default $m $v x]} { - lappend arglist [list $v $x] } { - lappend arglist $v } - } - return $arglist - } - Serializer instproc category c { - if {[$c istype ::xotcl::Class]} {return Class} {return Object} - } - Serializer instproc allChildren o { - set set $o - foreach c [$o info children] { - eval lappend set [my allChildren $c] - } - return $set - } - Serializer instproc allInstances C { - set set [$C info instances] - foreach sc [$C info subclass] { - eval lappend set [my allInstances $sc] - } - return $set - } - - Serializer instproc topoSort {set all} { - if {[my array exists s]} {my array unset s} - if {[my array exists level]} {my array unset level} - foreach c $set { - if {!$all && - [string match "::xotcl::*" $c] && - ![[self class] exists exportObjects($c)]} continue - if {[my exists skip($c)]} continue - my set s($c) 1 - } - set stratum 0 - while {1} { - set set [my array names s] - if {[llength $set] == 0} break - incr stratum - #my warn "$stratum set=$set" - my set level($stratum) {} - foreach c $set { - if {[my [my category $c]-needsNothing $c]} { - my lappend level($stratum) $c - } - } - if {[my set level($stratum)] eq ""} { - my set level($stratum) $set - my warn "Cyclic dependency in $set" - } - foreach i [my set level($stratum)] {my unset s($i)} - } - } - Serializer instproc warn msg { - if {[info command ns_log] ne ""} { - ns_log Notice $msg - } else { - puts stderr "!!! $msg" - } - } - - Serializer instproc Class-needsNothing x { - if {![my Object-needsNothing $x]} {return 0} - if {[my needsOneOf [$x info superclass]]} {return 0} - #if {[my needsOneOf [$x info instmixin ]]} {return 0} - return 1 - } - Serializer instproc Object-needsNothing x { - set p [$x info parent] - if {$p ne "::" && [my needsOneOf $p]} {return 0} - if {[my needsOneOf [$x info class]]} {return 0} - #if {[my needsOneOf [$x info mixin ]]} {return 0} - return 1 - } - Serializer instproc needsOneOf list { - foreach e $list {if {[my exists s($e)]} {return 1}} - return 0 - } - Serializer instproc serialize {objectOrClass} { - string trimright [my [my category $objectOrClass]-serialize $objectOrClass] "\\\n" - } - Serializer instproc serialize-objects {list all} { - my set postcmd "" - my topoSort $list $all - #foreach i [lsort [my array names level]] {my warn "$i: [my set level($i)]"} - set result "" - foreach l [lsort [my array names level]] { - foreach i [my set level($l)] { - #my warn "serialize $i" - append result [my serialize $i] \n - } - } - foreach e $list { - set namespace($e) 1 - set namespace([namespace qualifiers $e]) 1 - } - - set exports "" - set nsdefines "" - # delete ::xotcl from the namespace list, if it exists... - catch {unset namespace(::xotcl)} - foreach ns [array name namespace] { - if {![namespace exists $ns]} continue - if {![my isobject $ns]} { - append nsdefines "namespace eval $ns {}\n" - } elseif {$ns ne [namespace origin $ns] } { - append nsdefines "namespace eval $ns {}\n" - } - set exp [namespace eval $ns {namespace export}] - if {$exp ne ""} { - append exports "namespace eval $ns {namespace export $exp}" \n - } - } - return $nsdefines$result[my set postcmd]$exports - } - Serializer instproc deepSerialize o { - # assumes $o to be fully qualified - my serialize-objects [my allChildren $o] 1 - } - Serializer instproc serializeMethod {object kind name} { - set code "" - switch $kind { - proc { - if {[$object info procs $name] ne ""} { - set code [my method-serialize $object $name ""] - } - } - instproc { - if {[$object info instprocs $name] ne ""} { - set code [my method-serialize $object $name inst] - } - } - forward - instforward { - if {[$object info $kind $name] ne ""} { - set fwd [concat [list $kind $name] [$object info $kind -definition $name]] - set code [my pcmd $fwd] - } - } - } - return $code - } - - - Serializer proc exportMethods list { - foreach {o p m} $list {my set exportMethods($o,$p,$m) 1} - } - Serializer proc exportObjects list { - foreach o $list {my set exportObjects($o) 1} - } - - Serializer proc serializeExportedMethods {s} { - set r "" - foreach k [my array names exportMethods] { - foreach {o p m} [split $k ,] break - #if {$o ne "::xotcl::Object" && $o ne "::xotcl::Class"} { - #error "method export only for ::xotcl::Object and\ - # ::xotcl::Class implemented, not for $o" - #} - if {![string match "::xotcl::*" $o]} { - error "method export is only for ::xotcl::* \ - object an classes implemented, not for $o" - } - append methods($o) [$s serializeMethod $o $p $m] " \\\n " - } - set objects [array names methods] - foreach o [list ::xotcl::Object ::xotcl::Class] { - set p [lsearch $o $objects] - if {$p == -1} continue - set objects [lreplace $objects $p $p] - } - foreach o [concat ::xotcl::Object ::xotcl::Class $objects] { - if {![info exists methods($o)]} continue - append r \n "$o configure \\\n " \ - [string trimright $methods($o) "\\\n "] - } - #puts stderr "... exportedMethods <$r\n>" - return "$r\n" - } - - Serializer proc all {args} { - set filterstate [::xotcl::configure filter off] - set s [eval my new -childof [self] -volatile $args] - # always export __exitHandler - my exportMethods [list ::xotcl::Object proc __exitHandler] - set r {set ::xotcl::__filterstate [::xotcl::configure filter off]} - append r \n "::xotcl::configure softrecreate [::xotcl::configure softrecreate]" - append r \n [my serializeExportedMethods $s] - # export the objects and classes - #$s warn "export objects = [my array names exportObjects]" - #$s warn "export objects = [my array names exportMethods]" - append r [$s serialize-objects [$s allInstances ::xotcl::Object] 0] - foreach o [list ::xotcl::Object ::xotcl::Class] { - foreach x {mixin instmixin invar instinvar} { - set v [$o info $x] - if {$v ne "" && $v ne "::xotcl::Object"} { - append r "$o configure " [$s pcmd [list $x $v]] "\n" - } - } - } - append r { - ::xotcl::configure filter $::xotcl::__filterstate - unset ::xotcl::__filterstate - } - ::xotcl::configure filter $filterstate - return $r - } - Serializer proc methodSerialize {object method prefix} { - set s [my new -childof [self] -volatile] - concat $object [$s unescaped-method-serialize $object $method $prefix] - } - Serializer proc deepSerialize args { - set s [my new -childof [self] -volatile] - set nr [eval $s configure $args] - foreach o [lrange $args 0 [incr nr -1]] { - append r [$s deepSerialize [$o]] - } - if {[$s exists map]} {return [string map [$s map] $r]} - return $r - } - - Serializer exportObjects [namespace current]::Serializer - namespace eval :: "namespace import -force [namespace current]::*" - - #ns_log notice "???? sourceing.....Serializer" +if {$::xotcl::version < 1.5} { + ns_log notice "**********************************************************" + ns_log notice "This version of xotcl-core requires at least XOTcl 1.5.0." + ns_log notice "The installed version ($::xotcl::version$::xotcl::patchlevel appears to be older." + ns_log notice "Please updgrade to a new version (see http://openacs.org/xowiki/xotcl-core)" + ns_log notice "**********************************************************" } 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.11 -r1.12 --- openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 31 May 2007 20:17:34 -0000 1.11 +++ openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 26 Jan 2008 00:58:59 -0000 1.12 @@ -66,7 +66,7 @@ } } #show_stack;my log "--W children murdered, now next, chlds=[my info children]" - namespace eval [self] {namespace forget *} ;# for pre 1.4.0 versions + #namespace eval [self] {namespace forget *} ;# for pre 1.4.0 versions next } Index: openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl,v diff -u -r1.28 -r1.29 --- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 1 Jan 2008 23:31:00 -0000 1.28 +++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 26 Jan 2008 00:58:59 -0000 1.29 @@ -469,23 +469,22 @@ {src /resources/acs-subsite/Edit16.gif} {width 16} {height 16} {border 0} {title "[_ xotcl-core.edit_item]"} {alt "edit"} } - # for xotcl 1.4.0: {title [_ xotcl-core.edit_item]} {alt "edit"} Class ImageField_AddIcon \ -superclass ImageAnchorField -parameter { {src /resources/acs-subsite/Add16.gif} {width 16} {height 16} {border 0} - {title "Add Item"} {alt "add"} + {title "[_ xotcl-core.add_item]"} {alt "add"} } Class ImageField_ViewIcon \ -superclass ImageAnchorField -parameter { {src /resources/acs-subsite/Zoom16.gif} {width 16} {height 16} {border 0} - {title "View Item"} {alt "view"} + {title "[_ xotcl-core.view_item]"} {alt "view"} } Class ImageField_DeleteIcon \ -superclass ImageAnchorField -parameter { {src /resources/acs-subsite/Delete16.gif} {width 16} {height 16} {border 0} - {title "Delete Item"} {alt "delete"} + {title "[_ xotcl-core.delete_item]"} {alt "delete"} } # export table elements Index: openacs-4/packages/xotcl-core/tcl/test/xotcl-avail-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/test/xotcl-avail-procs.tcl,v diff -u -r1.2 -r1.3 --- openacs-4/packages/xotcl-core/tcl/test/xotcl-avail-procs.tcl 8 Oct 2007 17:37:03 -0000 1.2 +++ openacs-4/packages/xotcl-core/tcl/test/xotcl-avail-procs.tcl 26 Jan 2008 00:58:59 -0000 1.3 @@ -17,7 +17,7 @@ #} } - ? {expr {$::xotcl::version < 1.4}} 0 "XOTcl Version $::xotcl::version >= 1.4" + ? {expr {$::xotcl::version < 1.5}} 0 "XOTcl Version $::xotcl::version >= 1.5" set ns_cache_version_old [catch {ns_cache names xowiki_cache xxx}] if {$ns_cache_version_old} {