tclpd-console works

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

1 files changed, 87 insertions, 8 deletions

diff --git a/examples/tclpd-console.tcl b/examples/tclpd-console.tcl
index 3ab338d..0c37904 100644
--- a/examples/tclpd-console.tcl
+++ b/examples/tclpd-console.tcl
@@ -1,18 +1,61 @@
 package require Tclpd 0.2.3
 package require TclpdLib 0.19
 
+package require base64
+
+pd::guiproc ::tclpd_console_exec {cmd} {
+    if {$cmd eq {}} {return}
+
+    global tclpd_console_hist
+    global tclpd_console_histp
+
+    if {$cmd ne [lindex $tclpd_console_hist end]} {
+        lappend tclpd_console_hist $cmd
+        set tclpd_console_histp [expr {[llength $tclpd_console_hist]-1}]
+    }
+    .pdwindow.tcl.tclpd.entry delete 0 end
+
+    # encode message in base64 to prevent escaping and other FUDI annoyances
+    set cmd [::base64::encode $cmd]
+
+    set max_line_length 1024
+    while {$cmd ne {}} {
+        set line [string range $cmd 0 [expr $max_line_length - 1]]
+        set cmd [string range $cmd $max_line_length end]
+        ::pdsend "$::tclpd_console base64data $line"
+    }
+    ::pdsend "$::tclpd_console base64data -"
+}
+
+pd::guiproc ::tclpd_console_history {dir} {
+    global tclpd_console_hist
+    global tclpd_console_histp
+
+    incr tclpd_console_histp $dir
+    set l [llength $tclpd_console_hist]
+    if {$tclpd_console_histp < 0} {set tclpd_console_histp 0}
+    if {$tclpd_console_histp >= $l} {set tclpd_console_histp [expr {$l-1}]}
+
+    .pdwindow.tcl.tclpd.entry delete 0 end
+    .pdwindow.tcl.tclpd.entry insert 0 \
+        [lindex $tclpd_console_hist $tclpd_console_histp]
+}
+
 proc tclpd-console::constructor {self} {
-    if {[info exist ::tclpd_console_loaded]} {
+    if {[info exist ::tclpd-console::loaded]} {
         return -code error "only one instance of tclpd-console allowed"
     }
 
-    set ::tclpd_console_loaded 1
+    set ::tclpd-console::loaded 1
     set ::${self}_loaded 1
 
     pd_bind [tclpd_get_instance_pd $self] [gensym $self]
 
     sys_gui "set ::tclpd_console $self"
     sys_gui {
+        set ::tclpd_console_hist {}
+        set ::tclpd_console_histp {}
+        package require base64
         set w .pdwindow.tcl.tclpd
         frame $w -borderwidth 0
         pack $w -side bottom -fill x
@@ -23,10 +66,25 @@ proc tclpd-console::constructor {self} {
             -textvariable ::tclpd_cmd -font {$::font_family 12}
         pack $w.entry -side left -fill x
         bind $w.entry <$::modifier-Key-a> "%W selection range 0 end; break"
-        bind $w.entry <Return> {::pdsend "$::tclpd_console $::tclpd_cmd"}
+        bind $w.entry <Return> {::tclpd_console_exec $::tclpd_cmd}
         set bgrule {[lindex {#FFF0F0 #FFFFFF} [info complete $::tclpd_cmd]]}
         bind $w.entry <KeyRelease> "$w.entry configure -background $bgrule"
+        bind $w.entry <Up> "::tclpd_console_history -1"
+        bind $w.entry <Down> "::tclpd_console_history 1"
         bind .pdwindow.text <Key-Tab> "focus $w.entry; break"
+        after idle .pdwindow.text.internal yview end
+    }
+
+    # make puts print into pdwindow
+    if {[info procs puts_tclpd_console] eq {}} {
+        rename puts puts_tclpd_console
+        proc ::puts {args} {
+            if {[llength $args] == 1} {
+                uplevel "pd::post $args"
+            } else {
+                uplevel "puts_tclpd_console $args"
+            }
+        }
     }
 }
 
@@ -35,16 +93,37 @@ proc tclpd-console::destructor {self} {
         sys_gui { destroy .pdwindow.tcl.tclpd ; unset ::tclpd_console }
 
         pd_unbind [tclpd_get_instance_pd $self] [gensym $self]
+
+        # restore original puts
+        if {[info procs puts_tclpd_console] ne {}} {
+            rename puts_tclpd_console puts
+        }
     }
 
-    unset ::tclpd_console_loaded
+    unset ::tclpd-console::loaded
     unset ::${self}_loaded
 }
 
-proc tclpd-console::0_anything {self args} {
-    set tclcmd [pd::strip_selectors $args]
-    pd::post [concat % $tclcmd]
-    pd::post [uplevel #0 $tclcmd]
+proc tclpd-console::0_base64data {self data} {
+    if {[llength $data] != 2 || [lindex $data 0] ne {symbol}} {
+        return -code error "malformed arguments: $data"
+    }
+
+    global tclpd_console_buf
+
+    set data [lindex $data 1]
+    set op [string index $data 0]
+
+    if {$op eq "-"} {
+        set cmd [::base64::decode $tclpd_console_buf]
+        set tclpd_console_buf {}
+        pd::post [concat % $cmd]
+        set result [uplevel #0 $cmd]
+        if {$result ne {}} {pd::post $result}
+        #sys_gui "tk_messageBox -message {Result:\n$result}"
+    } else {
+        append tclpd_console_buf $data
+    }
 }
 
 pd::class tclpd-console -noinlet 1