# $Id: Serializer.xotcl,v 1.19 2007/10/05 09:06:00 neumann Exp $ package require XOTcl package provide xotcl::serializer 1.0 # For the time being, we require classical XOTcl. # TODO: separate into two packages (i.e. make one XOTcl specific # serializer package, and (a) load this package on a load of this # package (when ::xotcl::Object is defined), and (b) load it from # "xotcl1.tcl", when the serializer is alreaded loaded. namespace eval ::xotcl::serializer { namespace import ::nx::* @ @File { description { This package provides the class Serializer, which can be used to generate a snapshot of the current state of the workspace in the form of XOTcl source code. } authors { Gustaf Neumann, Gustaf.Neumann@wu-wien.ac.at } date { $Date: 2007/10/05 09:06:00 $ } } @ 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" } @ Serializer proc deepSerialize { ?-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" objs "Objects to be serialized" } { 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 -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 -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 -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. } 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} } ########################################################################### # Serializer Class, independent from Object System ########################################################################### Class create Serializer -parameter {ignoreVarsRE} { :method ignore args { # Ignore the objects passed via args. # :skip is used for filtering only in the topological sort. foreach element $args { foreach o [Serializer allChildren $element] { set :skip($o) 1 } } } :method init {} { # Never serialize the (volatile) serializer object :ignore [self] } :method warn msg { if {[info command ns_log] ne ""} { ns_log Notice $msg } else { puts stderr "!!! $msg" } } :method addPostCmd {cmd} { if {$cmd ne ""} {append :post_cmds $cmd "\n"} } :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] } } :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)} } } :method needsOneOf list { foreach e $list {if {[info exists :s($e)]} {return 1}} return 0 } :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 } :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 } ############################### # class object specfic methods ############################### :object method allChildren o { # return o and all its children fully qualified set set [::nx::core::dispatch $o -objscope ::xotcl::self] foreach c [$o info children] { lappend set {*}[:allChildren $c] } return $set } :object method exportMethods list { foreach {o p m} $list {set :exportMethods([list $o $p $m]) 1} } :object method exportObjects list { foreach o $list {set :exportObjects($o) 1} } :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" } } } :object method checkExportedObject {} { foreach o [array names :exportObjects] { if {![::xotcl::is $o object]} { puts stderr "Serializer exportObject: ignore non-existing object $o" unset :exportObjects($o) } else { # add all child objects foreach o [:allChildren $element] { set :exportObjects($o) 1 } } } } :object method all {-ignoreVarsRE -ignore} { # don't filter anything during serialization set filterstate [::nx::core::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 \[::nx::core::configure filter off\] #::xotcl::Slot mixin add ::xotcl::Slot::Nocheck ::nx::core::configure softrecreate [::nx::core::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 ::nx::core::configure filter $::xotcl::__filterstate unset ::xotcl::__filterstate } ::nx::core::configure filter $filterstate return $r } :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 } # include Serializer in the serialized code :exportObjects [self] } ########################################################################### # Object System specific serializer ########################################################################### Class create ObjectSystemSerializer { :method init {} { # Include object system serializers and the meta-class in "Serializer all" Serializer exportObjects [self class] Serializer exportObjects [self] } # # Methods to be executed at the begin and end of serialize all # :method serialize-all-start {s} { :getExported return [:serializeExportedMethods $s] } :method serialize-all-end {s} { set cmd "" foreach o [list ${:rootClass} ${:rootMetaClass}] { append cmd \ [:frameWorkCmd ::nx::core::relation $o object-mixin] \ [:frameWorkCmd ::nx::core::relation $o class-mixin] \ [:frameWorkCmd ::nx::core::assertion $o object-invar] \ [:frameWorkCmd ::nx::core::assertion $o class-invar] } return $cmd } :method registerTrace {on} { if {$on} { ::nx::core::alias ${:rootClass} __trace__ -objscope ::trace } else { ::nx::core::method ${:rootClass} __trace__ {} {} } } # # 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] } } :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 } #$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 o [Serializer exportedObjects] { if {[::xotcl::is $o type ${:rootClass}]} {set :exportObjects($o) 1} } foreach p [array names :ignorePattern] {Serializer addPattern $p} } ############################### # general method serialization ############################### :method classify {o} { if {[::xotcl::is $o type ${:rootMetaClass}]} \ {return Class} {return Object} } :method collectVars o { set setcmd [list] foreach v [lsort [$o info vars]] { if {![info 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 [::nx::core::setvar $o $v]] } } } return $setcmd } :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 } :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 exist: $o $p $m" continue } append methods($o) [:serializeExportedMethod $o $p $m]\n } 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" } ############################### # general object serialization ############################### :method serialize {objectOrClass s} { :[:classify $objectOrClass]-serialize $objectOrClass $s } :method matchesIgnorePattern {o} { foreach p [array names :ignorePattern] { if {[string match $p $o]} {return 1} } 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 } } } } ############################### # 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} if {[$s needsOneOf [::nx::core::relation $x class-mixin]]} {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 } } ########################################################################### # next specific serializer ########################################################################### ObjectSystemSerializer create Serializer2 { set :rootClass ::nx::Object set :rootMetaClass ::nx::Class array set :ignorePattern [list "::nx::*" 1 "::xotcl::*" 1] :method serialize-all-start {s} { if {[info command ::Object] ne "" && [namespace origin ::Object] eq "::nx::Object"} { set intro "package require next; namespace import -force ::nx::*" } else { set intro "" } return "$intro\n[next]" } ############################### # next 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] } ############################### # next object serialization ############################### :method Object-serialize {o s} { :collect-var-traces $o $s append cmd [list [$o info class] create \ [::nx::core::dispatch $o -objscope ::xotcl::self]] append cmd " -noinit\n" foreach i [lsort [::nx::core::cmd::ObjectInfo::methods $o]] { append cmd [:method-serialize $o $i "object"] "\n" } append cmd \ [list $o eval [join [:collectVars $o] "\n "]]\n \ [:frameWorkCmd ::nx::core::relation $o object-mixin] \ [:frameWorkCmd ::nx::core::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 eval :init] \n } $s addPostCmd [:frameWorkCmd ::nx::core::relation $o object-filter] return $cmd } ############################### # next class serialization ############################### :method Class-serialize {o s} { set cmd [:Object-serialize $o $s] foreach i [lsort [::nx::core::cmd::ClassInfo::methods $o]] { append cmd [:method-serialize $o $i ""] "\n" } append cmd \ [:frameWorkCmd ::nx::core::relation $o superclass -unless ${:rootClass}] \ [:frameWorkCmd ::nx::core::relation $o class-mixin] \ [:frameWorkCmd ::nx::core::assertion $o class-invar] $s addPostCmd [:frameWorkCmd ::nx::core::relation $o class-filter] return $cmd\n } # register serialize a global method ::nx::Object method serialize {} { ::Serializer deepSerialize [self] } } ########################################################################### # XOTcl specific serializer ########################################################################### ObjectSystemSerializer create Serializer1 { set :rootClass ::xotcl::Object set :rootMetaClass ::xotcl::Class array set :ignorePattern [list "::xotcl::*" 1] :method serialize-all-start {s} { set intro "package require XOTcl" if {[info command ::Object] ne "" && [namespace origin ::Object] eq "::xotcl::Object"} { set intro "namespace import -force ::xotcl::*" } return "$intro\n::xotcl::Object instproc trace args {}\n[next]" } :method serialize-all-end {s} { return "[next]\n::nx::core::alias ::xotcl::Object trace -objscope ::trace\n" } ############################### # XOTcl 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 ""}] } } } :method serializeExportedMethod {object kind name} { set code "" switch $kind { proc - instproc { if {[$object info ${kind}s $name] ne ""} { set prefix [expr {$kind eq "proc" ? "" : "inst"}] set code [:method-serialize $object $name $prefix]\n } } forward - instforward { if {[$object info $kind $name] ne ""} { set code [concat [list $object] $kind $name [$object info $kind -definition $name]]\n } } } return $code } :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 object serialization ############################### :method Object-serialize {o s} { :collect-var-traces $o $s append cmd [list [$o info class] create [::nx::core::dispatch $o -objscope ::xotcl::self]] # slots needs to be initialized when optimized, since # parametercmds are not serialized append cmd " -noinit\n" foreach i [::nx::core::cmd::ObjectInfo::methods $o -methodtype scripted] { append cmd [:method-serialize $o $i ""] "\n" } foreach i [::nx::core::cmd::ObjectInfo::methods $o -methodtype forward] { append cmd [concat [list $o] forward $i [$o info forward -definition $i]] "\n" } foreach i [::nx::core::cmd::ObjectInfo::methods $o -methodtype setter] { append cmd [list $o parametercmd $i] "\n" } append cmd \ [list $o eval [join [:collectVars $o] "\n "]] \n \ [:frameWorkCmd ::nx::core::relation $o object-mixin] \ [:frameWorkCmd ::nx::core::assertion $o object-invar] $s addPostCmd [:frameWorkCmd ::nx::core::relation $o object-filter] return $cmd } ############################### # XOTcl 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" } # provide limited support for exporting aliases for XOTcl objects foreach i [::nx::core::cmd::ClassInfo::methods $o -methodtype alias] { set xotcl2Def [::nx::core::cmd::ClassInfo::method $o definition $i] set objscope [lindex $xotcl2Def end-2] set methodName [lindex $xotcl2Def end-1] set cmdName [lindex $xotcl2Def end] if {$objscope ne "-objscope"} {set objscope ""} append cmd [list ::nx::core::alias $o $methodName {*}$objscope $cmdName]\n } append cmd \ [:frameWorkCmd ::nx::core::relation $o superclass -unless ${:rootClass}] \ [:frameWorkCmd ::nx::core::relation $o class-mixin] \ [:frameWorkCmd ::nx::core::assertion $o class-invar] $s addPostCmd [:frameWorkCmd ::nx::core::relation $o class-filter] return $cmd } # register serialize a global method for XOTcl ::xotcl::Object instproc serialize {} { ::Serializer deepSerialize [self] } # include this method in the serialized code #Serializer exportMethods { # ::xotcl::Object instproc contains #} } namespace export Serializer namespace eval :: "namespace import -force [namespace current]::*" }