Examples:<@br> - <@tt>Serializer all -ignoreVarsRE {::b$}<@br> - do not serialize any instance variable named b (of any object)
- <@tt>Serializer all -ignoreVarsRE {^::o1::.*text.*$|^::o2::x$}<@br> - do not serialize any variable of c1 whose name contains - the string "text" and do not serialze the variable x of o2
- <@tt>Serializer all - ignore obj1 obj2 ... <@br> - do not serizalze the specified objects + @ Serializer proc all { + ?-ignoreVarsRE RE? + "provide regular expression; matching vars are ignored" + ?-ignore obj1 obj2 ...? + "provide a list of objects to be omitted"} { + Description { + Serialize all objects and classes that are currently + defined (except the specified omissions and the current + Serializer object). +
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" } - 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: - <@tt>Serializer deepSerialize ::a::b::c -map {::a::b ::x::y}<@br> - 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.
- - <@tt>Serializer deepSerialize ::a::b::c -map {::a::b [self]}<@br> - The serizalized object can be reinstantiated under some current object, - under which the script is evaluated.
- - <@tt>Serializer deepSerialize ::a::b::c -map {::a::b::c ${var}}<@br> - The serizalized object will be reinstantiated under a name specified - by the variable <@tt>var<@tt> in the recreation context. + + @ 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" } - return "script" -} - -@ Serializer instproc serialize {entity "Object or Class"} { - Description { - Serialize the specified object or class. + + @ 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} } - return {Object or Class with all currently defined methods, - variables, invariants, filters and mixins} -} - -######################################################################################## -Class Serializer -parameter {ignoreVarsRE map} -Serializer proc addGlobalMethods list { - foreach {o p m} $list {my set globalExportMethods($o,$p,$m) 1} -} -Serializer proc ignore args { - my set skip $args -} -Serializer instproc ignore args { - foreach i $args { my set skip($i) 1 } -} -Serializer instproc init {} { - my ignore [self] - if {[[self class] exists skip]} { - eval my ignore [[self class] set skip] + @ 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.
+ 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 + }<@/pre> + } } -} -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} + + + @ 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} } - 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]!=""} {lappend r [$o info ${prefix}$p $m]} + + ######################################################################################## + Class Serializer -parameter {ignoreVarsRE map} + namespace export Serializer + Serializer proc ignore args { + my set skip $args } - return $r -} -Serializer instproc pcmd list { - foreach a $list { - if {[regexp -- {^-[[:alpha:]]} $a]} { - set mustEscape 1 - break + Serializer instproc ignore args { + foreach i $args { my set skip($i) 1 } + } + Serializer instproc init {} { + my ignore [self] + if {[[self class] exists skip]} { + eval my ignore [[self class] set skip] } } - if {[info exists mustEscape]} { - return "\[list -$list\]" - } else { - return -$list + Serializer instproc method-serialize {o m prefix} { + my pcmd [my unescaped-method-serialize $o $m $prefix] } -} -Serializer instproc Object-serialize o { - append cmd [list [$o info class] create $o -noinit] " \\\n" - foreach i [$o info procs] { - append cmd " " [my method-serialize $o $i ""] " \\\n" + 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]!=""} {lappend r [$o info ${prefix}$p $m]} + } + return $r } - foreach i [$o info forward] { - set fwd [concat [list forward $i] [$o info forward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" + 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 + } } - 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] + Serializer instproc Object-serialize o { + append cmd [list [$o info class] create $o -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" } - incr nrVars - append cmd \t [my pcmd $setcmd] " \\\n" } + foreach x {mixin invar} { + set v [$o info $x] + if {[string compare "" $v]} {append cmd [my pcmd [list $x $v]] " \\\n"} + } + set v [$o info filter -guards] + if {[string compare "" $v]} {append cmd [my pcmd [list filter $v]] " \\\n"} + return $cmd } - foreach x {mixin invar} { - set v [$o info $x] - if {[string compare "" $v]} {append cmd [my pcmd [list $x $v]] " \\\n"} + Serializer instproc Class-serialize o { + set cmd [my Object-serialize $o] + set p [$o info parameter] + if {[string compare "" $p]} { + 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 instmixin instinvar} { + set v [$o info $x] + if {[string compare "" $v] && [string compare "::xotcl::Object" $v]} { + append cmd " " [my pcmd [list $x $v]] " \\\n" + } + } + set v [$o info instfilter -guards] + if {[string compare "" $v]} {append cmd [my pcmd [list instfilter $v]] " \\\n"} + return $cmd\n } - set v [$o info filter -guards] - if {[string compare "" $v]} {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 {[string compare "" $p]} { - append cmd " " [my pcmd [list parameter $p]] " \\\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 } - foreach i [$o info instprocs] { - append cmd " " [my method-serialize $o $i inst] " \\\n" + Serializer instproc category c { + if {[$c istype ::Class]} {return Class} {return Object} } - foreach i [$o info instforward] { - set fwd [concat [list instforward $i] [$o info instforward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" + Serializer instproc allChildren o { + set set $o + foreach c [$o info children] { + eval lappend set [my allChildren $c] + } + return $set } - foreach x {superclass instmixin instinvar} { - set v [$o info $x] - if {[string compare "" $v] && [string compare "::xotcl::Object" $v]} { - append cmd " " [my pcmd [list $x $v]] " \\\n" + Serializer instproc allInstances C { + set set [$C info instances] + foreach sc [$C info subclass] { + eval lappend set [my allInstances $sc] } + return $set } - set v [$o info instfilter -guards] - if {[string compare "" $v]} {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 } + + Serializer instproc topoSort {set} { + if {[my array exists s]} {my array unset s} + if {[my array exists level]} {my array unset level} + foreach c $set { + if {[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 + #puts "$stratum set=$set" + my set level($stratum) {} + foreach c $set { + if {[my [my category $c]-needsNothing $c]} { + my lappend level($stratum) $c + } + } + if {[string equal "" [my set level($stratum)]]} { + my set level($stratum) $set + my warn "Cyclic dependency in $set" + } + foreach i [my set level($stratum)] {my unset s($i)} + } } - return $arglist -} -Serializer instproc category c { - if {[$c istype ::Class]} {return Class} {return Object} -} -Serializer instproc allChildren o { - set set $o - foreach c [$o info children] { - eval lappend set [my allChildren $c] + Serializer instproc warn msg { + if {[string compare "" [info command ns_log]]} { + ns_log Notice $msg + } else { + puts stderr "!!! Warning: $msg" + } } - return $set -} -Serializer instproc allInstances C { - set set [$C info instances] - foreach sc [$C info subclass] { - eval lappend set [my allInstances $sc] + + 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 } - return $set -} - -Serializer instproc topoSort {set} { - if {[my array exists s]} {my array unset s} - if {[my array exists level]} {my array unset level} - foreach c $set { - if {[regexp ^::xotcl:: $c]} continue - if {[my exists skip($c)]} continue - my set s($c) 1 + Serializer instproc Object-needsNothing x { + set p [$x info parent] + if {[string compare $p "::"] && [my needsOneOf $p]} {return 0} + if {[my needsOneOf [$x info class]]} {return 0} + if {[my needsOneOf [$x info mixin ]]} {return 0} + return 1 } - set stratum 0 - while {1} { - set set [my array names s] - if {[llength $set] == 0} break - incr stratum - #puts "$stratum set=$set" - my set level($stratum) {} - foreach c $set { - if {[my [my category $c]-needsNothing $c]} { - my lappend level($stratum) $c + Serializer instproc needsOneOf list { + foreach e $list {if {[my exists s($e)]} {return 1}} + return 0 + } + Serializer instproc serialize {objectOrClass} { + my [my category $objectOrClass]-serialize $objectOrClass + } + Serializer instproc serializeList {list} { + my topoSort $list + #foreach i [lsort [my array names level]] {puts "$i: [my set level($i)]"} + set result "" + foreach l [lsort [my array names level]] { + foreach i [my set level($l)] { + append result [string trimright [my serialize $i] "\\\n"] \n } } - if {[string equal "" [my set level($stratum)]]} { - my set level($stratum) $set - my warn "Cyclic dependency in $set" + foreach e $list { + if {[namespace exists $e]} { + set namespace($e) 1 + set namespace([namespace parent $e]) 1 + } } - foreach i [my set level($stratum)] {my unset s($i)} - } -} -Serializer instproc warn msg { - if {[string compare "" [info command ns_log]]} { - ns_log Notice $msg - } else { - puts stderr "!!! Warning: $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 {[string compare $p "::"] && [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} { - my [my category $objectOrClass]-serialize $objectOrClass -} -Serializer instproc serializeList {list} { - my topoSort $list - #foreach i [lsort [my array names level]] {puts "$i: [my set level($i)]"} - set result "" - foreach l [lsort [my array names level]] { - foreach i [my set level($l)] { - append result [string trimright [my serialize $i] "\\\n"] \n + set exports "" + set nsdefines "" + # delete ::xotcl from the namespace list, if it exists... + catch {unset namespace(::xotcl)} + foreach ns [array name namespace] { + if {![my isobject $ns]} { + append nsdefines "namespace eval $ns {}\n" + } elseif {[string compare $ns [namespace origin $ns]]} { + append nsdefines "namespace eval $ns {}\n" + } + set exp [namespace eval $ns {namespace export}] + if {[string compare "" $exp]} { + append exports "namespace eval $ns {namespace export $exp}" \n + } } + return $nsdefines$result$exports } - return $result -} -Serializer instproc deepSerialize o { - # assumes $o to be fully qualified - my serializeList [my allChildren $o] -} + Serializer instproc deepSerialize o { + # assumes $o to be fully qualified + my serializeList [my allChildren $o] + } + + 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 all {args} { - set s [eval my new -childof [self] -volatile $args] - set r [$s serializeList [$s allInstances ::Object]] - my addGlobalMethods [list ::xotcl::Object proc __exitHandler] - foreach k [my array names globalExportMethods] { - foreach {o p m} [split $k ,] break - switch $p { - proc {set prefix ""} - instproc {set prefix inst} + Serializer proc all {args} { + set s [eval my new -childof [self] -volatile $args] + set r [$s serializeList [$s allInstances ::xotcl::Object]] + my exportMethods [list ::xotcl::Object proc __exitHandler] + foreach k [my array names exportMethods] { + foreach {o p m} [split $k ,] break + switch $p { + proc {set prefix ""} + instproc {set prefix inst} + } + if {[string compare "" [$o info ${prefix}procs $m]]} { + if {![info exists methods($o)]} {set methods($o) ""} + append methods($o) [$s method-serialize $o $m $prefix] " \\\n " + } } - if {[string compare "" [$o info ${prefix}procs $m]]} { - if {![info exists methods($o)]} {set methods($o) ""} - append methods($o) [$s method-serialize $o $m $prefix] " \\\n " + foreach o [array names methods] { + append r \n "$o configure \\\n " [string trimright $methods($o) "\\\n "] } + return $r } - foreach o [array names methods] { - append r \n "$o configure \\\n " [string trimright $methods($o) "\\\n "] + Serializer proc methodSerialize {object method prefix} { + set s [my new -childof [self] -volatile] + concat $object [$s unescaped-method-serialize $object $method $prefix] } - 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]] + 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 + if {[$s exists map]} {return [string map [$s map] $r]} + return $r + } } - +namespace import ${::xotcl::ns}::* +Serializer exportObjects ${::xotcl::ns}::Serializer Index: xotcl/library/serialize/pkgIndex.tcl =================================================================== diff -u -r0896d4deb00780e48b5b03269bf9c4ecca948919 -r836f3964b3b9bff2d75f7f0b5dbc7939164ba24e --- xotcl/library/serialize/pkgIndex.tcl (.../pkgIndex.tcl) (revision 0896d4deb00780e48b5b03269bf9c4ecca948919) +++ xotcl/library/serialize/pkgIndex.tcl (.../pkgIndex.tcl) (revision 836f3964b3b9bff2d75f7f0b5dbc7939164ba24e) @@ -10,4 +10,3 @@ package ifneeded xotcl::scriptCreation::recoveryPoint 0.8 [list source [file join $dir RecoveryPoint.xotcl]] package ifneeded xotcl::scriptCreation::scriptCreator 0.8 [list source [file join $dir ScriptCreator.xotcl]] -package ifneeded xotcl::serializer 0.6 [list source [file join $dir Serializer.xotcl]] Index: xotcl/xotclConfig.sh =================================================================== diff -u -r0896d4deb00780e48b5b03269bf9c4ecca948919 -r836f3964b3b9bff2d75f7f0b5dbc7939164ba24e --- xotcl/xotclConfig.sh (.../xotclConfig.sh) (revision 0896d4deb00780e48b5b03269bf9c4ecca948919) +++ xotcl/xotclConfig.sh (.../xotclConfig.sh) (revision 836f3964b3b9bff2d75f7f0b5dbc7939164ba24e) @@ -65,5 +65,5 @@ XOTCL_UNSHARED_LIB_SUFFIX=1.3.5${DBGX}.a # the shell in whose installation dirs the xotcl package is installed -XOTCL_COMPATIBLE_TCLSH=/home/neumann/tcl8.4.7/unix/tclsh +XOTCL_COMPATIBLE_TCLSH=/home/neumann/tcl8.4.9/unix/tclsh