Index: generic/aol-xotcl.tcl =================================================================== diff -u -r00e168b160c8ad9d3785b0f32972577ac980c73a -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- generic/aol-xotcl.tcl (.../aol-xotcl.tcl) (revision 00e168b160c8ad9d3785b0f32972577ac980c73a) +++ generic/aol-xotcl.tcl (.../aol-xotcl.tcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -7,7 +7,7 @@ # package require XOTcl; namespace import -force ::xotcl::* -package require xotcl::serializer +package require nx::serializer ns_log notice "XOTcl version $::xotcl::version$::xotcl::patchlevel loaded" # @@ -22,7 +22,7 @@ set nslist "" _ns_getnamespaces namespaces foreach n $namespaces { - if {[string match "::xotcl*" $n] == 0 + if {[string match "::nx*" $n] == 0 && ([catch {::xotcl::objectproperty $n object} ret] || $ret == 0)} { lappend nslist $n } Index: library/lib/pkgIndex.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -8,7 +8,7 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded XOTcl 2.0 [list source [file join $dir xotcl.tcl]] +package ifneeded XOTcl 2.0 [list source [file join $dir xotcl2.tcl]] package ifneeded nx::doc 0.1 [list source [file join $dir doc-tools.xotcl]] package ifneeded nx::test 1.0 [list source [file join $dir test.tcl]] package ifneeded xotcl::htmllib 0.1 [list source [file join $dir htmllib.xotcl]] Fisheye: Tag 183ec0e7c071586238bf5ed90a05dbbda91d4582 refers to a dead (removed) revision in file `library/lib/xotcl.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: library/lib/xotcl2.tcl =================================================================== diff -u --- library/lib/xotcl2.tcl (revision 0) +++ library/lib/xotcl2.tcl (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -0,0 +1,812 @@ +package provide XOTcl 2.0 +package require nx +####################################################### +# Classical ::xotcl* +####################################################### +namespace eval ::xotcl { + # + # Set XOTcl version variables + # + set ::xotcl::version 2.0 + set ::xotcl::patchlevel .0 + + # + # Perform the basic setup of XOTcl. First, let us allocate the + # basic classes of XOTcl. This call creates the classes + # ::xotcl::Object and ::xotcl::Class and defines these as root class + # of the object system and as root meta class. + # + ::nx::core::createobjectsystem ::xotcl::Object ::xotcl::Class { + -class.alloc alloc + -class.create create + -class.dealloc dealloc + -class.recreate recreate + -class.requireobject __unknown + -object.configure configure + -object.cleanup cleanup + -object.defaultmethod defaultmethod + -object.destroy destroy + -object.init init + -object.move move + -object.objectparameter objectparameter + -object.residualargs residualargs + -object.unknown unknown + } + + # + # create ::nx and ::nx::core namespaces, otherwise mk_pkgindex will fail + # + namespace eval ::nx {} + namespace eval ::nx::core {} + + # + # get frequenly used primitiva into the ::xotcl namespace + # + namespace import ::nx::core::* + namespace import ::nx::Attribute + + # provide the standard command set for ::xotcl::Object + foreach cmd [info command ::nx::core::cmd::Object::*] { + set cmdName [namespace tail $cmd] + if {$cmdName in [list "filtersearch" "setter"]} continue + ::nx::core::alias Object $cmdName $cmd + } + + # provide some Tcl-commands as methods for ::xotcl::Object + foreach cmd {array append eval incr lappend set subst unset trace} { + ::nx::core::alias Object $cmd -objscope ::$cmd + } + + # provide the standard command set for ::xotcl::Class + foreach cmd [info command ::nx::core::cmd::Class::*] { + set cmdName [namespace tail $cmd] + if {$cmdName in [list "setter"]} continue + ::nx::core::alias Class $cmdName $cmd + } + + # protect some methods against redefinition + ::nx::core::methodproperty Object destroy redefine-protected true + ::nx::core::methodproperty Class alloc redefine-protected true + ::nx::core::methodproperty Class dealloc redefine-protected true + ::nx::core::methodproperty Class create redefine-protected true + + # define instproc and proc + ::nx::core::method Class instproc { + name arguments body precondition:optional postcondition:optional + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::nx::core::method [self] $name $arguments $body {*}$conditions + } + + ::nx::core::method Object proc { + name arguments body precondition:optional postcondition:optional + } { + set conditions [list] + if {[info exists precondition]} {lappend conditions -precondition $precondition} + if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} + ::nx::core::method [self] -per-object $name $arguments $body {*}$conditions + } + + # define - like in XOTcl 1 - a minimal implementation of "method" + Object instproc method {name arguments body} { + :proc $name $arguments $body + } + Class instproc method {-per-object:switch name arguments body} { + if {${per-object}} { + :proc $name $arguments $body + } else { + :instproc $name $arguments $body + } + } + + # define forward methods + ::nx::core::forward Object forward ::nx::core::forward %self -per-object + ::nx::core::forward Class instforward ::nx::core::forward %self + + Class instproc unknown {args} { + #puts stderr "use '[self] create $args', not '[self] $args'" + uplevel [list [self] create {*}$args] + } + + Object instproc unknown {m args} { + if {![self isnext]} { + error "[self]: unable to dispatch method '$m'" + } + } + + # "init" must exist on Object. per default it is empty. + Object instproc init args {} + + Object instproc self {} {::xotcl::self} + + # + # object-parameter definition, backwards compatible + # + ::xotcl::Object instproc objectparameter {} { + set parameterdefinitions [::nx::core::parametersFromSlots [self]] + lappend parameterdefinitions args + #puts stderr "*** parameter definition for [self]: $parameterdefinitions" + return $parameterdefinitions + } + + # + # Use parameter definition from next + # (same with classInfo parameter, see below) + ::nx::core::alias ::xotcl::Class parameter ::nx::core::classes::nx::Class::parameter + + # We provide a default value for superclass (when no superclass is + # specified explicitely) and metaclass, in case they should differ + # from the root classes of the object system. + + ::xotcl::Class parameter { + {__default_superclass ::xotcl::Object} + {__default_metaclass ::xotcl::Class} + } + + ############################################ + # system slots + ############################################ + proc register_system_slots {os} { + # We need explicit ::xotcl prefixes, since they are always skipped + # if not specified + ${os}::Object alloc ${os}::Class::slot + ${os}::Object alloc ${os}::Object::slot + + ::nx::RelationSlot create ${os}::Class::slot::superclass + ::nx::core::alias ${os}::Class::slot::superclass assign ::nx::core::relation + ::nx::RelationSlot create ${os}::Object::slot::class -multivalued false + ::nx::core::alias ${os}::Object::slot::class assign ::nx::core::relation + + ::nx::RelationSlot create ${os}::Object::slot::mixin \ + -methodname object-mixin + ::nx::RelationSlot create ${os}::Object::slot::filter \ + -methodname object-filter \ + -elementtype "" + + ::nx::RelationSlot create ${os}::Class::slot::instmixin \ + -methodname class-mixin + ::nx::RelationSlot create ${os}::Class::slot::instfilter \ + -methodname class-filter \ + -elementtype "" + } + register_system_slots ::xotcl + proc ::xotcl::register_system_slots {} {} + + ######################## + # Info definition + ######################## + Object create ::xotcl::objectInfo + Object create ::xotcl::classInfo + + # note, we are using ::xotcl::infoError defined earlier + Object instforward info -onerror ::nx::core::infoError ::xotcl::objectInfo %1 {%@2 %self} + Class instforward info -onerror ::nx::core::infoError ::xotcl::classInfo %1 {%@2 %self} + + objectInfo proc info {obj} { + set methods [list] + foreach m [::info commands ::xotcl::objectInfo::*] { + set name [namespace tail $m] + if {$name eq "unknown"} continue + lappend methods $name + } + return "valid options are: [join [lsort $methods] {, }]" + } + objectInfo proc unknown {method args} { + error "[::xotcl::self] unknown info option \"$method\"; [:info info]" + } + + classInfo proc info {cl} { + set methods [list] + foreach m [::info commands ::xotcl::classInfo::*] { + set name [namespace tail $m] + if {$name eq "unknown"} continue + lappend methods $name + } + return "valid options are: [join [lsort $methods] {, }]" + } + + classInfo proc unknown {method args} { + error "[::xotcl::self] unknown info option \"$method\"; [:info info]" + } + + # + # Backward compatibility info subcommands; + # + # TODO: should go finally into a library. + # + # Obsolete methods + # + # already emulated: + # + # => info -per-object method parameter .... replaces + # info instargs + # info instnonposargs + # info instdefault + # + # => info method .... replaces + # info body + # info instbody + # + # => info methods .... replaces + # info commands + # info instcommands + # info procs + # info instprocs + # info parametercmd + # info instparametercmd + # + # => info is (resp. ::xotcl::is) replaces + # info isobject + # info isclass + # info ismetaclass + # info ismixin + # info istype + # + # => info method .... replaces + # proc + # instproc + # info args + # info nonposargs + # info default + # + # TODO mark all absolete calls at least as deprecated in library + # + + proc ::xotcl::info_args {allocation o method} { + set result [list] + foreach \ + argName [::nx::core::cmd::${allocation}Info::method $o args $method] \ + flag [::nx::core::cmd::${allocation}Info::method $o parameter $method] { + if {[string match -* $flag]} continue + lappend result $argName + } + #puts stderr "+++ get ${inst}args for $o $method => $result" + return $result + } + + proc ::xotcl::info_nonposargs {allocation o method} { + set result [list] + foreach flag [::nx::core::cmd::${allocation}Info::method $o parameter $method] { + if {![string match -* $flag]} continue + lappend result $flag + } + #puts stderr "+++ get ${inst}nonposargs for $o $method => $result" + return $result + } + proc ::xotcl::info_default {allocation o method arg varName} { + foreach \ + argName [::nx::core::cmd::${allocation}Info::method $o args $method] \ + flag [::nx::core::cmd::${allocation}Info::method $o parameter $method] { + if {$argName eq $arg} { + upvar 3 $varName default + if {[llength $flag] == 2} { + set default [lindex $flag 1] + #puts stderr "--- get ${inst}default for $o $method $arg => $default" + return 1 + } + #puts stderr "--- get ${inst}default for $o $method $arg fails" + set default "" + return 0 + } + } + error "procedure \"$method\" doesn't have an argument \"$varName\"" + } + + classInfo eval { + :proc instargs {o method} {::xotcl::info_args Class $o $method} + :proc args {o method} {::xotcl::info_args Object $o $method} + :proc instnonposargs {o method} {::xotcl::info_nonposargs Class $o $method} + :proc nonposargs {o method} {::xotcl::info_nonposargs Object $o $method} + :proc instdefault {o method arg var} {::xotcl::info_default Class $o $method $arg $var} + :proc default {o method arg var} {::xotcl::info_default Object $o $method $arg $var} + + # info options emulated by "info method ..." + :proc instbody {o methodName} {::nx::core::cmd::ClassInfo::method $o body $methodName} + :proc instpre {o methodName} {::nx::core::cmd::ClassInfo::method $o precondition $methodName} + :proc instpost {o methodName} {::nx::core::cmd::ClassInfo::method $o postcondition $methodName} + + # info options emulated by "info methods" + :proc instcommands {o {pattern:optional ""}} { + ::nx::core::cmd::ClassInfo::methods $o {*}$pattern + } + :proc instprocs {o {pattern:optional ""}} { + ::nx::core::cmd::ClassInfo::methods $o -methodtype scripted {*}$pattern + } + :proc parametercmd {o {pattern:optional ""}} { + ::nx::core::cmd::ClassInfo::methods $o -per-object -methodtype setter {*}$pattern + } + :proc instparametercmd {o {pattern:optional ""}} { + ::nx::core::cmd::ClassInfo::methods $o -methodtype setter {*}$pattern + } + # assertion handling + :proc instinvar {o} {::nx::core::assertion $o class-invar} + } + + objectInfo eval { + :proc args {o method} {::xotcl::info_args Object $o $method} + :proc nonposargs {o method} {::xotcl::info_nonposargs Object $o $method} + :proc default {o method arg var} {::xotcl::info_default Object $o $method $arg $var} + + # info options emulated by "info method ..." + :proc body {o methodName} {::nx::core::cmd::ObjectInfo::method $o body $methodName} + :proc pre {o methodName} {::nx::core::cmd::ObjectInfo::method $o pre $methodName} + :proc post {o methodName} {::nx::core::cmd::ObjectInfo::method $o post $methodName} + + # info options emulated by "info methods" + :proc commands {o {pattern:optional ""}} { + ::nx::core::cmd::ObjectInfo::methods $o {*}$pattern + } + :proc procs {o {pattern:optional ""}} { + ::nx::core::cmd::ObjectInfo::methods $o -methodtype scripted {*}$pattern + } + :proc methods { + o -nocmds:switch -noprocs:switch -incontext:switch pattern:optional + } { + set methodtype all + if {$nocmds} {set methodtype scripted} + if {$noprocs} {if {$nocmds} {return ""}; set methodtype builtin} + set cmd [list ::nx::core::cmd::ObjectInfo::callable $o -methodtype $methodtype] + if {$incontext} {lappend cmd -incontext} + if {[info exists pattern]} {lappend cmd $pattern} + eval $cmd + } + # object filter mapping + :proc filter {o -order:switch -guards:switch pattern:optional} { + set guardsFlag [expr {$guards ? "-guards" : ""}] + set patternArg [expr {[info exists pattern] ? [list $pattern] : ""}] + if {$order && !$guards} { + set def [::nx::core::cmd::ObjectInfo::filter $o -order {*}$guardsFlag {*}$patternArg] + #puts stderr "TO CONVERT: $def" + set def [filterorder_list_to_xotcl1 $def] + } else { + set def [::nx::core::cmd::ObjectInfo::filter $o {*}$guardsFlag {*}$patternArg] + } + #puts stderr " => $def" + return $def + } + # assertion handling + :proc check {o} { + ::xotcl::checkoption_internal_to_xotcl1 [::nx::core::assertion $o check] + } + :proc invar {o} {::nx::core::assertion $o object-invar} + } + + foreach cmd [::info command ::nx::core::cmd::ObjectInfo::*] { + set cmdName [namespace tail $cmd] + if {$cmdName in [list "callable" "filter" "method" "methods"]} continue + ::nx::core::alias ::xotcl::objectInfo $cmdName $cmd + ::nx::core::alias ::xotcl::classInfo $cmdName $cmd + } + + foreach cmd [::info command ::nx::core::cmd::ClassInfo::*] { + set cmdName [namespace tail $cmd] + if {$cmdName in [list "forward" "method" "methods" \ + "mixinof" "object-mixin-of" \ + "filter" "filterguard" \ + "mixin" "mixinguard"]} continue + ::nx::core::alias ::xotcl::classInfo $cmdName $cmd + } + + ::nx::core::alias ::xotcl::objectInfo is ::nx::core::objectproperty + ::nx::core::alias ::xotcl::classInfo is ::nx::core::objectproperty + ::nx::core::alias ::xotcl::classInfo classparent ::nx::core::cmd::ObjectInfo::parent + ::nx::core::alias ::xotcl::classInfo classchildren ::nx::core::cmd::ObjectInfo::children + ::nx::core::alias ::xotcl::classInfo instmixin ::nx::core::cmd::ClassInfo::mixin + ::nx::core::alias ::xotcl::classInfo instmixinguard ::nx::core::cmd::ClassInfo::mixinguard + #::nx::core::alias ::xotcl::classInfo instmixinof ::nx::core::cmd::ClassInfo::class-mixin-of + ::nx::core::forward ::xotcl::classInfo instmixinof ::nx::core::cmd::ClassInfo::mixinof %1 -scope class + ::nx::core::alias ::xotcl::classInfo instfilter ::nx::core::cmd::ClassInfo::filter + ::nx::core::alias ::xotcl::classInfo instfilterguard ::nx::core::cmd::ClassInfo::filterguard + ::nx::core::alias ::xotcl::classInfo instforward ::nx::core::cmd::ClassInfo::forward + #::nx::core::alias ::xotcl::classInfo mixinof ::nx::core::cmd::ClassInfo::object-mixin-of + ::nx::core::forward ::xotcl::classInfo mixinof ::nx::core::cmd::ClassInfo::mixinof %1 -scope object + ::nx::core::alias ::xotcl::classInfo parameter ::nx::classInfo::parameter + + # assertion handling + ::nx::core::alias ::xotcl::classInfo invar objectInfo::invar + ::nx::core::alias ::xotcl::classInfo check objectInfo::check + + # define info methods from objectInfo on classInfo as well + ::nx::core::alias classInfo body objectInfo::body + ::nx::core::alias classInfo commands objectInfo::commands + ::nx::core::alias classInfo filter objectInfo::filter + ::nx::core::alias classInfo methods objectInfo::methods + ::nx::core::alias classInfo procs objectInfo::procs + ::nx::core::alias classInfo pre objectInfo::pre + ::nx::core::alias classInfo post objectInfo::post + + # emulation of isobject, isclass ... + Object instproc isobject {{object:substdefault "[self]"}} {::nx::core::objectproperty $object object} + Object instproc isclass {{class:substdefault "[self]"}} {::nx::core::objectproperty $class class} + Object instproc ismetaclass {{class:substdefault "[self]"}} {::nx::core::objectproperty $class metaclass} + Object instproc ismixin {class} {::nx::core::is [self] object -hasmixin $class} + Object instproc istype {class} {::nx::core::is [self] type $class} + + ::nx::core::alias Object contains ::nx::core::classes::nx::Object::contains + ::xotcl::Class instforward slots %self contains \ + -object {%::nx::core::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot} + # + # define parametercmd and instparametercmd in terms of ::nx method setter + # define filterguard and instfilterguard in terms of filterguard + # define mixinguard and instmixinguard in terms of mixinguard + # + ::nx::core::alias Object parametercmd ::nx::core::classes::nx::Object::setter + ::nx::core::alias Class instparametercmd ::nx::core::classes::nx::Class::setter + + ::nx::core::alias Class filterguard ::nx::core::cmd::Object::filterguard + ::nx::core::alias Class instfilterguard ::nx::core::cmd::Class::filterguard + + ::nx::core::alias Class mixinguard ::nx::core::cmd::Object::mixinguard + ::nx::core::alias Class instmixinguard ::nx::core::cmd::Class::mixinguard + + # assertion handling + proc checkoption_xotcl1_to_internal checkoptions { + set options [list] + foreach option $checkoptions { + if {$option eq "invar"} { + lappend options "object-invar" + } elseif {$option eq "instinvar"} { + lappend options "class-invar" + } else { + lappend options $option + } + } + return $options + } + proc checkoption_internal_to_xotcl1 checkoptions { + set options [list] + foreach option $checkoptions { + if {$option eq "object-invar"} { + lappend options "invar" + } elseif {$option eq "class-invar"} { + lappend options "instinvar" + } else { + lappend options $option + } + } + return $options + } + proc filterorder_list_to_xotcl1 definitions { + set defs [list] + foreach def $definitions {lappend defs [filterorder_to_xotcl1 $def]} + return $defs + } + proc filterorder_to_xotcl1 definition { + if {$definition ne ""} { + set modifier [lindex $definition 1] + if {$modifier eq "object"} { + set prefix "" + set kind [lindex $definition 2] + set name [lindex $definition 3] + } else { + set prefix "inst" + set kind $modifier + set name [lindex $definition 2] + } + if {$kind eq "method"} { + set kind proc + } elseif {$kind eq "setter"} { + set kind parametercmd + } + set definition [list [lindex $definition 0] ${prefix}$kind $name] + } + return $definition + } + + + Object instproc check {checkoptions} { + ::nx::core::assertion [self] check [::xotcl::checkoption_xotcl1_to_internal $checkoptions] + } + Object instforward invar ::nx::core::assertion %self object-invar + Class instforward instinvar ::nx::core::assertion %self class-invar + + Object instproc abstract {methtype methname arglist} { + if {$methtype ne "proc" && $methtype ne "instproc" && $methtype ne "method"} { + error "invalid method type '$methtype', \ + must be either 'proc', 'instproc' or 'method'." + } + :$methtype $methname $arglist " + if {!\[::xotcl::self isnextcall\]} { + error \"Abstract method $methname $arglist called\" + } else {::xotcl::next} + " + } + + # support for XOTcl specific convenience routines + Object instproc hasclass cl { + if {[::nx::core::is [self] object -hasmixin $cl]} {return 1} + ::nx::core::is [self] type $cl + } + Object instproc filtersearch {filter} { + set definition [::nx::core::dispatch [self] ::nx::core::cmd::Object::filtersearch $filter] + return [filterorder_to_xotcl1 $definition] + } + Object instproc procsearch {name} { + set definition [::nx::core::cmd::ObjectInfo::callable [self] -which $name] + if {$definition ne ""} { + foreach {obj modifier kind} $definition break + if {$modifier ne "object"} { + set kind $modifier + set perClass [::nx::core::is $obj class] + } else { + set perClass 0 + } + switch $kind { + alias {if {$perClass} {set kind "instcmd"} else {set kind "cmd"}} + forward {if {$perClass} {set kind "instforward"}} + method {if {$perClass} {set kind "instproc"} else {set kind "proc"}} + setter {if {$perClass} {set kind "instparametercmd"} else {set kind "parametercmd"}} + default {error "not handeled: $definition"} + } + #puts stderr "return: [list $obj $kind $name]" + return [list $obj $kind $name] + } + } + Class instproc allinstances {} { + # TODO: mark it deprecated + return [:info instances -closure] + } + + # keep old object interface for XOTcl + Object proc unsetExitHandler {} {::nx::core::unsetExitHandler $newbody} + Object proc setExitHandler {newbody} {::nx::core::setExitHandler $newbody} + Object proc getExitHandler {} {::nx::core::getExitHandler} + + # resue some definitions from next scripting + ::nx::core::alias ::xotcl::Object copy ::nx::core::classes::nx::Object::copy + ::nx::core::alias ::xotcl::Object move ::nx::core::classes::nx::Object::move + ::nx::core::alias ::xotcl::Object defaultmethod ::nx::core::classes::nx::Object::defaultmethod + + ::nx::core::alias ::xotcl::Class -per-object __unknown ::nx::Class::__unknown + + proc myproc {args} {linsert $args 0 [::xotcl::self]} + proc myvar {var} {.requireNamespace; return [::xotcl::self]::$var} + + Object create ::xotcl::config + config proc load {obj file} { + source $file + foreach i [array names ::auto_index [list $obj *proc *]] { + set type [lindex $i 1] + set meth [lindex $i 2] + if {[$obj info ${type}s $meth] == {}} { + $obj $type $meth auto $::auto_index($i) + } + } + } + + config proc mkindex {meta dir args} { + set sp {[ ]+} + set st {^[ ]*} + set wd {([^ ;]+)} + foreach creator $meta { + ::lappend cp $st$creator${sp}create$sp$wd + ::lappend ap $st$creator$sp$wd + } + foreach methodkind {proc instproc} { + ::lappend mp $st$wd${sp}($methodkind)$sp$wd + } + foreach cl [concat ::xotcl::Class [::xotcl::Class info heritage]] { + eval ::lappend meths [$cl info instcommands] + } + set old [pwd] + cd $dir + ::append idx "# Tcl autoload index file, version 2.0\n" + ::append idx "# xotcl additions generated with " + ::append idx "\"::xotcl::config::mkindex [list $meta] [list $dir] $args\"\n" + set oc 0 + set mc 0 + foreach file [eval glob -nocomplain -- $args] { + if {[catch {set f [open $file]} msg]} then { + catch {close $f} + cd $old + error $msg + } + while {[gets $f line] >= 0} { + foreach c $cp { + if {[regexp $c $line x obj]==1 && + [string index $obj 0]!={$}} then { + ::incr oc + ::append idx "set auto_index($obj) " + ::append idx "\"::xotcl::config::load $obj \$dir/$file\"\n" + } + } + foreach a $ap { + if {[regexp $a $line x obj]==1 && + [string index $obj 0]!={$} && + [lsearch -exact $meths $obj]==-1} { + ::incr oc + ::append idx "set auto_index($obj) " + ::append idx "\"::xotcl::config::load $obj \$dir/$file\"\n" + } + } + foreach m $mp { + if {[regexp $m $line x obj ty pr]==1 && + [string index $obj 0]!={$} && + [string index $pr 0]!={$}} then { + ::incr mc + ::append idx "set \{auto_index($obj " + ::append idx "$ty $pr)\} \"source \$dir/$file\"\n" + } + } + } + close $f + } + set t [open tclIndex a+] + puts $t $idx nonewline + close $t + cd $old + return "$oc objects, $mc methods" + } + + # + # if cutTheArg not 0, it cut from upvar argsList + # + Object instproc extractConfigureArg {al name {cutTheArg 0}} { + set value "" + upvar $al argList + set largs [llength $argList] + for {set i 0} {$i < $largs} {incr i} { + if {[lindex $argList $i] == $name && $i + 1 < $largs} { + set startIndex $i + set endIndex [expr {$i + 1}] + while {$endIndex < $largs && + [string first - [lindex $argList $endIndex]] != 0} { + lappend value [lindex $argList $endIndex] + incr endIndex + } + } + } + if {[info exists startIndex] && $cutTheArg != 0} { + set argList [lreplace $argList $startIndex [expr {$endIndex - 1}]] + } + return $value + } + + Object create ::xotcl::rcs + rcs proc date string { + lreplace [lreplace $string 0 0] end end + } + rcs proc version string { + lindex $string 2 + } + + # + # package support + # + # puts this for the time being into XOTcl + # + ::xotcl::Class instproc uses list { + foreach package $list { + ::xotcl::package import -into [::xotcl::self] $package + puts stderr "*** using ${package}::* in [::xotcl::self]" + } + } + ::nx::Class create ::xotcl::package -superclass ::xotcl::Class -parameter { + provide + {version 1.0} + {autoexport {}} + {export {}} + } { + + :public object method create {name args} { + set nq [namespace qualifiers $name] + if {$nq ne "" && ![namespace exists $nq]} {Object create $nq} + next + } + + :public object method extend {name args} { + :require $name + eval $name configure $args + } + + :public object method contains script { + if {[info exists :provide]} { + package provide [set :provide] [set :version] + } else { + package provide [::xotcl::self] [set :version] + } + namespace eval [::xotcl::self] {namespace import ::xotcl::*} + namespace eval [::xotcl::self] $script + foreach e [set :export] { + set nq [namespace qualifiers $e] + if {$nq ne ""} { + namespace eval [::xotcl::self]::$nq [list namespace export [namespace tail $e]] + } else { + namespace eval [::xotcl::self] [list namespace export $e] + } + } + foreach e [set :autoexport] { + namespace eval :: [list namespace import [::xotcl::self]::$e] + } + } + + :public object method unknown args { + #puts stderr "unknown: package $args" + eval [set :packagecmd] $args + } + + :public object method verbose value { + set :verbose $value + } + + :public object method present args { + if {$::tcl_version<8.3} { + switch -exact -- [lindex $args 0] { + -exact {set pkg [lindex $args 1]} + default {set pkg [lindex $args 0]} + } + if {[info exists :loaded($pkg)]} { + return ${:loaded}($pkg) + } else { + error "not found" + } + } else { + eval [set :packagecmd] present $args + } + } + + :public object method import {{-into ::} pkg} { + :require $pkg + namespace eval $into [subst -nocommands { + #puts stderr "*** package import ${pkg}::* into [namespace current]" + namespace import ${pkg}::* + }] + # import subclasses if any + foreach e [$pkg export] { + set nq [namespace qualifiers $e] + if {$nq ne ""} { + namespace eval $into$nq [list namespace import ${pkg}::$e] + } + } + } + + :public object method require args { + #puts "XOTCL package require $args, current=[namespace current]" + set prevComponent ${:component} + if {[catch {set v [eval package present $args]} msg]} { + #puts stderr "we have to load $msg" + switch -exact -- [lindex $args 0] { + -exact {set pkg [lindex $args 1]} + default {set pkg [lindex $args 0]} + } + set :component $pkg + lappend :uses($prevComponent) ${:component} + set v [uplevel \#1 [set :packagecmd] require $args] + if {$v ne "" && ${:verbose}} { + set path [lindex [::package ifneeded $pkg $v] 1] + puts "... $pkg $v loaded from '$path'" + set :loaded($pkg) $v ;# loaded stuff needed for Tcl 8.0 + } + } + set :component $prevComponent + return $v + } + + set :component . + set :verbose 0 + set :packagecmd ::package + } + + if {[info exists cmd]} {unset cmd} + + proc ::xotcl::configure args {::nx::core::configure {*}$args} + proc ::xotcl::finalize {} {::nx::core::finalize} + + # Documentation stub object -> just ignore per default. + # if xoDoc is loaded, documentation will be activated + ::xotcl::Object create ::xotcl::@ + ::xotcl::@ proc unknown args {} + + set ::xotcl::confdir ~/.xotcl + set ::xotcl::logdir $::xotcl::confdir/log + namespace import ::nx::core::tmpdir + + # finally, export contents defined for XOTcl + namespace export Object Class Attribute myproc myvar my self next @ +} + +foreach ns {::nx::core ::nx ::xotcl} { + puts stderr "$ns exports [namespace eval $ns {lsort [namespace export]}]" +} \ No newline at end of file Index: library/serialize/Serializer.xotcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -1,850 +1,3 @@ -# $Id: Serializer.xotcl,v 1.19 2007/10/05 09:06:00 neumann Exp $ -package require XOTcl +# offer old package name for backward minimal compatibility 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 ::nx::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 nx; 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]::*" -} +package require nx::serializer \ No newline at end of file Index: library/serialize/pkgIndex.tcl =================================================================== diff -u -rc0df808e0c4f79c4c2296174c22cfb331eb4c8f1 -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- library/serialize/pkgIndex.tcl (.../pkgIndex.tcl) (revision c0df808e0c4f79c4c2296174c22cfb331eb4c8f1) +++ library/serialize/pkgIndex.tcl (.../pkgIndex.tcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -8,7 +8,7 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. +package ifneeded nx::serializer 1.0 [list source [file join $dir serializer.tcl]] 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.4 [list source [file join $dir Serializer2.xotcl]] package ifneeded xotcl::serializer 1.0 [list source [file join $dir Serializer.xotcl]] Index: library/serialize/serializer.tcl =================================================================== diff -u --- library/serialize/serializer.tcl (revision 0) +++ library/serialize/serializer.tcl (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -0,0 +1,864 @@ +package require XOTcl 2.0 +package provide nx::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 ::nx::serializer { + namespace eval ::xotcl {} ;# just to make mk_pkgIndex happy + namespace import ::xotcl::* ;# just needed for the time being for @ + namespace import -force ::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 + } + } + + @ 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 namespaces of the basic object systems, which are + used for the object system internals and volatile objects. + + TODO + 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} { + #puts stderr "set :serializer($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 {![::nx::core::objectproperty $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} + + # TODO generalize? + set ns_excluded(::ns) 1 + + foreach c $set { + set ns [namespace qualifiers $c] + if {!$all && + [info exists ns_excluded($ns)] && + ![: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 next'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)} + catch {unset namespace(::ns)} + foreach ns [array name namespace] { + if {![namespace exists $ns]} continue + if {![::nx::core::objectproperty $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 ::nx::core::current] + 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 {![::nx::core::objectproperty $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\] + #::nx::Slot mixin add ::nx::Slot::Nocheck + ::nx::core::configure softrecreate [::nx::core::configure softrecreate] + ::nx::core::setExitHandler [list [::nx::core::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 { + #::nx::Slot mixin delete ::nx::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 {![::nx::core::objectproperty $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 {![::nx::core::objectproperty $o object]} { + puts stderr "Warning: $o is not an object" + } elseif {[::nx::core::objectproperty $o type ${:rootClass}]} {set :exportMethods($k) 1} + } + foreach o [Serializer exportedObjects] { + if {![::nx::core::objectproperty $o object]} { + puts stderr "Warning: $o is not an object" + } elseif {[::nx::core::objectproperty $o type ${:rootClass}]} {set :exportObjects($o) 1} + } + foreach p [array names :ignorePattern] {Serializer addPattern $p} + } + + + ############################### + # general method serialization + ############################### + + :method classify {o} { + if {[::nx::core::objectproperty $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 nx; 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 {![::nx::core::objectproperty $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 {[::nx::core::objectproperty $o type ::nx::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] + array set :ignorePattern [list "::nx::core::*" 1 "::xotcl::*" 1] + + + :method serialize-all-start {s} { + set intro "package require XOTcl 2.0" + if {[info command ::Object] ne "" && [namespace origin ::Object] eq "::xotcl::Object"} { + append intro "\nnamespace 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]::*" +} Index: tests/forwardtest.xotcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -135,7 +135,7 @@ # test serializer ########################################### Test case serializer -package require xotcl::serializer +package require nx::serializer obj proc test {} {puts "i am [self proc]"} set a [Serializer deepSerialize obj] #puts <<$a>> Index: tests/interceptor-slot.tcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- tests/interceptor-slot.tcl (.../interceptor-slot.tcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/interceptor-slot.tcl (.../interceptor-slot.tcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -98,7 +98,7 @@ # forwarder with 0 arguments + flag ? {C object-mixin} "::M" -puts stderr "==================== XOTcl 1" +puts stderr "==================== XOTcl" package require XOTcl namespace import -force ::xotcl::* Index: tests/slottest.xotcl =================================================================== diff -u -r35c67391973a07983d0b0dfe70706e6a69fbdbfc -r183ec0e7c071586238bf5ed90a05dbbda91d4582 --- tests/slottest.xotcl (.../slottest.xotcl) (revision 35c67391973a07983d0b0dfe70706e6a69fbdbfc) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision 183ec0e7c071586238bf5ed90a05dbbda91d4582) @@ -23,7 +23,7 @@ # # -gustaf neumann 21.Jan. 2006 -package require xotcl::serializer +package require nx::serializer ####################################################### # testing __initcmds