Examples: - <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b ::x::y} + <@pre class='code'>Serializer deepSerialize -map {::a::b ::x::y} ::a::b::c 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]} + <@pre class='code'>Serializer deepSerialize -map {::a::b [self]} ::a::b::c 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}} + <@pre class='code'>Serializer deepSerialize -map {::a::b::c ${var} ::a::b::c} The serizalized object will be reinstantiated under a name specified by the variable <@tt>var<@tt> in the recreation context. } @@ -126,429 +126,682 @@ 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 Class, independent from Object System + ########################################################################### + + Class create Serializer -parameter {ignoreVarsRE} { + + #todo: copy to oss? use ignorePattern? + .method ignore args { + # ignore the objects passed via args + foreach element $args { + foreach o [Serializer allChildren $element] { + set .skip($o) 1 + } } } - } - Serializer instproc init {} { - my ignore [self] - if {[[self class] exists skip]} { - eval my ignore [[self class] set skip] + + .method init {} { + # never serialize the (volatile) serializer object + .ignore [self] } - } - 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} + + .method warn msg { + if {[info command ns_log] ne ""} { + ns_log Notice $msg + } else { + puts stderr "!!! $msg" + } } - 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]} + + .method addPostCmd {cmd} { + if {$cmd ne ""} {append .post_cmds $cmd "\n"} } - return $r - } - Serializer instproc pcmd list { - foreach a $list { - if {[regexp -- {^-[[:alpha:]]} $a]} { - set mustEscape 1 - break + + .method setObjectSystemSerializer {o serializer} { + set .serializer($o) $serializer + } + + .method isExportedObject {o} { + # Check, whether o is exported. For exported objects. + # we export the object tree. + set oo $o + while {1} { + if {[[self class] exists exportObjects($o)]} { + return 1 + } + # we do this for object trees without object-less namespaces + if {![::xotcl::is $o object]} { + return 0 + } + set o [$o info parent] } } - if {[info exists mustEscape]} { - return "\[list -$list\]" - } else { - return -$list - } - } - Serializer instproc collect-var-traces o { - my instvar traces - foreach v [$o info vars] { - set t [$o __trace__ info variable $v] - if {$t ne ""} { - foreach ops $t { - foreach {op cmd} $ops break - # save traces in post_cmds - my append post_cmds [list $o trace add variable $v $op $cmd] "\n" - # remove trace from object - $o trace remove variable $v $op $cmd - } + + .method topoSort {set all} { + if {[array exists .s]} {array unset .s} + if {[array exists .level]} {array unset .level} + + foreach c $set { + if {!$all && + [string match "::xotcl::*" $c] && + ![.isExportedObject $c]} continue + if {[info exists .skip($c)]} continue + set .s($c) 1 } + set stratum 0 + while {1} { + set set [array names .s] + if {[llength $set] == 0} break + incr stratum + # .warn "$stratum set=$set" + set .level($stratum) {} + foreach c $set { + set oss [set .serializer($c)] + if {[$oss needsNothing $c [self]]} { + lappend .level($stratum) $c + } + } + if {[set .level($stratum)] eq ""} { + set .level($stratum) $set + .warn "Cyclic dependency in $set" + } + foreach i [set .level($stratum)] {unset .s($i)} + } } - } - Serializer instproc Object-serialize o { - my collect-var-traces $o - append cmd [list [$o info class] create [::xotcl::dispatch $o -objscope ::xotcl::self]] - # slots needs to be initialized when optimized, since - # parametercmds are not serialized - #if {![$o istype ::xotcl::Slot]} {append cmd " -noinit"} - append cmd " -noinit" - append cmd " \\\n" - foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype scripted] { - append cmd " " [my method-serialize $o $i ""] " \\\n" + + .method needsOneOf list { + foreach e $list {if {[info exists .s($e)]} {return 1}} + return 0 } - foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype forward] { - set fwd [concat [list forward $i] [$o info forward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" + + .method serialize-objects {list all} { + set .post_cmds "" + + # register for introspection purposes "trace" under a different + # name for every object system + foreach oss [ObjectSystemSerializer info instances] { + $oss registerTrace 1 + } + + .topoSort $list $all + #foreach i [lsort [array names .level]] { .warn "$i: [set .level($i)]"} + set result "" + foreach l [lsort -integer [array names .level]] { + foreach i [set .level($l)] { + #.warn "serialize $i" + #append result "# Stratum $l\n" + set oss [set .serializer($i)] + append result [$oss serialize $i [self]] \n + } + } + foreach e $list { + set namespace($e) 1 + set namespace([namespace qualifiers $e]) 1 + } + # remove "trace" from all object systems + foreach oss [ObjectSystemSerializer info instances] { + $oss registerTrace 0 + } + + # Handling of variable traces: traces might require a + # different topological sort, which is hard to handle. + # Similar as with filters, we deactivate the variable + # traces during initialization. This happens by + # (1) replacing the XOTcl's trace method by a no-op + # (2) collecting variable traces through collect-var-traces + # (3) re-activating the traces after variable initialization + + set exports "" + set pre_cmds "" + + # delete ::xotcl from the namespace list, if it exists... + catch {unset namespace(::xotcl)} + foreach ns [array name namespace] { + if {![namespace exists $ns]} continue + if {![::xotcl::is $ns object]} { + append pre_cmds "namespace eval $ns {}\n" + } elseif {$ns ne [namespace origin $ns] } { + append pre_cmds "namespace eval $ns {}\n" + } + set exp [namespace eval $ns {namespace export}] + if {$exp ne ""} { + append exports "namespace eval $ns {namespace export $exp}" \n + } + } + return $pre_cmds$result${.post_cmds}$exports } - foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype setter] { - append cmd \t [my pcmd [list parametercmd $i]] " \\\n" + + .method deepSerialize o { + # assumes $o to be fully qualified + set instances [Serializer allChildren $o] + foreach oss [ObjectSystemSerializer info instances] { + $oss registerSerializer [self] $instances + } + .serialize-objects $instances 1 } - set vset {} - set nrVars 0 - foreach v [$o info vars] { - set setcmd [list] - if {![my exists ignoreVarsRE] || - ![regexp [my set ignoreVarsRE] ${o}::$v]} { - if {[::xotcl::dispatch $o ::array exists $v]} { - lappend setcmd array set $v [::xotcl::dispatch $o ::array get .$v] - } else { - lappend setcmd set $v [::xotcl::setinstvar $o $v] - } - incr nrVars - append cmd \t [my pcmd $setcmd] " \\\n" + + ############################### + # class object specfic methods + ############################### + + .object method allChildren o { + # return o and all its children fully qualified + set set [::xotcl::dispatch $o -objscope ::xotcl::self] + foreach c [$o info children] { + lappend set {*}[.allChildren $c] } + return $set } - set v [$o info mixin] - if {$v ne ""} {my append post_cmds [list $o mixin set $v] "\n"} - set v [::xotcl::assertion $o object-invar] - if {$v ne ""} {my append post_cmds [list ::xotcl::assertion $o object-invar $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" + + .object method exportMethods list { + foreach {o p m} $list {set .exportMethods([list $o $p $m]) 1} } - foreach i [$o info instforward] { - set fwd [concat [list instforward $i] [$o info instforward -definition $i]] - append cmd \t [my pcmd $fwd] " \\\n" + + .object method exportObjects list { + foreach element $list { + foreach o [Serializer allChildren $element] { + set .exportObjects($o) 1 + } + } } - foreach i [$o info instparametercmd] { - append cmd \t [my pcmd [list instparametercmd $i]] " \\\n" + + .object method exportedMethods {} {array names .exportMethods} + .object method exportedObjects {} {array names .exportObjects} + + .object method resetPattern {} {array unset .ignorePattern} + .object method addPattern {p} {set .ignorePattern($p) 1} + + .object method checkExportedMethods {} { + foreach k [array names .exportMethods] { + foreach {o p m} $k break + set ok 0 + foreach p [array names .ignorePattern] { + if {[string match $p $o]} { + set ok 1; break + } + } + if {!$ok} { + error "method export is only for classes in\ + [join [array names .ignorePattern] {, }] not for $o" + } + } } - foreach x {superclass instinvar} { - set v [$o info $x] - if {$v ne "" && "::xotcl::Object" ne $v } { - append cmd " " [my pcmd [list $x $v]] " \\\n" + + .object method all {-ignoreVarsRE -ignore} { + + # don't filter anything during serialization + set filterstate [::xotcl::configure filter off] + set s [.new -childof [self] -volatile] + if {[info exists ignoreVarsRE]} {$s ignoreVarsRE $ignoreVarsRE} + if {[info exists ignore]} {$s ignore $ignore} + + set r [subst { + set ::xotcl::__filterstate \[::xotcl::configure filter off\] + ::xotcl::Slot mixin add ::xotcl::Slot::Nocheck + ::xotcl::configure softrecreate [::xotcl::configure softrecreate] + ::xotcl::setExitHandler [list [::xotcl::getExitHandler]] + }]\n + .resetPattern + set instances [list] + foreach oss [ObjectSystemSerializer info instances] { + append r [$oss serialize-all-start $s] + lappend instances {*}[$oss instances $s] } + + # provide error messages for invalid exports + .checkExportedMethods + + # export the objects and classes + #$s warn "export objects = [array names .exportObjects]" + #$s warn "export objects = [array names .exportMethods]" + + append r [$s serialize-objects $instances 0] + + foreach oss [ObjectSystemSerializer info instances] { + append r [$oss serialize-all-end $s] + } + + append r { + ::xotcl::Slot mixin delete ::xotcl::Slot::Nocheck + ::xotcl::configure filter $::xotcl::__filterstate + unset ::xotcl::__filterstate + } + ::xotcl::configure filter $filterstate + return $r } - foreach x {instmixin} { - set v [$o info $x] - if {$v ne "" && "::xotcl::Object" ne $v } { - my append post_cmds [list $o $x set $v] "\n" - #append cmd " " [my pcmd [list $x $v]] " \\\n" + + .object method methodSerialize {object method prefix} { + set s [.new -childof [self] -volatile] + concat $object [$s method-serialize $object $method $prefix] + } + + .object method deepSerialize {-ignoreVarsRE -ignore -map args} { + .resetPattern + set s [.new -childof [self] -volatile] + if {[info exists ignoreVarsRE]} {$s ignoreVarsRE $ignoreVarsRE} + if {[info exists ignore]} {$s ignore $ignore} + + foreach o $args { + append r [$s deepSerialize [$o]] } + if {[info exists map]} {return [string map $map $r]} + return $r } - set v [$o info instfilter -guards] - if {$v ne ""} {append cmd [my pcmd [list instfilter $v]] " \\\n"} - return $cmd\n + + # include Serializer in the serialized code + .exportObjects [self] + } + - 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 } + ########################################################################### + # Object System specific serializer + ########################################################################### + + Class create ObjectSystemSerializer { + + .method init {} { + # Include object system serializers in "Serializer all" + Serializer exportObjects [self] } - return $arglist - } - Serializer instproc category c { - if {[::xotcl::is $c type ::xotcl::Class]} {return Class} {return Object} - } - Serializer instproc allChildren o { - set set $o - foreach c [$o info children] { - eval lappend set [my allChildren $c] + + # + # Methods to be executed at the begin and end of serialize all + # + .method serialize-all-start {s} { + .getExported + return [.serializeExportedMethods $s] } - return $set - } - Serializer instproc allInstances C { - set set [$C info instances] - foreach sc [$C info subclass] { - eval lappend set [my allInstances $sc] + + .method serialize-all-end {s} { + set cmd "" + foreach o [list ${.rootClass} ${.rootMetaClass}] { + append cmd \ + [.frameWorkCmd ::xotcl::relation $o object-mixin] \ + [.frameWorkCmd ::xotcl::relation $o class-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o object-invar] \ + [.frameWorkCmd ::xotcl::assertion $o class-invar] + } + return $cmd } - return $set - } - Serializer instproc exportedObject o { - # check, whether o is exported. for exported objects. - # we export the object tree. - set oo $o - while {1} { - if {[[self class] exists exportObjects($o)]} { - #puts stderr "exported: $o -> exported $oo" - return 1 + + .method registerTrace {on} { + if {$on} { + ::xotcl::alias ${.rootClass} __trace__ -objscope ::trace + } else { + ::xotcl::method ${.rootClass} __trace__ {} {} } - # we do this for object trees without object-less name spaces - if {![my isobject $o]} {return 0} - set o [$o info parent] } - } - - Serializer instproc topoSort {set all} { - if {[array exists .s]} {array unset .s} - if {[array exists .level]} {array unset .level} - foreach c $set { - if {!$all && - [string match "::xotcl::*" $c] && - ![my exportedObject $c]} continue - if {[my exists skip($c)]} continue - my set s($c) 1 + + # + # Handle association between objects and responsible serializers + # + .method registerSerializer {s instances} { + # Communicate responsibility to serializer object $s + foreach i $instances { + if {![::xotcl::is $i type ${.rootClass}]} continue + $s setObjectSystemSerializer $i [self] + } } - set stratum 0 - while {1} { - set set [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 - } + + .method instances {s} { + # Compute all instances, for which we are responsible and + # notify serializer object $s + set instances [list] + foreach i [${.rootClass} info instances -closure] { + if {[.matchesIgnorePattern $i] && ![info exists .exportObjects($i)]} { + continue + } + $s setObjectSystemSerializer $i [self] + lappend instances $i } - if {[my set level($stratum)] eq ""} { - my set level($stratum) $set - my warn "Cyclic dependency in $set" + #$s warn "[self] handled instances: $instances" + return $instances + } + + .method getExported {} { + # + # get exported objects and methods from main Serializer for + # which this object specific serializer is responsible + # + foreach k [Serializer exportedMethods] { + foreach {o p m} $k break + if {[::xotcl::is $o type ${.rootClass}]} {set .exportMethods($k) 1} } - foreach i [my set level($stratum)] {my unset s($i)} + foreach o [Serializer exportedObjects] { + if {[::xotcl::is $o type ${.rootClass}]} {set .exportObjects($o) 1} + } + foreach p [array names .ignorePattern] {Serializer addPattern $p} } - } - Serializer instproc warn msg { - if {[info command ns_log] ne ""} { - ns_log Notice $msg - } else { - puts stderr "!!! $msg" + + + ############################### + # general method serialization + ############################### + + .method classify {o} { + if {[::xotcl::is $o type ${.rootMetaClass}]} \ + {return Class} {return Object} } - } - - Serializer instproc Class-needsNothing x { - if {![my Object-needsNothing $x]} {return 0} - set scs [$x info superclass] - if {[my needsOneOf $scs]} {return 0} - foreach sc $scs {if {[my needsOneOf [$sc info slots]]} {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 class] info slots]]} {return 0} - #if {[my needsOneOf [$x info mixin ]]} {return 0} - return 1 - } - Serializer instproc needsOneOf list { - foreach e $list {if {[my exists s($e)]} { - #upvar x x; puts stderr "$x needs $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 instvar post_cmds - set post_cmds "" - # register for introspection purposes "trace" under a different name - ::xotcl::alias ::xotcl::Object __trace__ -objscope ::trace - ::xotcl::alias ::xotcl2::Object __trace__ -objscope ::trace - my topoSort $list $all - #foreach i [lsort [array names .level]] {my warn "$i: [my set level($i)]"} - set result "" - foreach l [lsort -integer [array names .level]] { - foreach i [my set level($l)] { - #my warn "serialize $i" - #append result "# Stratum $l\n" - append result [my serialize $i] \n + + .method collectVars o { + set setcmd [list] + foreach v [lsort [$o info vars]] { + if {![.exists ignoreVarsRE] || ![regexp [set .ignoreVarsRE] ${o}::$v]} { + if {[$o eval [list ::array exists .$v]]} { + lappend setcmd [list array set .$v [$o eval [list array get .$v]]] + } else { + lappend setcmd [list set .$v [::xotcl::setinstvar $o $v]] + } + } } + return $setcmd } - foreach e $list { - set namespace($e) 1 - set namespace([namespace qualifiers $e]) 1 + + .method frameWorkCmd {cmd o relation -unless} { + set v [$cmd $o $relation] + if {$v eq ""} {return ""} + if {[info exists unless] && $v eq $unless} {return ""} + return [list $cmd $o $relation $v]\n } - ::xotcl::Object method __trace__ {} {} - ::xotcl2::Object method __trace__ {} {} - # Handling of variable traces: traces might require a - # different topological sort, which is hard to handle. - # Similar as with filters, we deactivate the variable - # traces during initialization. This happens by - # (1) replacing the XOTcl's trace method by a no-op - # (2) collecting variable traces through collect-var-traces - # (3) re-activating the traces after variable initialization + .method serializeExportedMethods {s} { + set r "" + foreach k [array names .exportMethods] { + foreach {o p m} $k break + if {![.methodExists $o $p $m]} { + $s warn "Method does not exists: $o $p $m" + continue + } + append methods($o) [.serializeExportedMethod $o $p $m] + } + foreach o [array names methods] {set ($o) 1} + foreach o [list ${.rootClass} ${.rootMetaClass}] { + if {[info exists ($o)]} {unset ($o)} + } + foreach o [concat ${.rootClass} ${.rootMetaClass} [array names ""]] { + if {![info exists methods($o)]} continue + append r \n $methods($o) + } + #puts stderr "[self] ... exportedMethods <$r\n>" + return "$r\n" + } - set exports "" - set pre_cmds "" + ############################### + # general object serialization + ############################### - # 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 pre_cmds "namespace eval $ns {}\n" - } elseif {$ns ne [namespace origin $ns] } { - append pre_cmds "namespace eval $ns {}\n" + .method serialize {objectOrClass s} { + .[.classify $objectOrClass]-serialize $objectOrClass $s + } + + .method matchesIgnorePattern {o} { + foreach p [array names .ignorePattern] { + if {[string match $p $o]} {return 1} } - set exp [namespace eval $ns {namespace export}] - if {$exp ne ""} { - append exports "namespace eval $ns {namespace export $exp}" \n + return 0 + } + + .method collect-var-traces {o s} { + foreach v [$o info vars] { + set t [$o __trace__ info variable $v] + if {$t ne ""} { + foreach ops $t { + foreach {op cmd} $ops break + # save traces in post_cmds + $s addPostCmd [list $o trace add variable $v $op $cmd] + + # remove trace from object + $o trace remove variable $v $op $cmd + } + } } } - #append post_cmds "::xotcl::alias ::xotcl::Object trace -objscope ::trace\n" - return $pre_cmds$result$post_cmds$exports + ############################### + # general dependency handling + ############################### + + .method needsNothing {x s} { + return [.[.classify $x]-needsNothing $x $s] + } + + .method Class-needsNothing {x s} { + if {![.Object-needsNothing $x $s]} {return 0} + set scs [$x info superclass] + if {[$s needsOneOf $scs]} {return 0} + foreach sc $scs {if {[$s needsOneOf [$sc info slots]]} {return 0}} + return 1 + } + + .method Object-needsNothing {x s} { + set p [$x info parent] + if {$p ne "::" && [$s needsOneOf $p]} {return 0} + if {[$s needsOneOf [$x info class]]} {return 0} + if {[$s needsOneOf [[$x info class] info slots]]} {return 0} + return 1 + } + } - 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 methods -nocmd $name] ne ""} { - set code [my method-serialize $object $name ""] - } + + ########################################################################### + # XOTcl 2 specific serializer + ########################################################################### + + ObjectSystemSerializer create Serializer2 { + + set .rootClass ::xotcl2::Object + set .rootMetaClass ::xotcl2::Class + array set .ignorePattern [list "::xotcl2::*" 1 "::xotcl::*" 1] + + ############################### + # XOTcl 2 method serialization + ############################### + + .method methodExists {object kind name} { + expr {[$object info method type $name] != ""} + } + + .method serializeExportedMethod {object kind name} { + # todo: object modifier is missing + return [.method-serialize $object $name ""] + } + + .method method-serialize {o m modifier} { + if {![::xotcl::is $o class]} {set modifier ""} + return [$o {*}$modifier info method definition $m] + } + + ############################### + # XOTcl 2 object serialization + ############################### + + .method Object-serialize {o s} { + .collect-var-traces $o $s + append cmd [list [$o info class] create \ + [::xotcl::dispatch $o -objscope ::xotcl::self]] + + append cmd " -noinit\n" + foreach i [lsort [::xotcl::cmd::ObjectInfo::methods $o]] { + append cmd [.method-serialize $o $i "object"] "\n" } - instproc { - if {[$object info instprocs $name] ne ""} { - set code [my method-serialize $object $name inst] - } + append cmd \ + [list $o eval [join [.collectVars $o] "\n "]]\n \ + [.frameWorkCmd ::xotcl::relation $o object-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o object-invar] + + if {[::xotcl::is $o type ::xotcl::Slot]} { + # Slots needs to be initialized to ensure + # __invalidateobjectparameter to be called + append cmd [list $o init] \n } - forward - instforward { - if {[$object info $kind $name] ne ""} { - set fwd [concat [list $kind $name] [$object info $kind -definition $name]] - set code [my pcmd $fwd] - } + + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o object-filter] + return $cmd + } + + ############################### + # XOTcl 2 class serialization + ############################### + + .method Class-serialize {o s} { + + set cmd [.Object-serialize $o $s] + foreach i [lsort [::xotcl::cmd::ClassInfo::methods $o]] { + append cmd [.method-serialize $o $i ""] "\n" } + append cmd \ + [.frameWorkCmd ::xotcl::relation $o superclass -unless ${.rootClass}] \ + [.frameWorkCmd ::xotcl::relation $o class-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o class-invar] + + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o class-filter] + return $cmd\n } - return $code - } - - Serializer proc exportMethods list { - foreach {o p m} $list {my set exportMethods($o,$p,$m) 1} + # register serialize a global method + ::xotcl2::Object method serialize {} { + ::Serializer deepSerialize [self] + } + } - Serializer proc exportObjects list { - foreach o $list {my set exportObjects($o) 1} - } - Serializer proc serializeExportedMethods {s} { - set r "" - foreach k [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 " + + + ########################################################################### + # XOTcl 1 specific serializer + ########################################################################### + + ObjectSystemSerializer create Serializer1 { + + set .rootClass ::xotcl::Object + set .rootMetaClass ::xotcl::Class + array set .ignorePattern [list "::xotcl::*" 1] + + .method serialize-all-start {s} { + return "::xotcl::Object instproc trace args {}\n[next]" } - 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] + + .method serialize-all-end {s} { + return "[next]\n::xotcl::alias ::xotcl::Object trace -objscope ::trace\n" } - 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 "] + + + ############################### + # XOTcl 1 method serialization + ############################### + + .method methodExists {object kind name} { + switch $kind { + proc - instproc { + return [expr {[$object info ${kind}s $name] ne ""}] + } + forward - instforward { + return [expr {[$object info ${kind} $name] ne ""}] + } + } } - #puts stderr "... exportedMethods <$r\n>" - return "$r\n" - } - Serializer proc all {args} { - # don't filter anything during serialization - 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] - ::xotcl::Object instproc trace args {} - ::xotcl::Slot instmixin add ::xotcl::Slot::Nocheck - } - append r "::xotcl::configure softrecreate [::xotcl::configure softrecreate]" - append r \n [my serializeExportedMethods $s] - # export the objects and classes - #$s warn "export objects = [array names .exportObjects]" - #$s warn "export objects = [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" - } + .method serializeExportedMethod {object kind name} { + set code "" + switch $kind { + proc - instproc { + if {[$object info ${kind}s $name] ne ""} { + set code [.method-serialize $object $name ""] + } + } + forward - instforward { + if {[$object info $kind $name] ne ""} { + set code [list $kind $name [$object info $kind -definition $name]] + } + } } + return $code } - append r { - ::xotcl::alias ::xotcl::Object trace -objscope ::trace - ::xotcl::Slot instmixin delete ::xotcl::Slot::Nocheck - ::xotcl::configure filter $::xotcl::__filterstate - unset ::xotcl::__filterstate + + .method 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 $o ${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 } - ::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] - foreach o [eval $s configure $args] { - append r [$s deepSerialize [$o]] + + ############################### + # XOTcl 1 object serialization + ############################### + + .method Object-serialize {o s} { + .collect-var-traces $o $s + append cmd [list [$o info class] create [::xotcl::dispatch $o -objscope ::xotcl::self]] + # slots needs to be initialized when optimized, since + # parametercmds are not serialized + append cmd " -noinit\n" + foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype scripted] { + append cmd [.method-serialize $o $i ""] "\n" + } + foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype forward] { + append cmd [concat [list $o] forward $i [$o info forward -definition $i]] "\n" + } + foreach i [::xotcl::cmd::ObjectInfo::methods $o -methodtype setter] { + append cmd [list $o parametercmd $i] "\n" + } + append cmd \ + [list $o eval [join [.collectVars $o] "\n "]] \n \ + [.frameWorkCmd ::xotcl::relation $o object-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o object-invar] + + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o object-filter] + + return $cmd } - if {[$s exists map]} {return [string map [$s map] $r]} - return $r - } - # register serialize a global method - ::xotcl::Object instproc serialize {} { - ::Serializer deepSerialize [self] - } + ############################### + # XOTcl 1 class serialization + ############################### + + .method Class-serialize {o s} { + set cmd [.Object-serialize $o $s] + foreach i [$o info instprocs] { + append cmd [.method-serialize $o $i inst] "\n" + } + foreach i [$o info instforward] { + append cmd [concat [list $o] instforward $i [$o info instforward -definition $i]] "\n" + } + foreach i [$o info instparametercmd] { + append cmd [list $o instparametercmd $i] "\n" + } + append cmd \ + [.frameWorkCmd ::xotcl::relation $o superclass -unless ${.rootClass}] \ + [.frameWorkCmd ::xotcl::relation $o class-mixin] \ + [.frameWorkCmd ::xotcl::assertion $o class-invar] - # include this method in the serialized code - Serializer exportMethods { - ::xotcl::Object instproc contains + $s addPostCmd [.frameWorkCmd ::xotcl::relation $o class-filter] + return $cmd + } + + # register serialize a global method for xotcl1 + ::xotcl::Object instproc serialize {} { + ::Serializer deepSerialize [self] + } + + # include this method in the serialized code + #Serializer exportMethods { + # ::xotcl::Object instproc contains + #} } - # include Serializer in the serialized code - Serializer exportObjects [namespace current]::Serializer + namespace export Serializer namespace eval :: "namespace import -force [namespace current]::*" }