diff options
Diffstat (limited to 'desiredata/src/poe.tcl')
-rw-r--r-- | desiredata/src/poe.tcl | 281 |
1 files changed, 281 insertions, 0 deletions
diff --git a/desiredata/src/poe.tcl b/desiredata/src/poe.tcl new file mode 100644 index 00000000..89ddfc78 --- /dev/null +++ b/desiredata/src/poe.tcl @@ -0,0 +1,281 @@ +# $Id: poe.tcl,v 1.1.2.2.2.27 2007-10-15 15:58:13 chunlee Exp $ +#----------------------------------------------------------------# +# POETCL +# +# Copyright (c) 2005,2006 by Mathieu Bouchard +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# See file ../COPYING.desire-client.txt for further informations on licensing terms. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# Note that this is not under the same license as the rest of PureData. +# Even the DesireData server-side modifications stay on the same license +# as the rest of PureData. +# +#-----------------------------------------------------------------------------------# + +# (please distinguish between what this is and what dataflow is) +# note, the toplevel class is called "thing". + +package provide poe 0.1 + +if {$tcl_version < 8.5} {package require pre8.5} +set nextid 0 +set _(Class:_class) Class +set _(Class:_super) {Thing} +set have_expand [expr ![catch {set a {foo bar}; list {expand}$a}]] +proc proc* {name args body} { + set argl {} + foreach arg $args {set arg [lindex $arg 0]; lappend argl "$arg=\$$arg"} + if {[regexp {_unknown$} $name]} { + proc $name $args "upvar 1 selector ___; puts \"\[VTgreen\]CALL TO PROC $name selector=\$___ [join $argl " "]\[VTgrey\]\"; $body" + } else { + if {![regexp "return" $body]} { + set body "time {$body}" + proc $name $args "puts \"\[VTgreen\]CALL TO PROC $name [join $argl " "], \[VTred\]\[lrange \[split \[$body\] \] 0 1\] \[VTgrey\]\"" + } { + proc $name $args "puts \"\[VTgreen\]CALL TO PROC $name [join $argl " "]\[VTgrey\]\"; $body" + } + } +} + +#proc Class_def {self selector args body} { +# global _; if {![info exists _($self:_class)]} {error "unknown class '$self'"} +# proc ${self}_$selector "self $args" "global _; [regsub -all @(\[\\w\\?\]+) $body _(\$self:\\1)]" +#} +#proc def {class selector args body} {$class def $selector $args $body} + +proc expand_macros {body} { + return [regsub -all @(\\\$?\[\\w\\?\]+) $body _(\$self:\\1)] +} + +proc def {self selector argnames body} { + global _ __trace __args + if {![info exists _($self:_class)]} {error "unknown class '$self'"} + set name ${self}_$selector + #if {$name == "Canvas_motion_wrap"} {set body "puts \[time {$body}\]"} + set argnames [concat [list self] $argnames] + if {([info exists __trace($self:$selector)] || [info exists __trace(*:$selector)] + || [info exists __trace($self:*)] || [info exists __trace(*:*)]) + && ![info exists __trace($self:!$selector)] + && ![info exists __trace(*:!$selector)] + } { + proc* $name $argnames "global _; [expand_macros $body]" + } { + proc $name $argnames "global _; [expand_macros $body]" + } + set __args($name) $argnames + #trace add execution ${self}_$selector enter dedebug +} + +proc class_new {self {super {Thing}}} { + global _ + set _($self:_class) Class + set _($self:_super) $super + set _($self:subclasses) {} + foreach sup $super {lappend _($sup:subclasses) $self} + proc ${self}_new {args} "global _ + set self \[format o%07x \$::nextid\] + incr ::nextid + set _(\$self:_class) $self + setup_dispatcher \$self + eval [concat \[list \$self init\] \$args] + return \$self + " + proc ${self}_new_as {self args} "global _ + if {\[info exists _(\$self:_class)\]} {error \"object '\\$self' already exists\" } + set _(\$self:_class) $self + setup_dispatcher \$self + eval [concat \[list \$self init\] \$args] + return \$self + " + setup_dispatcher $self +} + +# TODO: remove duplicates in lookup +proc lookup_method {class selector methodsv ancestorsv} { + global _ + upvar $methodsv methods + upvar $ancestorsv ancestors + set name ${class}_$selector + if {[llength [info procs $name]]} {lappend methods $name} + lappend ancestors $class + foreach super $_($class:_super) {lookup_method $super $selector methods ancestors} +} + +proc cache_method {class selector} { + global _ __ + set methods {}; set ancestors {} + lookup_method $class $selector methods ancestors + if {![llength $methods]} {set methods [cache_method $class unknown]} + set __($class:$selector) $methods + return $methods +} + +if {$have_expand} { + set dispatch { + set i 0; set class $::_($self:_class) + if {[catch {set methods $::__($class:$selector)}]} {set methods [cache_method $class $selector]} + [lindex $methods 0] $self {expand}$args + } +} else { + set dispatch { + set i 0; set class $::_($self:_class) + if {[catch {set methods $::__($class:$selector)}]} {set methods [cache_method $class $selector]} + eval [concat [list [lindex $methods 0] $self] $args] + } +} +proc setup_dispatcher {self} { + if {[llength [info commands $self]]} {rename $self old_$self} + proc $self {selector args} [regsub -all {\$self} $::dispatch $self] +} + +set super { + upvar 1 self self + upvar 2 methods methods i oi + set i [expr {1+$oi}] + if {[llength $methods] < $i} {error "no more supermethods"} +} +if {$have_expand} { + append super {[lindex $methods $i] $self {expand}$args} +} else { + append super {eval [concat [list [lindex $methods $i] $self] $args]} +} +proc super {args} $super + +class_new Thing {} +#set _(Thing:_super) {} +def Thing init {} {} +def Thing == {other} {return [expr ![string compare $self $other]]} + +# virtual destructor +def Thing delete {} { + foreach elem [array names _ $self:*] {array unset _ $elem} + rename $self "" +} + +def Thing vars {} { + set n [string length $self:] + set ks [list] + foreach k [array names _] { + if {0==[string compare -length $n $self: $k]} {lappend ks [string range $k $n end]} + } + return $ks +} + +def Thing inspect {} { + set t [list "#<$self: "] + foreach k [lsort [$self vars]] {lappend t "$k=[list $@$k] "} + lappend t ">" + return [join $t ""] +} + +def Thing class {} {return $@_class} + +def Thing unknown {args} { + upvar 1 selector selector class class + error "no such method '$selector' for object '$self'\nwith ancestors {[Class_ancestors $class]}" +} + +class_new Class + +# those return only the direct neighbours in the hierarchy +def Class superclasses {} {return $@_super} +def Class subclasses {} {return $@subclasses} + +# those look recursively. +def Class ancestors {} { + #if {[info exists @ancestors]} {} + set r [list $self] + foreach super $@_super {eval [concat [list lappend r] [$super ancestors]]} + return $r +} +def Class <= {class} {return [expr [lsearch [$self ancestors] $class]>=0]} + +# note: [luniq] is actually defined in desire.tk +def Class methods {} { + set methods {} + set anc [$self ancestors] + foreach class $anc { + foreach name [info procs ${class}_*] { + lappend methods [join [lrange [split $name _] 1 end] _] + } + } + return [luniq [lsort $methods]] +} + +# those are static methods, and poe.tcl doesn't distinguish them yet. +def Class new { args} {eval [concat [list ${self}_new ] $args]} +def Class new_as {id args} {eval [concat [list ${self}_new_as $id] $args]} + +#-----------------------------------------------------------------------------------# + +# this makes me think of Maximus-CBCS... +proc VTgrey {} {return "\x1b\[0m"} +proc VTred {} {return "\x1b\[0;1;31m"} +proc VTgreen {} {return "\x1b\[0;1;32m"} +proc VTyellow {} {return "\x1b\[0;1;33m"} +proc VTblue {} {return "\x1b\[0;1;34m"} +proc VTmagenta {} {return "\x1b\[0;1;35m"} +proc VTcyan {} {return "\x1b\[0;1;36m"} +proc VTwhite {} {return "\x1b\[0;1;37m"} + +proc error_text {} { + set e $::errorInfo + regsub -all " invoked from within\n" $e "" e + regsub -all "\n \\(" $e " (" e + regsub -all {\n[^\n]*procedure \"(::unknown|super)\"[^\n]*\n} $e "\n" e + regsub -all {\n\"\[lindex \$methods 0\][^\n]*\n} $e "\n" e + regsub -all {\s*while executing\s*\n} $e "\n" e + #regsub {\n$} $e "" e + return $e +} +set suicidal 0 +proc error_dump {} { + puts "[VTred]Exception:[VTgrey] [error_text]" + if {$::suicidal} {exit 1} +} + +proc tracedef {class method {when enter}} { + global __trace + set __trace($class:$method) $when +} + +proc yell {var key args} { + global $key + puts "[VTyellow]HEY! at [info level -1] set $key [list $::_($key)][VTgrey]" +} + +proc object_table {} { + set n 0 + puts "poe.tcl object_table: {" + foreach o [lsort [array names ::_ *:_class]] { + set oo [lindex [split $o :] 0] + set class $::_($o) + incr by_class($class) + puts " $oo is a $class" + incr n + } + puts "} ($n objects)" + set n 0 + puts "poe.tcl class_stats: {" + foreach o [array names by_class] { + puts " class $o has $by_class($o) objects" + incr n + } + puts "} ($n classes)" +} + +proc object_exists {self} {info exists ::_($self:_class)} |