From 9ea4e9fc1b4775a0e6b1c387a2a0965686c1c20e Mon Sep 17 00:00:00 2001 From: mescalinum Date: Fri, 14 Oct 2011 21:32:49 +0000 Subject: reorder tcl land into namespaces and streamline and standardize syntax svn path=/trunk/externals/loaders/tclpd/; revision=15600 --- ChangeLog.txt | 3 + examples/binbuf-test.tcl | 21 +- examples/bitmap.tcl | 546 +++++++++++++++++++++---------------------- examples/dynreceive.tcl | 84 +++---- examples/dynroute.tcl | 74 +++--- examples/list_change-help.pd | 42 ++-- examples/list_change.tcl | 47 ++-- examples/slider2.tcl | 366 ++++++++++++++--------------- pdlib.tcl | 108 +++++---- tcl_class.c | 99 +++++--- tcl_extras.h | 18 +- tcl_loader.c | 20 +- tcl_widgetbehavior.c | 130 ++++++----- tclpd-meta.pd | 2 +- 14 files changed, 819 insertions(+), 741 deletions(-) diff --git a/ChangeLog.txt b/ChangeLog.txt index f9fe792..5c8a950 100644 --- a/ChangeLog.txt +++ b/ChangeLog.txt @@ -1,3 +1,6 @@ +Version 0.2.3: + - Big rewrite, using tcl namespaces (more tidy, more efficient) + Version 0.2.2: - Requires pd 0.43 (logpost, pdpost) - Fixed "tclpd_get_instance_text cmd not found" bug diff --git a/examples/binbuf-test.tcl b/examples/binbuf-test.tcl index 9c9117f..62fc8c1 100644 --- a/examples/binbuf-test.tcl +++ b/examples/binbuf-test.tcl @@ -1,15 +1,12 @@ -package require Tclpd 0.2.2 -package require TclpdLib 0.18 +package require Tclpd 0.2.3 +package require TclpdLib 0.19 -pd::class binbuf-test { - constructor { - pd::add_outlet $self list - } - - destructor { - } +proc binbuf-test::constructor {self args} { + pd::add_outlet $self list +} - 0_bang { - pd::outlet $self 0 list [pd::get_binbuf $self] - } +proc binbuf-test::0_bang {self} { + pd::outlet $self 0 list [pd::get_binbuf $self] } + +pd::class binbuf-test diff --git a/examples/bitmap.tcl b/examples/bitmap.tcl index 43241d2..97b9491 100644 --- a/examples/bitmap.tcl +++ b/examples/bitmap.tcl @@ -1,5 +1,5 @@ -package require Tclpd 0.2.2 -package require TclpdLib 0.17 +package require Tclpd 0.2.3 +package require TclpdLib 0.19 set ::script_path [file dirname [info script]] @@ -27,320 +27,320 @@ pd::guiproc bitmap_draw_new {self c x y config data} { -outline $fgcolor -tags [list $self border$self] } -pd::guiclass bitmap { - constructor { - set s [file join $::script_path properties.tcl] - sys_gui "source {$s}\n" +proc+ bitmap::constructor {self args} { + set s [file join $::script_path properties.tcl] + sys_gui "source {$s}\n" - pd::add_outlet $self float + pd::add_outlet $self float - # set defaults: - set @config [list] - lappend @config -uwidth 8 - lappend @config -uheight 8 - lappend @config -cellsize 16 - lappend @config -label "" - lappend @config -labelpos "top" - lappend @config -sendsymbol "" - lappend @config -receivesymbol "" - lappend @config -fgcolor "#000000" - lappend @config -bgcolor "#ffffff" - lappend @config -lblcolor "#000000" - set @data { - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - } - # expanded ($n) send/recv symbols: - set @send {} - set @recv {} + # set defaults: + set @config [list] + lappend @config -uwidth 8 + lappend @config -uheight 8 + lappend @config -cellsize 16 + lappend @config -label "" + lappend @config -labelpos "top" + lappend @config -sendsymbol "" + lappend @config -receivesymbol "" + lappend @config -fgcolor "#000000" + lappend @config -bgcolor "#ffffff" + lappend @config -lblcolor "#000000" + set @data { + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + } + # expanded ($n) send/recv symbols: + set @send {} + set @recv {} - ::$self 0 config {*}$args + 0_config $self {*}$args - set @rcvLoadData {#bitmap} - pd_bind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData] - } + set @rcvLoadData {#bitmap} + pd_bind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData] +} - destructor { - set pdself [tclpd_get_instance_pd $self] - if {$@rcvLoadData != {}} { - #should not happen! - pd_unbind $pdself [gensym $@rcvLoadData] - } - if {[dict get $@config -receivesymbol] != {}} { - pd_unbind $pdself $@recv - } +proc+ bitmap::destructor {self} { + set pdself [tclpd_get_instance_pd $self] + if {$@rcvLoadData != {}} { + #should not happen! + pd_unbind $pdself [gensym $@rcvLoadData] + } + if {[dict get $@config -receivesymbol] != {}} { + pd_unbind $pdself $@recv } +} - 0_config { - if {$args == {}} { - return $@config - } else { - set newconf [list] - set optlist [pd::strip_selectors $args] - set optlist [pd::strip_empty $optlist] - for {set i 0} {$i < [llength $optlist]} {} { - set k [lindex $optlist $i] - if {![dict exists $@config $k]} { - return -code error "unknown option '$k'" - } - incr i - set v [lindex $optlist $i] - if {[lsearch -exact {-uwidth -uheight -cellsize} $k] != -1} { - set v [expr {int($v)}] - } - dict set newconf $k $v - incr i +proc+ bitmap::0_config {self args} { + if {$args == {}} { + return $@config + } else { + set newconf [list] + set optlist [pd::strip_selectors $args] + set optlist [pd::strip_empty $optlist] + for {set i 0} {$i < [llength $optlist]} {} { + set k [lindex $optlist $i] + if {![dict exists $@config $k]} { + return -code error "unknown option '$k'" } - if {[dict get $@config -uwidth] != [dict get $newconf -uwidth] || - [dict get $@config -uheight] != [dict get $newconf -uheight]} { - $self 0 resize {*}[pd::add_selectors [list \ - [dict get $newconf -uwidth] \ - [dict get $newconf -uheight] \ - ]] + incr i + set v [lindex $optlist $i] + if {[lsearch -exact {-uwidth -uheight -cellsize} $k] != -1} { + set v [expr {int($v)}] } - set ui 0 - foreach opt {label labelpos cellsize fgcolor bgcolor lblcolor} { - set old [dict get $@config -$opt] - if {[dict exists $newconf -$opt]} { - set new [dict get $newconf -$opt] - if {$old != $new} { - dict set @config -$opt $new - set ui 1 - } + dict set newconf $k $v + incr i + } + if {[dict get $@config -uwidth] != [dict get $newconf -uwidth] || + [dict get $@config -uheight] != [dict get $newconf -uheight]} { + 0_resize $self {*}[pd::add_selectors [list \ + [dict get $newconf -uwidth] \ + [dict get $newconf -uheight] \ + ]] + } + set ui 0 + foreach opt {label labelpos cellsize fgcolor bgcolor lblcolor} { + set old [dict get $@config -$opt] + if {[dict exists $newconf -$opt]} { + set new [dict get $newconf -$opt] + if {$old != $new} { + dict set @config -$opt $new + set ui 1 } } - foreach opt {sendsymbol receivesymbol} { - set old [dict get $@config -$opt] - if {[dict exists $newconf -$opt]} { - set new [dict get $newconf -$opt] - if {$old != $new} { - if {$opt == "receivesymbol"} { - set selfpd [tclpd_get_instance_pd $self] - if {$old != {}} { - pd_unbind $selfpd $@recv - } - if {$new != {}} { - set @recv [canvas_realizedollar \ - [tclpd_get_glist $self] [gensym $new]] - pd_bind $selfpd $@recv - } else { - set @recv {} - } + } + foreach opt {sendsymbol receivesymbol} { + set old [dict get $@config -$opt] + if {[dict exists $newconf -$opt]} { + set new [dict get $newconf -$opt] + if {$old != $new} { + if {$opt == "receivesymbol"} { + set selfpd [tclpd_get_instance_pd $self] + if {$old != {}} { + pd_unbind $selfpd $@recv + } + if {$new != {}} { + set @recv [canvas_realizedollar \ + [tclpd_get_glist $self] [gensym $new]] + pd_bind $selfpd $@recv + } else { + set @recv {} } - dict set @config -$opt $new } + dict set @config -$opt $new } } - if {$ui && [info exists @c]} { - sys_gui [list $@c delete $self]\n - sys_gui [list bitmap_draw_new $self \ - $@c $@x $@y $@config $@data]\n - } } - } - - 0_resize { - set w [pd::arg 0 int] - set h [pd::arg 1 int] - set oldw [dict get $@config -uwidth] - set oldh [dict get $@config -uheight] - set newd {} - for {set y 0} {$y < $h} {incr y} { - for {set x 0} {$x < $w} {incr x} { - if {$x < $oldw && $y < $oldh} { - lappend newd [lindex $@data [expr {$y*$oldw+$x}]] - } else { - lappend newd 0 - } - } + if {$ui && [info exists @c]} { + sys_gui [list $@c delete $self]\n + sys_gui [list bitmap_draw_new $self \ + $@c $@x $@y $@config $@data]\n } - dict set @config -uwidth $w - dict set @config -uheight $h - set @data $newd } +} - 0_getrow { - set r [list] - set n [pd::arg 0 int] - set w [dict get $@config -uwidth] - for {set i [expr {$n*$w}]} {$i < [expr {($n+1)*$w}]} {incr i} { - lappend r [list float [lindex $@data $i]] +proc+ bitmap::0_resize {self args} { + set w [pd::arg 0 int] + set h [pd::arg 1 int] + set oldw [dict get $@config -uwidth] + set oldh [dict get $@config -uheight] + set newd {} + for {set y 0} {$y < $h} {incr y} { + for {set x 0} {$x < $w} {incr x} { + if {$x < $oldw && $y < $oldh} { + lappend newd [lindex $@data [expr {$y*$oldw+$x}]] + } else { + lappend newd 0 + } } - pd::outlet $self 0 list $r } + dict set @config -uwidth $w + dict set @config -uheight $h + set @data $newd +} - 0_getcol { - set r [list] - set n [pd::arg 0 int] - set w [dict get $@config -uwidth] - set h [dict get $@config -uheight] - for {set i [expr {$n}]} {$i < [expr {$w*$h}]} {incr i $w} { - lappend r [list float [lindex $@data $i]] - } - pd::outlet $self 0 list $r +proc+ bitmap::0_getrow {self args} { + set r [list] + set n [pd::arg 0 int] + set w [dict get $@config -uwidth] + for {set i [expr {$n*$w}]} {$i < [expr {($n+1)*$w}]} {incr i} { + lappend r [list float [lindex $@data $i]] } + pd::outlet $self 0 list $r +} - 0_getcell { - set r [pd::arg 0 int] - set c [pd::arg 1 int] - set w [dict get $@config -uwidth] - pd::outlet $self 0 float [lindex $@data [expr {$r*$w+$c}]] +proc+ bitmap::0_getcol {self args} { + set r [list] + set n [pd::arg 0 int] + set w [dict get $@config -uwidth] + set h [dict get $@config -uheight] + for {set i [expr {$n}]} {$i < [expr {$w*$h}]} {incr i $w} { + lappend r [list float [lindex $@data $i]] } + pd::outlet $self 0 list $r +} - 0_setrow { - set row [pd::arg 0 int] - set z 1 - set col 0 - set w [dict get $@config -uwidth] - set fgcolor [dict get $@config -fgcolor] - set bgcolor [dict get $@config -bgcolor] - set colors [list $bgcolor $fgcolor] - for {set idx [expr {$row*$w}]} {$idx < [expr {($row+1)*$w}]} {incr idx} { - set d [expr {0!=[pd::arg $z int]}] - lset @data $idx $d - sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \ - -fill [lindex $colors $d]]\n - incr z - incr col - } - } +proc+ bitmap::0_getcell {self args} { + set r [pd::arg 0 int] + set c [pd::arg 1 int] + set w [dict get $@config -uwidth] + pd::outlet $self 0 float [lindex $@data [expr {$r*$w+$c}]] +} - 0_setcol { - set col [pd::arg 0 int] - set z 1 - set row 0 - set w [dict get $@config -uwidth] - set h [dict get $@config -uheight] - set fgcolor [dict get $@config -fgcolor] - set bgcolor [dict get $@config -bgcolor] - set colors [list $bgcolor $fgcolor] - for {set idx [expr {$col}]} {$idx < [expr {$w*$h}]} {incr idx $w} { - set d [expr {0!=[pd::arg $z int]}] - lset @data $idx $d - sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \ - -fill [lindex $colors $d]]\n - incr z - incr row - } +proc+ bitmap::0_setrow {self args} { + set row [pd::arg 0 int] + set z 1 + set col 0 + set w [dict get $@config -uwidth] + set fgcolor [dict get $@config -fgcolor] + set bgcolor [dict get $@config -bgcolor] + set colors [list $bgcolor $fgcolor] + for {set idx [expr {$row*$w}]} {$idx < [expr {($row+1)*$w}]} {incr idx} { + set d [expr {0!=[pd::arg $z int]}] + lset @data $idx $d + sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \ + -fill [lindex $colors $d]]\n + incr z + incr col } +} - 0_setcell { - set r [pd::arg 0 int] - set c [pd::arg 1 int] - set d [expr {0!=[pd::arg 2 int]}] - set w [dict get $@config -uwidth] - set fgcolor [dict get $@config -fgcolor] - set bgcolor [dict get $@config -bgcolor] - set colors [list $bgcolor $fgcolor] - set idx [expr {$r*$w+$c}] +proc+ bitmap::0_setcol {self args} { + set col [pd::arg 0 int] + set z 1 + set row 0 + set w [dict get $@config -uwidth] + set h [dict get $@config -uheight] + set fgcolor [dict get $@config -fgcolor] + set bgcolor [dict get $@config -bgcolor] + set colors [list $bgcolor $fgcolor] + for {set idx [expr {$col}]} {$idx < [expr {$w*$h}]} {incr idx $w} { + set d [expr {0!=[pd::arg $z int]}] lset @data $idx $d - sys_gui [list $@c itemconfigure cell_${r}_${c}_$self \ + sys_gui [list $@c itemconfigure cell_${col}_${row}_$self \ -fill [lindex $colors $d]]\n + incr z + incr row } +} - 0_setdata { - set d [pd::strip_selectors $args] - set l [llength $d] - set w [dict get $@config -uwidth] - set h [dict get $@config -uheight] - if {$l != $w*$h} { - return -code error "bad data size" - } - set @data [list] - foreach i $d {lappend @data [expr {int($i)}]} - if {$@rcvLoadData != {}} { - pd_unbind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData] - set @rcvLoadData {} - } - } +proc+ bitmap::0_setcell {self args} { + set r [pd::arg 0 int] + set c [pd::arg 1 int] + set d [expr {0!=[pd::arg 2 int]}] + set w [dict get $@config -uwidth] + set fgcolor [dict get $@config -fgcolor] + set bgcolor [dict get $@config -bgcolor] + set colors [list $bgcolor $fgcolor] + set idx [expr {$r*$w+$c}] + lset @data $idx $d + sys_gui [list $@c itemconfigure cell_${r}_${c}_$self \ + -fill [lindex $colors $d]]\n +} - object_save { - return [list #X obj $@x $@y bitmap {*}[pd::add_empty $@config] \; \ - \#bitmap setdata {*}$@data \; ] +proc+ bitmap::0_setdata {self args} { + set d [pd::strip_selectors $args] + set l [llength $d] + set w [dict get $@config -uwidth] + set h [dict get $@config -uheight] + if {$l != $w*$h} { + return -code error "bad data size" } - - object_properties { - set title "\[bitmap\] properties" - set x_xobj_obpd [tclpd_get_object_pd $self] - set x [tclpd_get_instance $self] - set buf [list propertieswindow %s $@config $title]\n - gfxstub_new $x_xobj_obpd $x $buf + set @data [list] + foreach i $d {lappend @data [expr {int($i)}]} + if {$@rcvLoadData != {}} { + pd_unbind [tclpd_get_instance_pd $self] [gensym $@rcvLoadData] + set @rcvLoadData {} } +} - widgetbehavior_getrect { - lassign $args x1 y1 - set w [dict get $@config -uwidth] - set h [dict get $@config -uheight] - set sz [dict get $@config -cellsize] - set x2 [expr {1+$x1+$w*$sz}] - set y2 [expr {1+$y1+$h*$sz}] - return [list $x1 $y1 $x2 $y2] - } +proc+ bitmap::save {self args} { + return [list #X obj $@x $@y bitmap {*}[pd::add_empty $@config] \; \ + \#bitmap setdata {*}$@data \; ] +} - widgetbehavior_displace { - set dx [lindex $args 0] - set dy [lindex $args 1] - if {$dx != 0 || $dy != 0} { - incr @x $dx - incr @y $dy - sys_gui [list $@c move $self $dx $dy]\n - } - return [list $@x $@y] - } +proc+ bitmap::properties {self args} { + set title "\[bitmap\] properties" + set x_xobj_obpd [tclpd_get_object_pd $self] + set x [tclpd_get_instance $self] + set buf [list propertieswindow %s $@config $title]\n + gfxstub_new $x_xobj_obpd $x $buf +} - widgetbehavior_select { - set sel [lindex $args 0] - set fgcolor [dict get $@config -fgcolor] - set bgcolor [dict get $@config -bgcolor] - set selcolor "blue" - set colors [list $selcolor $fgcolor] - sys_gui [list $@c itemconfigure $self \ - -outline [lindex $colors $sel]]\n - } +proc+ bitmap::widgetbehavior_getrect {self args} { + lassign $args x1 y1 + set w [dict get $@config -uwidth] + set h [dict get $@config -uheight] + set sz [dict get $@config -cellsize] + set x2 [expr {1+$x1+$w*$sz}] + set y2 [expr {1+$y1+$h*$sz}] + return [list $x1 $y1 $x2 $y2] +} - widgetbehavior_activate { +proc+ bitmap::widgetbehavior_displace {self args} { + set dx [lindex $args 0] + set dy [lindex $args 1] + if {$dx != 0 || $dy != 0} { + incr @x $dx + incr @y $dy + sys_gui [list $@c move $self $dx $dy]\n } + return [list $@x $@y] +} - widgetbehavior_vis { - set @c [lindex $args 0] - set @x [lindex $args 1] - set @y [lindex $args 2] - set vis [lindex $args 3] - set w [dict get $@config -uwidth] - set h [dict get $@config -uheight] - set sz [dict get $@config -cellsize] - if {$vis} { - sys_gui [list bitmap_draw_new $self $@c $@x $@y $@config $@data]\n - } else { - sys_gui [list $@c delete $self]\n - } +proc+ bitmap::widgetbehavior_select {self args} { + set sel [lindex $args 0] + set fgcolor [dict get $@config -fgcolor] + set bgcolor [dict get $@config -bgcolor] + set selcolor "blue" + set colors [list $selcolor $fgcolor] + sys_gui [list $@c itemconfigure $self \ + -outline [lindex $colors $sel]]\n +} + +proc+ bitmap::widgetbehavior_activate {self args} { +} + +proc+ bitmap::widgetbehavior_vis {self args} { + set @c [lindex $args 0] + set @x [lindex $args 1] + set @y [lindex $args 2] + set vis [lindex $args 3] + set w [dict get $@config -uwidth] + set h [dict get $@config -uheight] + set sz [dict get $@config -cellsize] + if {$vis} { + sys_gui [list bitmap_draw_new $self $@c $@x $@y $@config $@data]\n + } else { + sys_gui [list $@c delete $self]\n } +} - widgetbehavior_click { - set w [dict get $@config -uwidth] - set h [dict get $@config -uheight] - set sz [dict get $@config -cellsize] - set fgcolor [dict get $@config -fgcolor] - set bgcolor [dict get $@config -bgcolor] - set colors [list $bgcolor $fgcolor] - set xpix [expr {[lindex $args 0]-$@x-1}] - set ypix [expr {[lindex $args 1]-$@y-1}] - if {$xpix < 0 || $xpix >= $w*$sz} {return} - if {$ypix < 0 || $ypix >= $h*$sz} {return} - set shift [lindex $args 2] - set alt [lindex $args 3] - set dbl [lindex $args 4] - set doit [lindex $args 5] - if {$doit} { - set j [expr {$xpix/$sz}] - set i [expr {$ypix/$sz}] - set idx [expr {$w*${i}+${j}}] - set d [expr {[lindex $@data $idx]==0}] - lset @data $idx $d - sys_gui [list $@c itemconfigure cell_${j}_${i}_$self \ - -fill [lindex $colors $d]]\n - } +proc+ bitmap::widgetbehavior_click {self args} { + set w [dict get $@config -uwidth] + set h [dict get $@config -uheight] + set sz [dict get $@config -cellsize] + set fgcolor [dict get $@config -fgcolor] + set bgcolor [dict get $@config -bgcolor] + set colors [list $bgcolor $fgcolor] + set xpix [expr {[lindex $args 0]-$@x-1}] + set ypix [expr {[lindex $args 1]-$@y-1}] + if {$xpix < 0 || $xpix >= $w*$sz} {return} + if {$ypix < 0 || $ypix >= $h*$sz} {return} + set shift [lindex $args 2] + set alt [lindex $args 3] + set dbl [lindex $args 4] + set doit [lindex $args 5] + if {$doit} { + set j [expr {$xpix/$sz}] + set i [expr {$ypix/$sz}] + set idx [expr {$w*${i}+${j}}] + set d [expr {[lindex $@data $idx]==0}] + lset @data $idx $d + sys_gui [list $@c itemconfigure cell_${j}_${i}_$self \ + -fill [lindex $colors $d]]\n } } + +pd::guiclass bitmap diff --git a/examples/dynreceive.tcl b/examples/dynreceive.tcl index 8a269f7..6903da9 100644 --- a/examples/dynreceive.tcl +++ b/examples/dynreceive.tcl @@ -1,53 +1,53 @@ -package require Tclpd 0.2.1 -package require TclpdLib 0.17 +package require Tclpd 0.2.3 +package require TclpdLib 0.19 -pd::class dynreceive { - constructor { - set @sym {} - if {[pd::args] > 0} { - set @sym [pd::arg 0 symbol] - pd_bind [tclpd_get_instance_pd $self] [gensym $@sym] - } - pd::add_outlet $self +proc+ dynreceive::constructor {self args} { + set @sym {} + if {[pd::args] > 0} { + set @sym [pd::arg 0 symbol] + pd_bind [tclpd_get_instance_pd $self] [gensym $@sym] } + pd::add_outlet $self +} - destructor { - # don't forget to call pd_unbind, or sending things to a symbol - # bound to dead object will crash pd! - if {$@sym != {}} { - pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym] - } +proc+ dynreceive::destructor {self} { + # don't forget to call pd_unbind, or sending things to a symbol + # bound to dead object will crash pd! + if {$@sym != {}} { + pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym] } +} - 0_set { - # send [set empty( to clear the receive symbol - set s [pd::arg 0 symbol] - if {$@sym != {}} { - pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym] - } - if {$s == {empty}} { - set @sym {} - } else { - set @sym $s - pd_bind [tclpd_get_instance_pd $self] [gensym $@sym] - } +proc+ dynreceive::0_set {self args} { + # send [set empty( to clear the receive symbol + set s [pd::arg 0 symbol] + if {$@sym != {}} { + pd_unbind [tclpd_get_instance_pd $self] [gensym $@sym] } - - 0_bang { - pd::outlet $self 0 bang + if {$s == {empty}} { + set @sym {} + } else { + set @sym $s + pd_bind [tclpd_get_instance_pd $self] [gensym $@sym] } +} - 0_float { - pd::outlet $self 0 float [pd::arg 0 float] - } +proc+ dynreceive::0_bang {self} { + pd::outlet $self 0 bang +} - 0_symbol { - pd::outlet $self 0 symbol [gensym [pd::arg 0 symbol]] - } +proc+ dynreceive::0_float {self args} { + pd::outlet $self 0 float [pd::arg 0 float] +} - 0_anything { - set sel [pd::arg 0 symbol] - set argz [lrange $args 1 end] - pd::outlet $self 0 $sel $argz - } +proc+ dynreceive::0_symbol {self args} { + pd::outlet $self 0 symbol [gensym [pd::arg 0 symbol]] } + +proc+ dynreceive::0_anything {self args} { + set sel [pd::arg 0 symbol] + set argz [lrange $args 1 end] + pd::outlet $self 0 $sel $argz +} + +pd::class dynreceive diff --git a/examples/dynroute.tcl b/examples/dynroute.tcl index 2309ac7..04cb3c9 100644 --- a/examples/dynroute.tcl +++ b/examples/dynroute.tcl @@ -1,5 +1,5 @@ -package require Tclpd 0.2.1 -package require TclpdLib 0.17 +package require Tclpd 0.2.3 +package require TclpdLib 0.19 # dynroute: dynamically route messages based on first element # non-matching arguments are sent to last inlet @@ -10,48 +10,48 @@ package require TclpdLib 0.17 # remove remove previously created routing # clear -pd::class dynroute { - constructor { - pd::add_inlet $self list +proc+ dynroute::constructor {self args} { + pd::add_inlet $self list - set @num_outlets [pd::arg 0 int] - if {$@num_outlets < 0} {set @num_outlets 2} + set @num_outlets [pd::arg 0 int] + if {$@num_outlets < 0} {set @num_outlets 2} - for {set i 0} {$i < $@num_outlets} {incr i} { - pd::add_outlet $self list - } - - set @routing {} + for {set i 0} {$i < $@num_outlets} {incr i} { + pd::add_outlet $self list } - 0_list { - set sel [pd::arg 0 any] - set out [expr {$@num_outlets-1}] - catch {set out [dict get $@routing $sel]} - pd::outlet $self $out list $args - } + set @routing {} +} - 1_add { - set sel [pd::arg 0 any] - set out [pd::arg 1 int] - if {$out < 0 || $out >= $@num_outlets} { - pd::post "error: add: outlet number out of range" - return - } - dict set @routing $sel $out - } +proc+ dynroute::0_list {self args} { + set sel [pd::arg 0 any] + set out [expr {$@num_outlets-1}] + catch {set out [dict get $@routing $sel]} + pd::outlet $self $out list $args +} - 1_remove { - set sel [pd::arg 0 any] - set out [pd::arg 1 int] - if {$out < 0 || $out >= $@num_outlets} { - pd::post "error: add: outlet number out of range" - return - } - catch {dict unset @routing $sel $out} +proc+ dynroute::1_add {self args} { + set sel [pd::arg 0 any] + set out [pd::arg 1 int] + if {$out < 0 || $out >= $@num_outlets} { + pd::post "error: add: outlet number out of range" + return } + dict set @routing $sel $out +} - 1_clear { - set @routing {} +proc+ dynroute::1_remove {self args} { + set sel [pd::arg 0 any] + set out [pd::arg 1 int] + if {$out < 0 || $out >= $@num_outlets} { + pd::post "error: add: outlet number out of range" + return } + catch {dict unset @routing $sel $out} +} + +proc+ dynroute::1_clear {self} { + set @routing {} } + +pd::class dynroute diff --git a/examples/list_change-help.pd b/examples/list_change-help.pd index 430b23d..3b3a8ba 100644 --- a/examples/list_change-help.pd +++ b/examples/list_change-help.pd @@ -1,21 +1,21 @@ -#N canvas 617 384 635 406 10; -#X obj 54 240 list_change; -#X text 144 236 right inlet sets internal value without output anything -; -#X obj 71 271 bng 15 250 50 0 empty empty empty 17 7 0 10 -262144 -1 --1; -#X obj 54 309 print; -#X text 33 21 Outputs its input (a list) only when it changes. You -can set the current value using the right inlet \, or bang to force -output; -#X msg 117 201 list foo bar; -#X msg 69 140 list foo bar; -#X msg 77 163 list bar baz; -#X msg 54 104 bang; -#X text 98 103 output current value; -#X connect 0 0 2 0; -#X connect 0 0 3 0; -#X connect 5 0 0 1; -#X connect 6 0 0 0; -#X connect 7 0 0 0; -#X connect 8 0 0 0; +#N canvas 294 76 635 406 10; +#X obj 54 240 list_change; +#X text 144 236 right inlet sets internal value without output anything +; +#X obj 71 271 bng 15 250 50 0 empty empty empty 17 7 0 10 -262144 -1 +-1; +#X obj 54 309 print; +#X text 33 21 Outputs its input (a list) only when it changes. You +can set the current value using the right inlet \, or bang to force +output; +#X msg 117 201 list foo bar; +#X msg 69 140 list foo bar; +#X msg 77 163 list bar baz; +#X msg 54 104 bang; +#X text 98 103 output current value; +#X connect 0 0 2 0; +#X connect 0 0 3 0; +#X connect 5 0 0 1; +#X connect 6 0 0 0; +#X connect 7 0 0 0; +#X connect 8 0 0 0; diff --git a/examples/list_change.tcl b/examples/list_change.tcl index 2c70937..26190e4 100644 --- a/examples/list_change.tcl +++ b/examples/list_change.tcl @@ -1,31 +1,32 @@ -package require Tclpd 0.2.1 -package require TclpdLib 0.17 +package require Tclpd 0.2.3 +package require TclpdLib 0.19 -pd::class list_change { - constructor { - # add second inlet (first created by default) - pd::add_inlet $self list +proc+ list_change::constructor {self args} { + # add second inlet (first created by default) + pd::add_inlet $self list - # add outlet - pd::add_outlet $self list + # add outlet + pd::add_outlet $self list - set @curlist {} - } - - 0_list { - # HOT inlet - if {$args != $@curlist} { - set @curlist $args - pd::outlet $self 0 list $@curlist - } - } + set @curlist {} +} - 0_bang { +proc+ list_change::0_list {self args} { + # HOT inlet + if {$args != $@curlist} { + set @curlist $args pd::outlet $self 0 list $@curlist } +} - 1_list { - # COLD inlet - set @curlist $args - } +proc+ list_change::0_bang {self} { + if {$@curlist == {}} return + pd::outlet $self 0 list $@curlist } + +proc+ list_change::1_list {self args} { + # COLD inlet + set @curlist $args +} + +pd::class list_change diff --git a/examples/slider2.tcl b/examples/slider2.tcl index 23a2141..adc2e35 100644 --- a/examples/slider2.tcl +++ b/examples/slider2.tcl @@ -1,5 +1,5 @@ -package require Tclpd 0.2.2 -package require TclpdLib 0.17 +package require Tclpd 0.2.3 +package require TclpdLib 0.19 set ::script_path [file dirname [info script]] @@ -59,215 +59,215 @@ pd::guiproc slider2_update {self c x y config state} { } } -pd::guiclass slider2 { - constructor { - pd::add_outlet $self float - sys_gui "source {[file join $::script_path properties.tcl]}\n" - # set defaults: - set @config { - -width 15 -height 130 -headsz 3 -rangebottom 0 -rangetop 127 - -init 0 -initvalue 0 -jumponclick 0 -label "" -labelpos "top" - -orient "vertical" -sendsymbol "" -receivesymbol "" - -fgcolor "#000000" -bgcolor "#ffffff" -lblcolor "#000000" - } - set @state {_min 0 _max 127 _rev 0} - # expanded ($n) send/recv symbols: - set @send {} - set @recv {} - ::$self 0 config {*}$args +proc+ slider2::constructor {self args} { + pd::add_outlet $self float + sys_gui "source {[file join $::script_path properties.tcl]}\n" + # set defaults: + set @config { + -width 15 -height 130 -headsz 3 -rangebottom 0 -rangetop 127 + -init 0 -initvalue 0 -jumponclick 0 -label "" -labelpos "top" + -orient "vertical" -sendsymbol "" -receivesymbol "" + -fgcolor "#000000" -bgcolor "#ffffff" -lblcolor "#000000" } + set @state {_min 0 _max 127 _rev 0} + # expanded ($n) send/recv symbols: + set @send {} + set @recv {} + 0_config $self {*}$args +} - destructor { - if {[dict get $@config -receivesymbol] != {}} { - pd_unbind [tclpd_get_instance_pd $self] $@recv - } +proc+ slider2::destructor {self} { + if {[dict get $@config -receivesymbol] != {}} { + pd_unbind [tclpd_get_instance_pd $self] $@recv } +} - 0_loadbang { - if {[dict get $@config -init]} {$self 0 bang} - } +proc+ slider2::0_loadbang {self} { + if {[dict get $@config -init]} {0_bang $self} +} - 0_config { - set newconf [list] - set optlist [pd::strip_selectors $args] - set optlist [pd::strip_empty $optlist] - set int_opts {-width -height -cellsize} - set bool_opts {-init -jumponclick} - set ui_opts {-fgcolor -bgcolor -lblcolor -orient -width -height} - set upd_opts {-rangebottom -rangetop -label -labelpos} - set conn_opts {-sendsymbol -receivesymbol} - set ui 0 - set upd 0 - foreach {k v} $optlist { - if {![dict exists $@config $k]} { - return -code error "unknown option '$k'" - } - if {[dict get $@config $k] == $v} {continue} - if {[lsearch -exact $int_opts $k] != -1} {set v [expr {int($v)}]} - if {[lsearch -exact $bool_opts $k] != -1} {set v [expr {int($v)!=0}]} - if {[lsearch -exact $ui_opts $k] != -1} {set ui 1} - if {[lsearch -exact $upd_opts $k] != -1} {set upd 1} - dict set newconf $k $v - } - # process -{send,receive}symbol - if {[dict exists $newconf -receivesymbol]} { - set new_recv [dict get $newconf -receivesymbol] - set selfpd [tclpd_get_instance_pd $self] - if {[dict get $@config -receivesymbol] != {}} { - pd_unbind $selfpd $@recv - } - if {$new_recv != {}} { - set @recv [canvas_realizedollar \ - [tclpd_get_glist $self] [gensym $new_recv]] - pd_bind $selfpd $@recv - } else {set @recv {}} - } - if {[dict exists $newconf -sendsymbol]} { - set new_send [dict get $newconf -sendsymbol] - if {$new_send != {}} { - set @send [canvas_realizedollar \ - [tclpd_get_glist $self] [gensym $new_send]] - } else {set @send {}} - } - # changing orient -> swap sizes - if {[dict exists $newconf -orient] && ![dict exists $newconf -width] - && ![dict exists $newconf -height]} { - dict set newconf -width [dict get $@config -height] - dict set newconf -height [dict get $@config -width] - } - # no errors up to this point. we can safely merge options - set @config [dict merge $@config $newconf] - # adjust reverse range - set a [dict get $@config -rangebottom] - set b [dict get $@config -rangetop] - dict set @state _min [expr {$a>$b?$b:$a}] - dict set @state _max [expr {$a>$b?$a:$b}] - dict set @state _rev [expr {$a>$b}] - set orient [dict get $@config -orient] - switch $orient { - horizontal {set dim [dict get $@config -width]; set mul 1} - vertical {set dim [dict get $@config -height]; set mul -1} - default {return -code error "invalid value '$orient' for -orient"} - } - # recompute pix2units conversion - set @pix2units [expr {(2.0 * [dict get $@state _rev] - 1.0) * - ( [dict get $@state _max] - [dict get $@state _min] ) * - $mul / ( $dim - [dict get $@config -headsz])}] - # if ui changed, update it - if {$ui && [info exists @c]} { - sys_gui [list $@c delete $self]\n - sys_gui [list slider2_draw_new $self $@c $@x $@y $@config $@state]\n - } elseif {$upd && [info exists @c]} { - sys_gui [list slider2_update $self $@c $@x $@y $@config $@state]\n - } - if {[dict exists $newconf -width] || [dict exists $newconf -height]} { - canvas_fixlinesfor \ - [tclpd_get_glist $self] [tclpd_get_instance_text $self] +proc+ slider2::0_config {self args} { + set newconf [list] + set optlist [pd::strip_selectors $args] + set optlist [pd::strip_empty $optlist] + set int_opts {-width -height -cellsize} + set bool_opts {-init -jumponclick} + set ui_opts {-fgcolor -bgcolor -lblcolor -orient -width -height} + set upd_opts {-rangebottom -rangetop -label -labelpos} + set conn_opts {-sendsymbol -receivesymbol} + set ui 0 + set upd 0 + foreach {k v} $optlist { + if {![dict exists $@config $k]} { + return -code error "unknown option '$k'" } + if {[dict get $@config $k] == $v} {continue} + if {[lsearch -exact $int_opts $k] != -1} {set v [expr {int($v)}]} + if {[lsearch -exact $bool_opts $k] != -1} {set v [expr {int($v)!=0}]} + if {[lsearch -exact $ui_opts $k] != -1} {set ui 1} + if {[lsearch -exact $upd_opts $k] != -1} {set upd 1} + dict set newconf $k $v } - - 0_set { - foreach v {min max} {set $v [dict get $@state _$v]} - set f [pd::arg 0 float] - if {$f < $min} {set f $min} - if {$f > $max} {set f $max} - dict set @config -initvalue $f - if {[info exists @c]} { - # update ui: - sys_gui [list slider2_update $self $@c $@x $@y $@config $@state]\n + # process -{send,receive}symbol + if {[dict exists $newconf -receivesymbol]} { + set new_recv [dict get $newconf -receivesymbol] + set selfpd [tclpd_get_instance_pd $self] + if {[dict get $@config -receivesymbol] != {}} { + pd_unbind $selfpd $@recv } + if {$new_recv != {}} { + set @recv [canvas_realizedollar \ + [tclpd_get_glist $self] [gensym $new_recv]] + pd_bind $selfpd $@recv + } else {set @recv {}} } - - 0_bang { - foreach v {initvalue} {set $v [dict get $@config -$v]} - pd::outlet $self 0 float $initvalue - if {$@send != {}} { - set s_thing [$@send cget -s_thing] - if {$s_thing != {NULL}} {pd_float $s_thing $initvalue} - } + if {[dict exists $newconf -sendsymbol]} { + set new_send [dict get $newconf -sendsymbol] + if {$new_send != {}} { + set @send [canvas_realizedollar \ + [tclpd_get_glist $self] [gensym $new_send]] + } else {set @send {}} } - - 0_float { - $self 0 set {*}$args - $self 0 bang + # changing orient -> swap sizes + if {[dict exists $newconf -orient] && ![dict exists $newconf -width] + && ![dict exists $newconf -height]} { + dict set newconf -width [dict get $@config -height] + dict set newconf -height [dict get $@config -width] } - - object_save { - return [list #X obj $@x $@y slider2 {*}[pd::add_empty $@config] \;] + # no errors up to this point. we can safely merge options + set @config [dict merge $@config $newconf] + # adjust reverse range + set a [dict get $@config -rangebottom] + set b [dict get $@config -rangetop] + dict set @state _min [expr {$a>$b?$b:$a}] + dict set @state _max [expr {$a>$b?$a:$b}] + dict set @state _rev [expr {$a>$b}] + set orient [dict get $@config -orient] + switch $orient { + horizontal {set dim [dict get $@config -width]; set mul 1} + vertical {set dim [dict get $@config -height]; set mul -1} + default {return -code error "invalid value '$orient' for -orient"} } - - object_properties { - set c [string map {$ \\$} $@config] - gfxstub_new [tclpd_get_object_pd $self] [tclpd_get_instance $self] \ - [list propertieswindow %s $c "\[slider2\] properties"]\n + # recompute pix2units conversion + set @pix2units [expr {(2.0 * [dict get $@state _rev] - 1.0) * + ( [dict get $@state _max] - [dict get $@state _min] ) * + $mul / ( $dim - [dict get $@config -headsz])}] + # if ui changed, update it + if {$ui && [info exists @c]} { + sys_gui [list $@c delete $self]\n + sys_gui [list slider2_draw_new $self $@c $@x $@y $@config $@state]\n + } elseif {$upd && [info exists @c]} { + sys_gui [list slider2_update $self $@c $@x $@y $@config $@state]\n } - - widgetbehavior_getrect { - lassign $args x1 y1 - set x2 [expr {1+$x1+[dict get $@config -width]}] - set y2 [expr {1+$y1+[dict get $@config -height]}] - return [list $x1 $y1 $x2 $y2] + if {[dict exists $newconf -width] || [dict exists $newconf -height]} { + canvas_fixlinesfor \ + [tclpd_get_glist $self] [tclpd_get_instance_text $self] } +} - widgetbehavior_displace { - lassign $args dx dy - if {$dx != 0 || $dy != 0} { - incr @x $dx; incr @y $dy - sys_gui [list $@c move $self $dx $dy]\n - } - return [list $@x $@y] +proc+ slider2::0_set {self args} { + foreach v {min max} {set $v [dict get $@state _$v]} + set f [pd::arg 0 float] + if {$f < $min} {set f $min} + if {$f > $max} {set f $max} + dict set @config -initvalue $f + if {[info exists @c]} { + # update ui: + sys_gui [list slider2_update $self $@c $@x $@y $@config $@state]\n } +} - widgetbehavior_select { - lassign $args sel - sys_gui [list $@c itemconfigure $self&&!label$self -outline [lindex \ - [list [dict get $@config -fgcolor] {blue}] $sel]]\n +proc+ slider2::0_bang {self} { + foreach v {initvalue} {set $v [dict get $@config -$v]} + pd::outlet $self 0 float $initvalue + if {$@send != {}} { + set s_thing [$@send cget -s_thing] + if {$s_thing != {NULL}} {pd_float $s_thing $initvalue} } +} - widgetbehavior_vis { - lassign $args @c @x @y vis - if {$vis} { - sys_gui [list slider2_draw_new $self $@c $@x $@y $@config $@state]\n - } else { - sys_gui [list $@c delete $self]\n - } +proc+ slider2::0_float {self args} { + 0_set $self {*}$args + 0_bang $self +} + +proc+ slider2::save {self} { + return [list #X obj $@x $@y slider2 {*}[pd::add_empty $@config] \;] +} + +proc+ slider2::properties {self} { + set c [string map {$ \\$} $@config] + gfxstub_new [tclpd_get_object_pd $self] [tclpd_get_instance $self] \ + [list propertieswindow %s $c "\[slider2\] properties"]\n +} + +proc+ slider2::widgetbehavior_getrect {self args} { + lassign $args x1 y1 + set x2 [expr {1+$x1+[dict get $@config -width]}] + set y2 [expr {1+$y1+[dict get $@config -height]}] + return [list $x1 $y1 $x2 $y2] +} + +proc+ slider2::widgetbehavior_displace {self args} { + lassign $args dx dy + if {$dx != 0 || $dy != 0} { + incr @x $dx; incr @y $dy + sys_gui [list $@c move $self $dx $dy]\n } + return [list $@x $@y] +} - widgetbehavior_click { - lassign $args x y shift alt dbl doit - set h [dict get $@config -height] - set ypix [expr {[lindex $args 1]-$@y-1}] - if {$ypix < 0 || $ypix >= $h} {return} - if {$doit} { - switch [dict get $@config -orient] { - horizontal { - set @motion_start_x $x - set @motion_curr_x $x - } - vertical { - set @motion_start_y $y - set @motion_curr_y $y - } - } - set @motion_start_v [dict get $@config -initvalue] - tclpd_guiclass_grab [tclpd_get_instance $self] \ - [tclpd_get_glist $self] $x $y - } +proc+ slider2::widgetbehavior_select {self args} { + lassign $args sel + sys_gui [list $@c itemconfigure $self&&!label$self -outline [lindex \ + [list [dict get $@config -fgcolor] {blue}] $sel]]\n +} + +proc+ slider2::widgetbehavior_vis {self args} { + lassign $args @c @x @y vis + if {$vis} { + sys_gui [list slider2_draw_new $self $@c $@x $@y $@config $@state]\n + } else { + sys_gui [list $@c delete $self]\n } +} - widgetbehavior_motion { - lassign $args dx dy +proc+ slider2::widgetbehavior_click {self args} { + lassign $args x y shift alt dbl doit + set h [dict get $@config -height] + set ypix [expr {[lindex $args 1]-$@y-1}] + if {$ypix < 0 || $ypix >= $h} {return} + if {$doit} { switch [dict get $@config -orient] { horizontal { - set @motion_curr_x [expr {$dx+$@motion_curr_x}] - set pixdelta [expr {-1*($@motion_curr_x-$@motion_start_x)}] + set @motion_start_x $x + set @motion_curr_x $x } vertical { - set @motion_curr_y [expr {$dy+$@motion_curr_y}] - set pixdelta [expr {-1*($@motion_curr_y-$@motion_start_y)}] + set @motion_start_y $y + set @motion_curr_y $y } } - set f [expr {$@motion_start_v+$pixdelta*$@pix2units}] - $self 0 float {*}[pd::add_selectors [list $f]] + set @motion_start_v [dict get $@config -initvalue] + tclpd_guiclass_grab [tclpd_get_instance $self] \ + [tclpd_get_glist $self] $x $y + } +} + +proc+ slider2::widgetbehavior_motion {self args} { + lassign $args dx dy + switch [dict get $@config -orient] { + horizontal { + set @motion_curr_x [expr {$dx+$@motion_curr_x}] + set pixdelta [expr {-1*($@motion_curr_x-$@motion_start_x)}] + } + vertical { + set @motion_curr_y [expr {$dy+$@motion_curr_y}] + set pixdelta [expr {-1*($@motion_curr_y-$@motion_start_y)}] + } } + set f [expr {$@motion_start_v+$pixdelta*$@pix2units}] + 0_float $self {*}[pd::add_selectors [list $f]] } + +pd::guiclass slider2 diff --git a/pdlib.tcl b/pdlib.tcl index d6509b9..faf3f5a 100644 --- a/pdlib.tcl +++ b/pdlib.tcl @@ -1,13 +1,20 @@ # TCL objectized library for PD api -# by Federico Ferri - (C) 2007-2009 +# by Federico Ferri - (C) 2007-2011 -package provide TclpdLib 0.18 +package provide TclpdLib 0.19 package require Tcl 8.5 -package require Tclpd 0.2.2 +package require Tclpd 0.2.3 set verbose 0 +namespace eval :: { + proc proc+ {name arglist body} { + set body2 [concat "global _;" [regsub -all @(\\\$?\[\\w\\?\]+) $body _(\$self:\\1)]] + uplevel #0 [list proc $name $arglist $body2] + } +} + namespace eval ::pd { proc error_msg {m} { return "pdlib: [uplevel {lindex [info level 0] 0}]: error: $m" @@ -74,62 +81,59 @@ namespace eval ::pd { } } - # used internally (from dispatcher) to call a class method - proc call_classmethod {classname self inlet sel args} { - if $::verbose {post [info level 0]} - set m_sel "::${classname}_${inlet}_${sel}" - if {[llength [info commands $m_sel]] > 0} { - return [$m_sel $self {*}$args] - } - set m_any "::${classname}_${inlet}_anything" - if {[llength [info commands $m_any]] > 0} { - return [$m_any $self [list symbol $sel] {*}$args] - } - # don't notify if a loadbang method does not exists - if {$sel != "loadbang"} { - post "Tcl class $classname: inlet $inlet: no such method: $sel" - } - } - - proc read_class_definition {classname def} { + proc read_class_options {classname options} { set patchable_flag 1 set noinlet_flag 0 - proc ::${classname}_object_save {self args} {return ""} - - foreach {id arg} $def { - switch -- $id { - patchable { - if {$arg != 0 && $arg != 1} { - return -code error [error_msg "patchable must be 0/1"] + foreach {k v} $options { + switch -- $k { + -patchable { + if {$v != 0 && $v != 1} { + return -code error [error_msg "-patchable must be 0/1"] } - set patchable_flag $arg + set patchable_flag $v } - noinlet { - if {$arg != 0 && $arg != 1} { - return -code error [error_msg "noinlet must be 0/1"] + -noinlet { + if {$v != 0 && $v != 1} { + return -code error [error_msg "-noinlet must be 0/1"] } - set noinlet_flag $arg + set noinlet_flag $v } default { - proc ::${classname}_${id} {self args} [concat "global _;" [regsub -all @(\\\$?\[\\w\\?\]+) $arg _(\$self:\\1)]] + return -code error [error_msg "unknown option: $k"] } } } - # class level dispatcher (sort of class constructor) - proc ::$classname {self args} " - if \$::verbose {::pd::post \[info level 0\]} - # define object dispatcher: - proc ::\$self {inlet selector args} \" - if \\\$::verbose {::pd::post \\\[info level 0\\\]} - ::pd::call_classmethod $classname \$self \\\$inlet \\\$selector {*}\\\$args - \" - # call constructor: - ::${classname}_constructor \$self {*}\$args - return \$self + proc ::${classname}::dispatcher {self function args} " + if {\$function == \"method\"} { + set inlet \[lindex \$args 0\] + set selector \[lindex \$args 1\] + set argsr \[lrange \$args 2 end\] + set i_s ::${classname}::\${inlet}_\${selector} + set i_a ::${classname}::\${inlet}_anything + if {\[info procs \$i_s\] != {}} { + uplevel \[linsert \$argsr 0 \$i_s \$self\] + } elseif {\[info procs \$i_s\] == {} && \[info procs \$i_a\] != {}} { + uplevel \[linsert \$argsr 0 \$i_a \$self \[pd::add_selector \$selector\]\] + } else { + return -code error \"${classname}: no such method: \$i_s\" + } + } elseif {\$function == \"widgetbehavior\"} { + set subfunction \[lindex \$args 0\] + set argsr \[lrange \$args 1 end\] + uplevel \[linsert \$argsr 0 ::${classname}::\${function}_\${subfunction} \$self] + } else { + uplevel \[linsert \$args 0 ::${classname}::\$function \$self\] + } " + # some dummy function to suppress eventual errors if they are not deifned: + proc ::${classname}::constructor {self args} {} + proc ::${classname}::destructor {self} {} + proc ::${classname}::0_loadbang {self} {} + proc ::${classname}::save {self args} {return ""} + # TODO: c->c_gobj = (typeflag >= CLASS_GOBJ) set flag [expr { 8 * ($noinlet_flag != 0) + @@ -140,19 +144,19 @@ namespace eval ::pd { } # this handles the pd::class definition - proc class {classname def} { + proc class {classname args} { if $::verbose {post [lrange [info level 0] 0 end-1]} - set flag [read_class_definition $classname $def] + set flag [read_class_options $classname $args] # this wraps the call to class_new() tclpd_class_new $classname $flag } - proc guiclass {classname def} { + proc guiclass {classname args} { if $::verbose {post [lrange [info level 0] 0 end-1]} - set flag [read_class_definition $classname $def] + set flag [read_class_options $classname $args] # this wraps the call to class_new() tclpd_guiclass_new $classname $flag @@ -217,10 +221,14 @@ namespace eval ::pd { return $r } + proc add_selector {s} { + return [list [lindex {float symbol} [catch {expr $s}]] $s] + } + proc add_selectors {tcllist} { set r {} foreach i $tcllist { - lappend r [list [lindex {float symbol} [catch {expr $i}]] $i] + lappend r [add_selector $i] } return $r } diff --git a/tcl_class.c b/tcl_class.c index c0c7485..6e700c2 100644 --- a/tcl_class.c +++ b/tcl_class.c @@ -136,6 +136,8 @@ t_class* tclpd_class_new(const char* name, int flags) { class_table_add(name, c); class_addanything(c, tclpd_anything); + + // is this really necessary given that there is already a 'anything' handler? class_addmethod(c, (t_method)tclpd_loadbang, gensym("loadbang"), A_NULL); // always set save function. it will call the default if @@ -145,7 +147,7 @@ t_class* tclpd_class_new(const char* name, int flags) { // check if properties function exists in tcl space. char buf[80]; int res_i; - snprintf(buf, 80, "llength [info procs ::%s_object_properties]", name); + snprintf(buf, 80, "llength [info procs ::%s::properties]", name); if(Tcl_Eval(tcl_for_pd, buf) == TCL_OK) { Tcl_Obj* res = Tcl_GetObjResult(tcl_for_pd); if(Tcl_GetIntFromObj(tcl_for_pd, res, &res_i) == TCL_OK) { @@ -196,31 +198,37 @@ t_tcl* tclpd_new(t_symbol* classsym, int ac, t_atom* at) { x->x_glist = (t_glist*)canvas_getcurrent(); x->classname = Tcl_NewStringObj(name, -1); - char s[64]; - snprintf(s, 64, "tclpd:%s:x%lx", name, objectSequentialId++); - x->self = Tcl_NewStringObj(s, -1); - - // the lifetime of x->classname and x->self is greater than this + char so[64]; + snprintf(so, 64, "tclpd.%s.x%lx", name, objectSequentialId++); + x->self = Tcl_NewStringObj(so, -1); + char sd[64]; + snprintf(sd, 64, "::%s::dispatcher", name); + x->dispatcher = Tcl_NewStringObj(sd, -1); + + // the lifetime of x->{classname,self,dispatcher} is greater than this // function, hence they get an extra Tcl_IncrRefCount here: // (see tclpd_free()) Tcl_IncrRefCount(x->classname); Tcl_IncrRefCount(x->self); + Tcl_IncrRefCount(x->dispatcher); // store in object table (for later lookup) - if(!object_table_get(s)) - object_table_add(s, x); + if(!object_table_get(so)) + object_table_add(so, x); // build constructor command - Tcl_Obj *av[ac+2]; InitArray(av, ac+2, NULL); - av[0] = x->classname; + Tcl_Obj *av[ac+3]; InitArray(av, ac+3, NULL); + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("constructor", -1); + Tcl_IncrRefCount(av[2]); for(int i=0; iclassname, NULL), -1); - Tcl_AppendToObj(sym, "_destructor", -1); - Tcl_Obj *av[2]; InitArray(av, 2, NULL); - av[0] = sym; + Tcl_Obj *av[3]; InitArray(av, 3, NULL); + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); av[1] = x->self; Tcl_IncrRefCount(av[1]); + av[2] = Tcl_NewStringObj("destructor", -1); + Tcl_IncrRefCount(av[2]); + // call destructor - if(Tcl_EvalObjv(tcl_for_pd, 2, av, 0) != TCL_OK) { + if(Tcl_EvalObjv(tcl_for_pd, 3, av, 0) != TCL_OK) { #ifdef DEBUG - post("tclpd_free: failed"); + post("tclpd_free: failed to call destructor"); #endif } + + // decrement reference counter Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); + Tcl_DecrRefCount(av[2]); // here ends the lifetime of x->classname and x->self Tcl_DecrRefCount(x->self); Tcl_DecrRefCount(x->classname); + Tcl_DecrRefCount(x->dispatcher); #ifdef DEBUG post("tclpd_free called"); #endif @@ -280,30 +293,34 @@ void tclpd_anything(t_tcl* x, t_symbol* s, int ac, t_atom* at) { } void tclpd_inlet_anything(t_tcl* x, int inlet, t_symbol* s, int ac, t_atom* at) { - // proxy method - format: ... - Tcl_Obj* av[ac+3]; InitArray(av, ac+3, NULL); + // proxy method - format: method args... + Tcl_Obj* av[ac+5]; InitArray(av, ac+5, NULL); int result; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewIntObj(inlet); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj(s->s_name, -1); + av[2] = Tcl_NewStringObj("method", -1); Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewIntObj(inlet); + Tcl_IncrRefCount(av[3]); + av[4] = Tcl_NewStringObj(s->s_name, -1); + Tcl_IncrRefCount(av[4]); for(int i=0; iself; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("object", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("save", -1); Tcl_IncrRefCount(av[2]); + int result = Tcl_EvalObjv(tcl_for_pd, 3, av, 0); if(result == TCL_OK) { res = Tcl_GetObjResult(tcl_for_pd); @@ -429,6 +447,7 @@ void tclpd_save(t_gobj* z, t_binbuf* b) { pd_error(x, "Tcl: object save: failed"); tclpd_interp_error(x, result); } + Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); @@ -436,23 +455,33 @@ void tclpd_save(t_gobj* z, t_binbuf* b) { void tclpd_properties(t_gobj* z, t_glist* owner) { Tcl_Obj* av[3]; InitArray(av, 3, NULL); - Tcl_Obj* res; t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("object", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); av[2] = Tcl_NewStringObj("properties", -1); Tcl_IncrRefCount(av[2]); + int result = Tcl_EvalObjv(tcl_for_pd, 3, av, 0); if(result != TCL_OK) { //res = Tcl_GetObjResult(tcl_for_pd); pd_error(x, "Tcl: object properties: failed"); tclpd_interp_error(x, result); } + Tcl_DecrRefCount(av[0]); Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); } + +void tclpd_class_namespace_init(const char* classname) { + char cmd[256]; + snprintf(cmd, 256, "if [namespace exists ::%s] " + "{namespace delete ::%s}; " + "namespace eval ::%s {}", + classname, classname, classname); + Tcl_Eval(tcl_for_pd, cmd); +} diff --git a/tcl_extras.h b/tcl_extras.h index 2ae0116..0f563a8 100644 --- a/tcl_extras.h +++ b/tcl_extras.h @@ -10,7 +10,7 @@ #define PATH_MAX 4096 #endif -#define TCLPD_VERSION "0.2.2" +#define TCLPD_VERSION "0.2.3" #define InitArray(name, size, value) for(int zz=0; zz<(size); zz++) name[zz]=value @@ -19,6 +19,7 @@ typedef struct _t_tcl { t_glist* x_glist; Tcl_Obj* self; Tcl_Obj* classname; + Tcl_Obj* dispatcher; int ninlets; } t_tcl; @@ -31,7 +32,7 @@ typedef struct _t_proxyinlet { t_atom* argv; } t_proxyinlet; -/* tcl_proxyinlet.cxx */ +/* tcl_proxyinlet.c */ extern t_class* proxyinlet_class; void proxyinlet_init(t_proxyinlet* x); void proxyinlet_clear(t_proxyinlet* x); @@ -41,22 +42,22 @@ t_atom* proxyinlet_get_atoms(t_proxyinlet* x); void proxyinlet_clone(t_proxyinlet* x, t_proxyinlet* y); void proxyinlet_setup(void); -/* tcl_wrap.cxx */ +/* tcl_wrap.c */ extern int Tclpd_SafeInit(Tcl_Interp *interp); -/* tcl_typemap.cxx */ +/* tcl_typemap.c */ int pd_to_tcl(t_atom* input, Tcl_Obj** output); int tcl_to_pd(Tcl_Obj* input, t_atom* output); const char* atom_type_string(t_atom* a); const char* atom_symbol_value(t_atom* a); float atom_float_value(t_atom* a); -/* tcl_setup.cxx */ +/* tclpd.c */ extern Tcl_Interp* tcl_for_pd; extern void tclpd_setup(void); void tclpd_interp_error(t_tcl* x, int result); -/* tcl_class.cxx */ +/* tcl_class.c */ t_class* tclpd_class_new(const char* name, int flags); t_class* tclpd_guiclass_new(const char* name, int flags); t_tcl* tclpd_new(t_symbol* classsym, int ac, t_atom* at); @@ -78,8 +79,9 @@ void poststring2(const char* s); extern void text_save(t_gobj *z, t_binbuf *b); void tclpd_save(t_gobj* z, t_binbuf* b); void tclpd_properties(t_gobj* z, t_glist* owner); +void tclpd_class_namespace_init(const char* classname); -/* tcl_widgetbehavior.cxx */ +/* tcl_widgetbehavior.c */ void tclpd_guiclass_getrect(t_gobj* z, t_glist* owner, int* xp1, int* yp1, int* xp2, int* yp2); void tclpd_guiclass_displace(t_gobj* z, t_glist* glist, int dx, int dy); void tclpd_guiclass_select(t_gobj* z, t_glist* glist, int selected); @@ -90,7 +92,7 @@ int tclpd_guiclass_click(t_gobj* z, t_glist* glist, int xpix, int ypix, int shif void tclpd_guiclass_motion(t_tcl* x, t_floatarg dx, t_floatarg dy); void tclpd_guiclass_grab(t_tcl* x, t_glist* glist, int xpix, int ypix); -/* tcl_loader.cxx */ +/* tcl_loader.c */ extern int tclpd_do_load_lib(t_canvas* canvas, char* objectname); /* pd loader private stuff: */ typedef int (*loader_t)(t_canvas *canvas, char* classname); diff --git a/tcl_loader.c b/tcl_loader.c index 95d0232..0766a8c 100644 --- a/tcl_loader.c +++ b/tcl_loader.c @@ -47,8 +47,13 @@ gotone: strncat(filename, nameptr, MAXPDSTRING-strlen(filename)); filename[MAXPDSTRING-1] = 0; + int result; + + // create the required tcl namespace for the class + tclpd_class_namespace_init(classname); + // load tcl external: - int result = Tcl_EvalFile(tcl_for_pd, filename); + result = Tcl_EvalFile(tcl_for_pd, filename); if(result == TCL_OK) { post("Tcl loader: loaded %s", filename); } else { @@ -57,6 +62,19 @@ gotone: return 0; } +#ifdef TCLPD_CALL_SETUP + // call the setup method: + char cmd[64]; + snprintf(cmd, 64, "::%s::setup", classname); + result = Tcl_Eval(tcl_for_pd, cmd); + if(result == TCL_OK) { + } else { + post("Tcl loader: error in %s %s::setup", filename, classname); + tclpd_interp_error(NULL, result); + return 0; + } +#endif // TCLPD_CALL_SETUP + class_set_extern_dir(&s_); sys_putonloadlist(objectname); return 1; diff --git a/tcl_widgetbehavior.c b/tcl_widgetbehavior.c index 56e21dc..2a1186f 100644 --- a/tcl_widgetbehavior.c +++ b/tcl_widgetbehavior.c @@ -2,19 +2,20 @@ #include void tclpd_guiclass_motion(t_tcl* x, t_floatarg dx, t_floatarg dy) { - Tcl_Obj* av[5]; InitArray(av, 5, NULL); - int tmp[4], i, length; - av[0] = x->self; + Tcl_Obj* av[6]; InitArray(av, 6, NULL); + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("motion", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewDoubleObj(dx); + av[3] = Tcl_NewStringObj("motion", -1); Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewDoubleObj(dy); + av[4] = Tcl_NewDoubleObj(dx); Tcl_IncrRefCount(av[4]); - int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); + av[5] = Tcl_NewDoubleObj(dy); + Tcl_IncrRefCount(av[5]); + int result = Tcl_EvalObjv(tcl_for_pd, 6, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; @@ -27,6 +28,7 @@ cleanup: Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); + Tcl_DecrRefCount(av[5]); } void tclpd_guiclass_grab(t_tcl* x, t_glist* glist, int xpix, int ypix) { @@ -35,29 +37,31 @@ void tclpd_guiclass_grab(t_tcl* x, t_glist* glist, int xpix, int ypix) { } int tclpd_guiclass_click(t_gobj* z, t_glist* glist, int xpix, int ypix, int shift, int alt, int dbl, int doit) { - Tcl_Obj* av[9]; InitArray(av, 9, NULL); + Tcl_Obj* av[10]; InitArray(av, 10, NULL); Tcl_Obj* o = NULL; int i = 0; t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("click", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(xpix); + av[3] = Tcl_NewStringObj("click", -1); Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(ypix); + av[4] = Tcl_NewIntObj(xpix); Tcl_IncrRefCount(av[4]); - av[5] = Tcl_NewIntObj(shift); + av[5] = Tcl_NewIntObj(ypix); Tcl_IncrRefCount(av[5]); - av[6] = Tcl_NewIntObj(alt); + av[6] = Tcl_NewIntObj(shift); Tcl_IncrRefCount(av[6]); - av[7] = Tcl_NewIntObj(dbl); + av[7] = Tcl_NewIntObj(alt); Tcl_IncrRefCount(av[7]); - av[8] = Tcl_NewIntObj(doit); + av[8] = Tcl_NewIntObj(dbl); Tcl_IncrRefCount(av[8]); - int result = Tcl_EvalObjv(tcl_for_pd, 9, av, 0); + av[9] = Tcl_NewIntObj(doit); + Tcl_IncrRefCount(av[9]); + int result = Tcl_EvalObjv(tcl_for_pd, 10, av, 0); if(result != TCL_OK) { goto error; } @@ -85,28 +89,31 @@ cleanup: Tcl_DecrRefCount(av[6]); Tcl_DecrRefCount(av[7]); Tcl_DecrRefCount(av[8]); + Tcl_DecrRefCount(av[9]); // return value (BOOL) means 'object wants to be clicked' (g_editor.c:1270) return i; } void tclpd_guiclass_getrect(t_gobj* z, t_glist* owner, int* xp1, int* yp1, int* xp2, int* yp2) { - Tcl_Obj* av[5]; InitArray(av, 5, NULL); + Tcl_Obj* av[6]; InitArray(av, 6, NULL); Tcl_Obj* o; Tcl_Obj* theList = NULL; int tmp[4], i, length; t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("getrect", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(text_xpix(&x->o, owner)); + av[3] = Tcl_NewStringObj("getrect", -1); Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(text_ypix(&x->o, owner)); + av[4] = Tcl_NewIntObj(text_xpix(&x->o, owner)); Tcl_IncrRefCount(av[4]); - int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); + av[5] = Tcl_NewIntObj(text_ypix(&x->o, owner)); + Tcl_IncrRefCount(av[5]); + int result = Tcl_EvalObjv(tcl_for_pd, 6, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; @@ -147,25 +154,28 @@ cleanup: Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); + Tcl_DecrRefCount(av[5]); } void tclpd_guiclass_displace(t_gobj* z, t_glist* glist, int dx, int dy) { - Tcl_Obj* av[5]; InitArray(av, 5, NULL); + Tcl_Obj* av[6]; InitArray(av, 6, NULL); Tcl_Obj* theList = NULL; Tcl_Obj* o; int length, i, tmp[2]; t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("displace", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(dx); + av[3] = Tcl_NewStringObj("displace", -1); Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(dy); + av[4] = Tcl_NewIntObj(dx); Tcl_IncrRefCount(av[4]); - int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); + av[5] = Tcl_NewIntObj(dy); + Tcl_IncrRefCount(av[5]); + int result = Tcl_EvalObjv(tcl_for_pd, 6, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; @@ -208,20 +218,23 @@ cleanup: Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); Tcl_DecrRefCount(av[4]); + Tcl_DecrRefCount(av[5]); } void tclpd_guiclass_select(t_gobj* z, t_glist* glist, int selected) { - Tcl_Obj* av[4]; InitArray(av, 4, NULL); + Tcl_Obj* av[5]; InitArray(av, 5, NULL); t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("select", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(selected); + av[3] = Tcl_NewStringObj("select", -1); Tcl_IncrRefCount(av[3]); - int result = Tcl_EvalObjv(tcl_for_pd, 4, av, 0); + av[4] = Tcl_NewIntObj(selected); + Tcl_IncrRefCount(av[4]); + int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; @@ -233,20 +246,23 @@ cleanup: Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); } void tclpd_guiclass_activate(t_gobj* z, t_glist* glist, int state) { - Tcl_Obj* av[4]; InitArray(av, 4, NULL); + Tcl_Obj* av[5]; InitArray(av, 5, NULL); t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("activate", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); - av[3] = Tcl_NewIntObj(state); + av[3] = Tcl_NewStringObj("activate", -1); Tcl_IncrRefCount(av[3]); - int result = Tcl_EvalObjv(tcl_for_pd, 4, av, 0); + av[4] = Tcl_NewIntObj(state); + Tcl_IncrRefCount(av[4]); + int result = Tcl_EvalObjv(tcl_for_pd, 5, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; @@ -258,6 +274,7 @@ cleanup: Tcl_DecrRefCount(av[1]); Tcl_DecrRefCount(av[2]); Tcl_DecrRefCount(av[3]); + Tcl_DecrRefCount(av[4]); } void tclpd_guiclass_delete(t_gobj* z, t_glist* glist) { @@ -266,25 +283,27 @@ void tclpd_guiclass_delete(t_gobj* z, t_glist* glist) { } void tclpd_guiclass_vis(t_gobj* z, t_glist* glist, int vis) { - Tcl_Obj* av[7]; InitArray(av, 7, NULL); + Tcl_Obj* av[8]; InitArray(av, 8, NULL); t_tcl* x = (t_tcl*)z; - av[0] = x->self; + av[0] = x->dispatcher; Tcl_IncrRefCount(av[0]); - av[1] = Tcl_NewStringObj("widgetbehavior", -1); + av[1] = x->self; Tcl_IncrRefCount(av[1]); - av[2] = Tcl_NewStringObj("vis", -1); + av[2] = Tcl_NewStringObj("widgetbehavior", -1); Tcl_IncrRefCount(av[2]); + av[3] = Tcl_NewStringObj("vis", -1); + Tcl_IncrRefCount(av[3]); char buf[32]; snprintf(buf, 32, ".x%lx.c", glist_getcanvas(glist)); - av[3] = Tcl_NewStringObj(buf, -1); - Tcl_IncrRefCount(av[3]); - av[4] = Tcl_NewIntObj(text_xpix(&x->o, glist)); + av[4] = Tcl_NewStringObj(buf, -1); Tcl_IncrRefCount(av[4]); - av[5] = Tcl_NewIntObj(text_ypix(&x->o, glist)); + av[5] = Tcl_NewIntObj(text_xpix(&x->o, glist)); Tcl_IncrRefCount(av[5]); - av[6] = Tcl_NewIntObj(vis); + av[6] = Tcl_NewIntObj(text_ypix(&x->o, glist)); Tcl_IncrRefCount(av[6]); - int result = Tcl_EvalObjv(tcl_for_pd, 7, av, 0); + av[7] = Tcl_NewIntObj(vis); + Tcl_IncrRefCount(av[7]); + int result = Tcl_EvalObjv(tcl_for_pd, 8, av, 0); if(result != TCL_OK) { tclpd_interp_error(x, result); goto error; @@ -299,4 +318,5 @@ cleanup: Tcl_DecrRefCount(av[4]); Tcl_DecrRefCount(av[5]); Tcl_DecrRefCount(av[6]); + Tcl_DecrRefCount(av[7]); } diff --git a/tclpd-meta.pd b/tclpd-meta.pd index 665813b..3ef5d2a 100644 --- a/tclpd-meta.pd +++ b/tclpd-meta.pd @@ -2,5 +2,5 @@ #N canvas 25 49 420 300 META 1; #X text 13 41 NAME tclpd; #X text 10 25 AUTHOR Federico Ferri; -#X text 10 10 VERSION 0.2.2; +#X text 10 10 VERSION 0.2.3; #X restore 10 10 pd META; -- cgit v1.2.1