path: root/desiredata/src/poe.tcl

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