reorganized

svn path=/trunk/; revision=9400

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)}