rename pdlib.tcl to tclpd.tcl

svn path=/trunk/externals/loaders/tclpd/; revision=15605

1 files changed, 287 insertions, 0 deletions

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 <mescalinum@gmail.com> - (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
+    }
+}
+