aboutsummaryrefslogtreecommitdiff
path: root/examples/tclpd-console.tcl
blob: 0c379041304cc2692375a4bc94c44de3134b8076 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
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]} {
        return -code error "only one instance of tclpd-console allowed"
    }

    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
        label $w.label -text [_ "tclpd: "] -anchor e
        pack $w.label -side left
        entry $w.entry -width 200 \
            -exportselection 1 -insertwidth 2 -insertbackground blue \
            -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> {::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"
            }
        }
    }
}

proc tclpd-console::destructor {self} {
    if {[set ::${self}_loaded]} {
        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 ::${self}_loaded
}

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