From b43ebdb4ebbe583218d5e7802835b8d7a56c7292 Mon Sep 17 00:00:00 2001 From: mescalinum Date: Sat, 15 Oct 2011 20:44:27 +0000 Subject: rename pdlib.tcl to tclpd.tcl svn path=/trunk/externals/loaders/tclpd/; revision=15605 --- Makefile | 4 +- README.txt | 59 ++++--------- pdlib.tcl | 284 ------------------------------------------------------------ tclpd.c | 2 +- tclpd.tcl | 287 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 309 insertions(+), 327 deletions(-) delete mode 100644 pdlib.tcl create mode 100644 tclpd.tcl diff --git a/Makefile b/Makefile index 12a467c..7b64039 100644 --- a/Makefile +++ b/Makefile @@ -25,7 +25,7 @@ TCLPD_SOURCES = hashtable.c tcl_class.c tcl_loader.c tcl_proxyinlet.c tcl_typema # list them here. This can be anything from header files, test patches, # documentation, etc. README.txt and LICENSE.txt are required and therefore # automatically included -EXTRA_DIST = tcl.i tcl_extras.h pdlib.tcl $(TCLPD_SOURCES) ChangeLog.txt AUTHORS.txt TODO.txt +EXTRA_DIST = tcl.i tcl_extras.h tclpd.tcl $(TCLPD_SOURCES) ChangeLog.txt AUTHORS.txt TODO.txt @@ -312,7 +312,7 @@ single_install: $(LIBRARY_NAME) install-doc install-examples install-manual $(INSTALL_DIR) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(INSTALL_PROGRAM) $(LIBRARY_NAME).$(EXTENSION) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) $(STRIP) $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME)/$(LIBRARY_NAME).$(EXTENSION) - $(INSTALL_DATA) pdlib.tcl $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) + $(INSTALL_DATA) tclpd.tcl $(DESTDIR)$(objectsdir)/$(LIBRARY_NAME) ifeq ($(UNAME),Darwin) # force tclpd to use the Tcl.framework built into Pd-extended install_name_tool -change \ diff --git a/README.txt b/README.txt index 0276171..cec7a92 100644 --- a/README.txt +++ b/README.txt @@ -3,14 +3,12 @@ ========== This library allows to to write externals for Pd using the Tcl language. - -It is based on the standard API of PD (defined in m_pd.h, plus some other -private header files, like g_canvas.h, s_stuff.h, ...). +It wraps quite closely the pd API (m_pd.h, plus some private functions) Also a library of Tcl helper functions is provided. It is not mandatory to use it (moreover: it requires Tcl 8.5, while the tclpd external alone requires only Tcl 8.4), but it is a syntactic sugar and can simplify a lot the code. -Using it is as simple as sourcing pdlib.tcl in your Tcl external. +To use it simply add 'package require TclpdLib' in your Tcl external. Anyway, disregarding any approach chosen to develop Tcl externals, a general knowledge of Pd internals (atoms, symbols, symbol table, inlets, objects) is @@ -37,40 +35,29 @@ pure-data). ===================== Pd is split into two processes: pd (the core) and pd-gui. -A simple pd external just runs in the core. A simple Tcl externals still runs -in the core, because tclpd creates a Tcl interpreter for that. - -Instead, pd-gui has its own Tcl interpreter. In order to to GUI things (i.e. -draw on the canvas, or react to mouse events), the core process needs to -communicate with the pd-gui process (generally sending Tk commands, or calling -procedures defined in the pd-gui interp. -This is done with the sys_gui() function, if using the plain API. - -Also pdlib.tcl provide means to simplify this task, with the guiproc function, -which defines procedures directly into the pd-gui interpreter. +A pd external executes in the core. The same applies for a Tcl external loaded +by tclpd, because tclpd creates a Tcl interpreter for that, running in the +same process as pd. -As a counterexample, I'd like to cite tot/toxy/widget externals, which you may -be familiar with. -Such externals run in the pd-gui process. That was fine for writing simple gui -externals, that don't need to react to any message. -But, for instance, you cannot do a metronome or anything which is timing -accurate, or heavy IO, as that is not the purpose of the gui process. -Tclpd instead, by running in the core process, allows that. +On the gui side (pd-gui) there is another Tcl interpreter living in a separate +process, which communicates with pd using a network socket. +Communication happens in one way (pd to gui) with the sys_gui function, and in +the other way using ::pdsend. (needs to set up a receiver using pdbind, check +the examples). Data conversion between Tcl <=> Pd ================================== -In pd exists 'atoms'. An atom is a float, a symbol, a list item, and such. -Tcl does not have data types. In Tcl everything is a string, also numbers and -lists. Just when something needs to be read as number, then evaluation comes -in. -This leads to loss of information about atom types. Imagine a -symbol '456' comes into tclpd, you won't know anymore if "456" -is a symbol or a float. +In pd objects communicate using messages, and messages are made up of atoms. +An atom could be a float, a symbol, a list, and so on. +Tcl usually doesn't make distinction between strings and numbers. This means +that simply translating a message text into a string could lose information +about the atom type (to pd, symbol 456 is different from float 456, but if we +just convert it as a string "456" the type information is lost). -Here a little convention comes in: in tclpd an atom gets converted into a -two-item list, where first item is atom type, and second item is its value. +To maintain atom type infrmation, pd atoms are represented in Tcl as two +element lists, where the first element indicates the atom type. Some examples of this conversion: @@ -87,15 +74,7 @@ Some examples of this conversion: Examples ======== -I provided small examples. -after loading pd with option '-lib tcl', just type the filename -(minus the .tcl extension) to load the Tcl externals examples. - -actually there is one simple example: list_change (behaves like -[change] object, but work with lists only) - -examples make use of pdlib.tcl. It's still possible to port the example to use -only the plain Pd api. Contributions are welcome. +Some examples externals are provided, including their helpfile. Authors diff --git a/pdlib.tcl b/pdlib.tcl deleted file mode 100644 index 0766ae4..0000000 --- a/pdlib.tcl +++ /dev/null @@ -1,284 +0,0 @@ -# TCL objectized library for PD api -# by Federico Ferri - (C) 2007-2011 - -package provide TclpdLib 0.19 - -package require Tcl 8.5 -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" - } - - proc add_inlet {self sel} { - if $::verbose {post [info level 0]} - variable _ - tclpd_add_proxyinlet [tclpd_get_instance $self] - } - - proc add_outlet {self {sel {}}} { - if $::verbose {post [info level 0]} - variable _ - if {$sel == {}} { - set o [outlet_new [tclpd_get_object $self] [null_symbol]] - } else { - if {[lsearch -exact {bang float list symbol} $sel] == -1} { - return -code error [error_msg "unsupported selector: $sel"] - } - set o [outlet_new [tclpd_get_object $self] [gensym $sel]] - } - lappend _($self:x_outlet) $o - return $o - } - - # used inside class for outputting some value - proc outlet {self n sel args} { - if $::verbose {post [info level 0]} - variable _ - set outlet [lindex $_($self:x_outlet) $n] - switch -- $sel { - float { - set v [lindex $args 0] - outlet_float $outlet $v - } - symbol { - set v [lindex $args 0] - outlet_symbol $outlet $v - } - list { - set v [lindex $args 0] - set sz [llength $v] - set aa [new_atom_array $sz] - for {set i 0} {$i < $sz} {incr i} { - set_atom_array $aa $i [lindex $v $i] - } - outlet_list $outlet [gensym "list"] $sz $aa - delete_atom_array $aa $sz - } - bang { - outlet_bang $outlet - } - default { - set v [lindex $args 0] - set sz [llength $v] - set aa [new_atom_array $sz] - for {set i 0} {$i < $sz} {incr i} { - set_atom_array $aa $i [lindex $v $i] - } - outlet_anything $outlet [gensym $sel] $sz $aa - delete_atom_array $aa $sz - } - } - } - - proc read_class_options {classname options} { - set patchable_flag 1 - set noinlet_flag 0 - - 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 $v - } - -noinlet { - if {$v != 0 && $v != 1} { - return -code error [error_msg "-noinlet must be 0/1"] - } - set noinlet_flag $v - } - default { - return -code error [error_msg "unknown option: $k"] - } - } - } - - 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}::0_loadbang {self} {} - - # TODO: c->c_gobj = (typeflag >= CLASS_GOBJ) - set flag [expr { - 8 * ($noinlet_flag != 0) + - 3 * ($patchable_flag != 0) - }] - - return $flag - } - - # this handles the pd::class definition - proc class {classname args} { - if $::verbose {post [lrange [info level 0] 0 end-1]} - - set flag [read_class_options $classname $args] - - # this wraps the call to class_new() - tclpd_class_new $classname $flag - } - - proc guiclass {classname args} { - if $::verbose {post [lrange [info level 0] 0 end-1]} - - set flag [read_class_options $classname $args] - - # this wraps the call to class_new() - tclpd_guiclass_new $classname $flag - } - - # wrapper to post() withouth vargs - proc post {args} { - poststring2 [concat {*}$args] - } - - proc args {} { - return [uplevel 1 "llength \$args"] - } - - proc arg {n {assertion any}} { - upvar 1 args up_args - set up_args_len [llength $up_args] - if {$n < 0 || $n >= $up_args_len} { - return -code error "fatal: argument $n out of range" - } - set v [lindex $up_args $n] - set i 0 - if {[llength $v] != 2} { - return -code error "fatal: malformed atom: $v (full args: $up_args)" - } - foreach {selector value} $v {break} - if {$assertion == {int}} { - set assertion {float} - set i 1 - } - if {$assertion != {any}} { - if {$selector != $assertion} { - return -code error "arg #$n is $selector, must be $assertion" - } - } - if {$assertion == {float} && $i && $value != int($value)} { - return -code error "arg #$n is float, must be int" - } - if {$assertion == {float} && $i} { - return [expr {int($value)}] - } else { - return $value - } - } - - proc default_arg {n assertion defval} { - if {$n < [uplevel "pd::args"]} { - return [uplevel "pd::arg $n $assertion"] - } else { - return $defval - } - } - - proc strip_selectors {pdlist} { - set r {} - foreach atom $pdlist { - if {[llength $atom] != 2} { - return -code error "Malformed pd list!" - } - lappend r [lindex $atom 1] - } - 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 [add_selector $i] - } - return $r - } - - proc strip_empty {tcllist} { - set r {} - foreach i $tcllist { - if {$i == "empty"} {lappend r {}} {lappend r $i} - } - return $r - } - - proc add_empty {tcllist} { - set r {} - foreach i $tcllist { - if {$i == {}} {lappend r "empty"} {lappend r $i} - } - return $r - } - - # mechanism for uploading procs to gui interp, without the hassle of escaping [encoder] - proc guiproc {name argz body} { - # upload the decoder - sys_gui "proc guiproc {name argz body} {set map {}; for {set i 0} {\$i < 256} {incr i} {lappend map %\[format %02x \$i\] \[format %c \$i\]}; foreach x {name argz body} {set \$x \[string map \$map \[set \$x\]\]}; uplevel \[list proc \$name \$argz \$body\]}\n" - # build the mapping - set map {} - for {set i 0} {$i < 256} {incr i} { - set chr [format %c $i] - set hex [format %02x $i] - if {[regexp {[^A-Za-z0-9]} $chr]} {lappend map $chr %$hex} - } - # encode data - foreach x {name argz body} {set $x [string map $map [set $x]]} - # upload proc - sys_gui "guiproc $name $argz $body\n" - } - - proc get_binbuf {self} { - set binbuf [tclpd_get_object_binbuf $self] - set len [binbuf_getnatom $binbuf] - set result {} - for {set i 0} {$i < $len} {incr i} { - set atom [tclpd_binbuf_get_atom $binbuf $i] - set selector [atom_type_string $atom] - set value {?} - if {$selector == "float"} { - set value [atom_float_value $atom] - } elseif {$selector == "symbol"} { - set value [atom_symbol_value $atom] - } - lappend result [list $selector $value] - } - return $result - } -} - diff --git a/tclpd.c b/tclpd.c index 4bc0b5a..0440952 100644 --- a/tclpd.c +++ b/tclpd.c @@ -25,7 +25,7 @@ void tclpd_setup(void) { t_class* foo_class = class_new(gensym("tclpd_init"), 0, 0, 0, 0, 0); char buf[PATH_MAX]; - snprintf(buf, PATH_MAX, "%s/pdlib.tcl", foo_class->c_externdir->s_name); + snprintf(buf, PATH_MAX, "%s/tclpd.tcl", foo_class->c_externdir->s_name); if(Tcl_EvalFile(tcl_for_pd, buf) != TCL_OK) { error("tclpd loader: error loading %s", buf); } diff --git a/tclpd.tcl b/tclpd.tcl new file mode 100644 index 0000000..e3b2583 --- /dev/null +++ b/tclpd.tcl @@ -0,0 +1,287 @@ +# TCL objectized library for PD api +# by Federico Ferri - (C) 2007-2011 + +package provide TclpdLib 0.19 + +package require Tcl 8.5 +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" + } + + proc add_inlet {self sel} { + if $::verbose {post [info level 0]} + variable _ + tclpd_add_proxyinlet [tclpd_get_instance $self] + } + + proc add_outlet {self {sel {}}} { + if $::verbose {post [info level 0]} + variable _ + if {$sel == {}} { + set o [outlet_new [tclpd_get_object $self] [null_symbol]] + } else { + if {[lsearch -exact {bang float list symbol} $sel] == -1} { + return -code error [error_msg "unsupported selector: $sel"] + } + set o [outlet_new [tclpd_get_object $self] [gensym $sel]] + } + lappend _($self:x_outlet) $o + return $o + } + + # used inside class for outputting some value + proc outlet {self n sel args} { + if $::verbose {post [info level 0]} + variable _ + set outlet [lindex $_($self:x_outlet) $n] + switch -- $sel { + float { + set v [lindex $args 0] + outlet_float $outlet $v + } + symbol { + set v [lindex $args 0] + outlet_symbol $outlet $v + } + list { + set v [lindex $args 0] + set sz [llength $v] + set aa [new_atom_array $sz] + for {set i 0} {$i < $sz} {incr i} { + set_atom_array $aa $i [lindex $v $i] + } + outlet_list $outlet [gensym "list"] $sz $aa + delete_atom_array $aa $sz + } + bang { + outlet_bang $outlet + } + default { + set v [lindex $args 0] + set sz [llength $v] + set aa [new_atom_array $sz] + for {set i 0} {$i < $sz} {incr i} { + set_atom_array $aa $i [lindex $v $i] + } + outlet_anything $outlet [gensym $sel] $sz $aa + delete_atom_array $aa $sz + } + } + } + + proc read_class_options {classname options} { + set patchable_flag 1 + set noinlet_flag 0 + + 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 $v + } + -noinlet { + if {$v != 0 && $v != 1} { + return -code error [error_msg "-noinlet must be 0/1"] + } + set noinlet_flag $v + } + default { + return -code error [error_msg "unknown option: $k"] + } + } + } + + 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\] + set f ::${classname}::\${function}_\${subfunction} + if {\[info procs \$f\] != {}} { + uplevel \[linsert \$argsr 0 \$f \$self] + } + } else { + uplevel \[linsert \$args 0 ::${classname}::\$function \$self\] + } + " + + # some dummy function to suppress eventual errors if they are not deifned: + proc ::${classname}::0_loadbang {self} {} + + # TODO: c->c_gobj = (typeflag >= CLASS_GOBJ) + set flag [expr { + 8 * ($noinlet_flag != 0) + + 3 * ($patchable_flag != 0) + }] + + return $flag + } + + # this handles the pd::class definition + proc class {classname args} { + if $::verbose {post [lrange [info level 0] 0 end-1]} + + set flag [read_class_options $classname $args] + + # this wraps the call to class_new() + tclpd_class_new $classname $flag + } + + proc guiclass {classname args} { + if $::verbose {post [lrange [info level 0] 0 end-1]} + + set flag [read_class_options $classname $args] + + # this wraps the call to class_new() + tclpd_guiclass_new $classname $flag + } + + # wrapper to post() withouth vargs + proc post {args} { + poststring2 [concat {*}$args] + } + + proc args {} { + return [uplevel 1 "llength \$args"] + } + + proc arg {n {assertion any}} { + upvar 1 args up_args + set up_args_len [llength $up_args] + if {$n < 0 || $n >= $up_args_len} { + return -code error "fatal: argument $n out of range" + } + set v [lindex $up_args $n] + set i 0 + if {[llength $v] != 2} { + return -code error "fatal: malformed atom: $v (full args: $up_args)" + } + foreach {selector value} $v {break} + if {$assertion == {int}} { + set assertion {float} + set i 1 + } + if {$assertion != {any}} { + if {$selector != $assertion} { + return -code error "arg #$n is $selector, must be $assertion" + } + } + if {$assertion == {float} && $i && $value != int($value)} { + return -code error "arg #$n is float, must be int" + } + if {$assertion == {float} && $i} { + return [expr {int($value)}] + } else { + return $value + } + } + + proc default_arg {n assertion defval} { + if {$n < [uplevel "pd::args"]} { + return [uplevel "pd::arg $n $assertion"] + } else { + return $defval + } + } + + proc strip_selectors {pdlist} { + set r {} + foreach atom $pdlist { + if {[llength $atom] != 2} { + return -code error "Malformed pd list!" + } + lappend r [lindex $atom 1] + } + 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 [add_selector $i] + } + return $r + } + + proc strip_empty {tcllist} { + set r {} + foreach i $tcllist { + if {$i == "empty"} {lappend r {}} {lappend r $i} + } + return $r + } + + proc add_empty {tcllist} { + set r {} + foreach i $tcllist { + if {$i == {}} {lappend r "empty"} {lappend r $i} + } + return $r + } + + # mechanism for uploading procs to gui interp, without the hassle of escaping [encoder] + proc guiproc {name argz body} { + # upload the decoder + sys_gui "proc guiproc {name argz body} {set map {}; for {set i 0} {\$i < 256} {incr i} {lappend map %\[format %02x \$i\] \[format %c \$i\]}; foreach x {name argz body} {set \$x \[string map \$map \[set \$x\]\]}; uplevel \[list proc \$name \$argz \$body\]}\n" + # build the mapping + set map {} + for {set i 0} {$i < 256} {incr i} { + set chr [format %c $i] + set hex [format %02x $i] + if {[regexp {[^A-Za-z0-9]} $chr]} {lappend map $chr %$hex} + } + # encode data + foreach x {name argz body} {set $x [string map $map [set $x]]} + # upload proc + sys_gui "guiproc $name $argz $body\n" + } + + proc get_binbuf {self} { + set binbuf [tclpd_get_object_binbuf $self] + set len [binbuf_getnatom $binbuf] + set result {} + for {set i 0} {$i < $len} {incr i} { + set atom [tclpd_binbuf_get_atom $binbuf $i] + set selector [atom_type_string $atom] + set value {?} + if {$selector == "float"} { + set value [atom_float_value $atom] + } elseif {$selector == "symbol"} { + set value [atom_symbol_value $atom] + } + lappend result [list $selector $value] + } + return $result + } +} + -- cgit v1.2.1