Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch hypnotoad
Excluding Merge-Ins
This is equivalent to a diff from
04e9c7f911
to c4c1ad43fd
2013-02-12
| | |
15:13 |
|
check-in: 833107b47e user: seandeelywoods tags: trunk
|
15:11 |
|
Leaf
check-in: c4c1ad43fd user: seandeelywoods tags: hypnotoad
|
14:57 |
|
check-in: 1cf1e20494 user: seandeelywoods tags: hypnotoad
|
2013-02-05
| | |
02:15 |
|
check-in: 04e9c7f911 user: gerald tags: trunk
|
2013-01-22
| | |
18:31 |
|
check-in: bd8435682a user: gerald tags: trunk
|
| | |
Changes to README.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
|
-
+
-
+
|
Requires Snit. Run tclsh8.5 server.tcl and open your browser to http://localhost:9001
Requires TclOO. Run tclsh8.5 server.tcl and open your browser to http://localhost:9001
I've recently started putting together a Tk-over-jQuery routine I'm calling web Tk (wtk). The idea is having full Tcl running on a server, with a Tk-like layer that sends commands to code running in a browser.
For those of you who remember it, this is conceptually similar to ProxyTk (see http://www.markroseman.com/pubs/proxytk.pdf).
An important thing is that its not tied into any particular web server or other communication channel; in fact, it just assumes there is a communication channel of some sort. This might be an AJAX connection pair, WebSockets, socket.io, etc. Or it might not even be a remote communication. You could well have a desktop/iPad app whose UI is a web view, and the "communication" between "server" and "client" might be just a procedure call.
The implementation is based on Snit, and the demo uses simple Ajax communication over a generic minihttpd.tcl-derived web server. Incidentally, while I've never really used Snit before, it's a clear win for this type of thing; you'll see from the widget code that the amount of overhead needed to translate the "tk-like" commands into Javascript/jQuery calls is fairly minimal. This is important as I want to make this very easy for people to extend, wrap other jQuery widgets, etc.
The implementation is based on TclOO, and the demo uses simple Ajax communication over a generic minihttpd.tcl-derived web server. TclOO translates the "tk-like" commands into Javascript/jQuery calls with fairly minimal code. This is important as I want to make this very easy for people to extend, wrap other jQuery widgets, etc.
It's still at what I'd consider the proof of concept stage, but it feels very promising.
Notes:
Starting the wtk app server:
|
︙ | | |
Changes to commands/bind.tcl.
︙ | | |
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
|
-
+
-
+
|
return -code error -level 1 -errorcode [list WTKNOTIMPYET bind query_for_events] {[bind window] not yet implemented}
}
1 {
return -code error -level 1 -errorcode [list WTKNOTIMPYET bind query_for_script] {[bind window pattern] not yet implemented}
}
2 {
lassign $args ev script
return [$w _bind $ev $script]
return [$w action_bind $ev $script]
}
default {
return -code error -level 1 {wrong # args: should be "bind window ?pattern? ?command?"}
}
}
return [$w _bind $ev $script]
return [$w action_bind $ev $script]
}
|
Changes to commands/focus.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
-
+
|
##
## Partial implementation of focus
##
proc ::wtk::focus {args} {
if {![llength $args]} {
set args [list -displayof .]
} elseif {[llength $args] > 2} {
return \
-code error \
[format {bad option "%1$s": must be -displayof, -force, or -lastfor} [lindex $arg 0]]
} elseif {[llength $args] == 1} {
_VerifyWindowExists $args
$args _focus
$args event_focus
return;
}
switch -exact -- [lindex $args 0] {
-displayof {
return -code error -level 1 -errorcode [list WTKNOTIMPYET focus -displayof] {[focus -displayof] not yet implemented}
}
-force {
|
︙ | | |
Changes to commands/wm.tcl.
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
|
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
|
-
-
-
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
namespace eval ::wtk::wm:: {
namespace ensemble create -map {
aspect Aspect attributes Attributes client Client colormapwindows Colormapwindows command Command deiconify Deiconify focusmodel Focusmodel frame Frame geometry Geometry grid Grid group Group iconbitmap Iconbitmap iconify Iconify iconmask Iconmask iconname Iconname iconphoto Iconphoto iconposition Iconposition iconwindow Iconwindow maxsize Maxsize minsize Minsize overrideredirect Overrideredirect positionfrom Positionfrom protocol Protocol resizable Resizable sizefrom Sizefrom stackorder Stackorder state State title Title transient Transient withdraw Withdraw
}
namespace ensemble create -map {
aspect Aspect attributes Attributes client Client colormapwindows Colormapwindows command Command deiconify Deiconify focusmodel Focusmodel frame Frame geometry Geometry grid Grid group Group iconbitmap Iconbitmap iconify Iconify iconmask Iconmask iconname Iconname iconphoto Iconphoto iconposition Iconposition iconwindow Iconwindow maxsize Maxsize minsize Minsize overrideredirect Overrideredirect positionfrom Positionfrom protocol Protocol resizable Resizable sizefrom Sizefrom stackorder Stackorder state State title Title transient Transient withdraw Withdraw
}
}
proc ::wtk::wm::_VerifyWindowExists {window} {
parray ::wtk::widgets
if {![info exists ::wtk::widgets([string trimleft $window])]} {
return \
-code error \
-level 2 \
[format {bad window path name "%1$s"} $window]
} elseif {![string equal $window {.}]} {
return \
-code error \
-level 2 \
[format {window "%1$s" isn't a top-level window} $window]
}
return;
if {![info exists ::wtk::widgets([string trimleft $window])]} {
return \
-code error \
-level 2 \
[format {bad window path name "%1$s"} $window]
} elseif {![string equal $window {.}]} {
return \
-code error \
-level 2 \
[format {window "%1$s" isn't a top-level window} $window]
}
return;
}
foreach file [glob -- [file join [file dirname [info script]] wm *.tcl]] {
source $file
source $file
}
|
Changes to demo.tcl.
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
|
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
|
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
+
-
+
-
-
-
-
-
-
+
+
+
+
+
+
-
+
-
-
-
-
-
-
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
|
proc render {} {
puts RENDER
wtk::wm title . "Feet to Meters"
wtk::grid [wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
wtk::grid columnconfigure .c 0 -weight 1; wtk::grid rowconfigure .c 0 -weight 1
wtk::grid [wtk::button .c.calc -text "Calculate" -radius 7 -bg #ffccff -fg darkgreen -command calculate] -column 0 -row 1 -sticky w
wtk::grid [wtk::entry .c.feet -width 7 -textvariable feet -bg GreenYellow -fg Red] -column 1 -row 1 -sticky we
wtk::grid [wtk::label .c.flbl -text "feet" -bg yellow] -column 2 -row 1 -sticky w
wtk::grid [wtk::label .c.islbl -text "is equivalent to"] -column 0 -row 2 -sticky e
wtk::grid [wtk::label .c.meters -textvariable meters] -column 1 -row 2 -sticky we
wtk::grid [wtk::label .c.mlbl -text "meters"] -column 2 -row 2 -sticky w
#foreach w [wtk::winfo children .c] {wtk::grid configure $w -padx 50 -pady 50}; #not working yet
wtk::grid [wtk::text .text -rows 4 -cols 40 -bg GreenYellow -fg Red -textvariable textval] -column 0 -row 2 -sticky ew
wtk::grid [wtk::frame .d -padding "3 3 12 12"] -column 0 -row 3 -sticky nwes
wtk::grid columnconfigure .d 0 -weight 1; wtk::grid rowconfigure .d 0 -weight 1
wtk::grid rowconfigure . 3 -weight 1
wtk::grid [wtk::button .d.ib -text "" -src /images/logo.png -width 63 -height 63 -command swapimages] -column 0 -row 0 -sticky e
wtk::grid [wtk::label .d.iblbl -text "<-- Click Me"] -column 1 -row 0 -sticky w
wtk::grid [wtk::combobox .d.cb -text "ComboBox" -options "zero one two three" -variable textval -command selectimg] -column 2 -row 0 -sticky w
wtk::grid [wtk::checkbutton .d.ck -bg violet -fg Red -variable checkval -command docheck] -column 3 -row 0 -sticky w
wtk::grid [wtk::label .d.cklbl -textvariable ckstatus] -column 4 -row 0 -sticky w
#foreach w [wtk::winfo children .d] {wtk::grid configure $w -padx 150 -pady 150}; #not working yet
wtk::grid [wtk::frame .e -padding "3 3 12 12"] -column 0 -row 4 -sticky nwes
wtk::grid columnconfigure .e 0 -weight 1; wtk::grid rowconfigure .e 0 -weight 1
set html "<a href=\"http://www.google.com\">Link To Google<a/>"
wtk::grid [wtk::misc .e.misclink -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 0
wtk::grid [wtk::label .e.spacer -text "                "] -column 1 -row 0 -sticky w
::wtk::wm title . "Feet to Meters"
::wtk::grid [::wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
::wtk::grid columnconfigure .c 0 -weight 1; ::wtk::grid rowconfigure .c 0 -weight 1
::wtk::grid [::wtk::button .c.calc -text "Calculate" -radius 7 -bg #ffccff -fg darkgreen -command calculate] -column 0 -row 1 -sticky w
::wtk::grid [::wtk::entry .c.feet -width 7 -textvariable feet -bg GreenYellow -fg Red] -column 1 -row 1 -sticky we
::wtk::grid [::wtk::label .c.flbl -text "feet" -bg yellow] -column 2 -row 1 -sticky w
::wtk::grid [::wtk::label .c.islbl -text "is equivalent to"] -column 0 -row 2 -sticky e
::wtk::grid [::wtk::label .c.meters -textvariable meters] -column 1 -row 2 -sticky we
::wtk::grid [::wtk::label .c.mlbl -text "meters"] -column 2 -row 2 -sticky w
#foreach w [::wtk::winfo children .c] {::wtk::grid configure $w -padx 50 -pady 50}; #not working yet
::wtk::grid [::wtk::text .text -rows 4 -cols 40 -bg GreenYellow -fg Red -textvariable textval] -column 0 -row 2 -sticky ew
::wtk::grid [::wtk::frame .d -padding "3 3 12 12"] -column 0 -row 3 -sticky nwes
::wtk::grid columnconfigure .d 0 -weight 1; ::wtk::grid rowconfigure .d 0 -weight 1
::wtk::grid rowconfigure . 3 -weight 1
::wtk::grid [::wtk::button .d.ib -text "" -src /images/logo.png -width 63 -height 63 -command swapimages] -column 0 -row 0 -sticky e
::wtk::grid [::wtk::label .d.iblbl -text "<-- Click Me"] -column 1 -row 0 -sticky w
::wtk::grid [::wtk::combobox .d.cb -text "ComboBox" -options "zero one two three" -variable textval -command selectimg] -column 2 -row 0 -sticky w
::wtk::grid [::wtk::checkbutton .d.ck -bg violet -fg Red -variable checkval -command docheck] -column 3 -row 0 -sticky w
::wtk::grid [::wtk::label .d.cklbl -textvariable ckstatus] -column 4 -row 0 -sticky w
#foreach w [::wtk::winfo children .d] {::wtk::grid configure $w -padx 150 -pady 150}; #not working yet
::wtk::grid [::wtk::frame .e -padding "3 3 12 12"] -column 0 -row 4 -sticky nwes
::wtk::grid columnconfigure .e 0 -weight 1; ::wtk::grid rowconfigure .e 0 -weight 1
set html "<a href=\"http://www.google.com\">Link To Google<a/>"
::wtk::grid [::wtk::misc .e.misclink -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 0
::wtk::grid [::wtk::label .e.spacer -text "                "] -column 1 -row 0 -sticky w
set html "<a href=\"http://dev.sr-tech.com:8100/wtk/timeline?n=200\"> Link To Wtk Repo<a/>"
wtk::grid [wtk::misc .e.misclinkwtk -type div -text "$html" -attr "innerHTML" -command nop] -column 2 -row 0
set html "<form action=\"demo.tcl\" method=\"post\" enctype=\"multipart/form-data\">"
append html "<input type=\"file\" name=\"upfile\" id=\"file\">"
append html "<input type=\"submit\" name=\"submit\" value=\"Submit\">"
append html "</form>"
wtk::grid [wtk::misc .up -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 5
set html "<a href=\"http://dev.sr-tech.com:8100/wtk/timeline?n=200\"> Link To Wtk Repo<a/>"
::wtk::grid [::wtk::misc .e.misclinkwtk -type div -text "$html" -attr "innerHTML" -command nop] -column 2 -row 0
set html "<form action=\"demo.tcl\" method=\"post\" enctype=\"multipart/form-data\">"
append html "<input type=\"file\" name=\"upfile\" id=\"file\">"
append html "<input type=\"submit\" name=\"submit\" value=\"Submit\">"
append html "</form>"
::wtk::grid [::wtk::misc .up -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 5
}
proc nop {args} {}
proc docheck {} {
if {$::checkval} {
set ::ckstatus "checked"
wtk::focus .c.feet
} else {
set ::ckstatus ""
}
if {$::checkval} {
set ::ckstatus "checked"
::wtk::focus .c.feet
} else {
set ::ckstatus ""
}
}
proc calculate {} {
if {[catch {
set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
set ::textval "hey!"
}]!=0} {
set ::meters ""
}
if {[catch {
set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
set ::textval "hey!"
}]!=0} {
set ::meters ""
}
}
proc swapimages {} {
switch -- $::image {
0 {set ::image 1; set ::textval "one"
.d.ib configure -src /images/cameralens1.jpg}
1 {set ::image 2; set ::textval "two"
.d.ib configure -src /images/rainbow.gif}
2 {set ::image 3; set ::textval "three"
.d.ib configure -src /images/cameralens2.jpg}
3 {set ::image 0; set ::textval "zero"
.d.ib configure -src /images/logo.png}
}
}
switch -- $::image {
0 {
set ::image 1; set ::textval "one"
.d.ib configure -src /images/cameralens1.jpg
}
1 {
set ::image 2; set ::textval "two"
.d.ib configure -src /images/rainbow.gif
}
2 {
set ::image 3; set ::textval "three"
.d.ib configure -src /images/cameralens2.jpg
}
3 {
set ::image 0; set ::textval "zero"
.d.ib configure -src /images/logo.png
}
}
}
proc selectimg {} {
switch -- $::textval {
zero {set ::image 0
.d.ib configure -src /images/logo.png}
one {set ::image 1
.d.ib configure -src /images/cameralens1.jpg}
two {set ::image 2
.d.ib configure -src /images/rainbow.gif}
three {set ::image 3
.d.ib configure -src /images/cameralens2.jpg}
}
switch -- $::textval {
zero {
set ::image 0
.d.ib configure -src /images/logo.png
}
one {
set ::image 1
.d.ib configure -src /images/cameralens1.jpg
}
two {
set ::image 2
.d.ib configure -src /images/rainbow.gif
}
three {
set ::image 3
.d.ib configure -src /images/cameralens2.jpg
}
}
}
set ::image 0
render
wtk::focus .c.feet
wtk::bind . <Return> {calculate}
::wtk::focus .c.feet
::wtk::bind . <Return> {calculate}
|
Changes to geomanagers/grid/configure.tcl.
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
|
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
|
-
+
-
-
+
+
-
+
-
-
+
+
|
proc ::wtk::grid::Configure {window args} {
variable ::wtk::widgets
set w [namespace tail $window]
::wtk::_VerifyWindowExists $w
set parent [join [lrange [split $w .] 0 end-1] .]
if {$parent eq ""} {set parent "."}
if {![info exists widgets($parent)]} {error "no parent widget found"}
if {![$w _created?]} {$w _create}
if {![$w was_created]} {$w do_create}
if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
if {[dict keys $args -row]==""} {dict set args -row 0}
###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
[GridState for $parent] addSlave $w {*}$args
###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
[::wtk::GridState for $parent] addSlave $w {*}$args
return;
}
proc ::wtk::grid::Configure2 {cmd window args} {
variable ::wtk::widgets
set w [namespace tail $window]
::wtk::_VerifyWindowExists $w
set parent [join [lrange [split $w .] 0 end-1] .]
if {$parent eq ""} {set parent "."}
if {![info exists widgets($parent)]} {error "no parent widget found"}
if {![$w _created?]} {$w _create}
if {![$w was_created]} {$w do_create}
if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
if {[dict keys $args -row]==""} {dict set args -row 0}
###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
[GridState for $parent] addSlave $w {*}$args
###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
[::wtk::GridState for $parent] addSlave $w {*}$args
return;
}
|
Changes to geomanagers/wtk-grid.tcl.
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
|
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
|
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
-
+
-
+
-
+
|
namespace eval ::wtk {
# Grid geometry manager and friends
# Place a slave inside its master. Right now this doesn't process any actual grid options. Or handle multiple widgets. Or etc.
proc grid {w args} {
variable widgets
switch -exact -- $w {
"columnconfigure" {}
"rowconfigure" {}
default {
set w [namespace tail $w]
set parent [join [lrange [split $w .] 0 end-1] .]
if {$parent eq ""} {set parent "."}
if {![info exists widgets($parent)]} {error "no parent widget found"}
if {![$w _created?]} {$w _create}
if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
if {[dict keys $args -row]==""} {dict set args -row 0}
###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
[GridState for $parent] addSlave $w {*}$args
return ""
set w [namespace tail $w]
set wobj ::$w
puts [list grid $w [info object class $wobj]]
set parent [join [lrange [split $w .] 0 end-1] .]
if {$parent eq ""} {set parent "."}
if {![info exists widgets($parent)]} {error "no parent widget found"}
if {![$wobj was_created]} {$wobj do_create}
if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
if {[dict keys $args -row]==""} {dict set args -row 0}
###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
[::wtk::GridState for $parent] addSlave $w {*}$args
return ""
}
}
}
# internal state kept for each master
snit::type GridState {
typevariable states
typemethod for {w} {
if {![info exists states($w)]} {set states($w) [GridState %AUTO% $w]}
return $states($w)
odie::class ::wtk::GridState {
class_method for {w} {
my variable states
set w [namespace tail $w]
if {![info exists states($w)]} {
set states($w) [my create ::wtk::${w}#grid $w]
}
return $states($w)
}
typemethod _reset {} {foreach i [$type info instances] {$i destroy}; unset states}
class_method _reset {} {
my variable states
foreach {w obj} [array get states] {
$obj destroy
}
unset states
}
variable rows {}
variable columns {}
variable slaves ; # array
variable tabledata {}
variable master
variable id
constructor {w} {set master $w; set id [string map "obj grid" [$w id]] }
constructor {w} {
set master [namespace tail $w]
my variable rows columns tabledata master id
set rows {}
set columns {}
set tabledata {}
set id [string map "obj grid" [$master id]]
}
method jqobj {} {return "\$('#$id')"}
method jsobj {} {return "\$('#$id')\[0\]"}
method _debug {} {
my variable rows columns tabledata master id slaves
method _debug {} {return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]}
return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]
}
method addSlave {w args} {
my variable rows columns tabledata master id slaves
set w [namespace tail $w]
if {[dict keys $args -column] eq "" || [dict keys $args -row] eq ""} {error "need to supply -column and -row"}; # NOTE: caller ensures we have a column and row
set slaves($w) $args
set colnum [dict get $args -column]; set rownum [dict get $args -row]
#puts "\n BEFORE: $tabledata -> col=$colnum row=$rownum w=$w"
if {$colnum ni $columns} {$self _insertColumn $colnum}
if {$rownum ni $rows} {$self _insertRow $rownum}
set colidx [lsearch $columns $colnum]; set rowidx [lsearch $rows $rownum]
set row [lindex $tabledata $rowidx]
#puts " row=$row, colidx=$colidx"
set tabledata [lreplace $tabledata $rowidx $rowidx [lreplace $row $colidx $colidx [lreplace [lindex $row $colidx] 2 2 $w]]]
#puts " AFTER: $tabledata\n"
wtk::toclient "[$self jsobj].rows\[$rowidx\].cells\[$colidx\].appendChild(wtk.widgets\['[$w id]'\]);"
return ""
if {[dict keys $args -column] eq "" || [dict keys $args -row] eq ""} {error "need to supply -column and -row"}; # NOTE: caller ensures we have a column and row
set slaves($w) $args
set colnum [dict get $args -column]; set rownum [dict get $args -row]
#puts "\n BEFORE: $tabledata -> col=$colnum row=$rownum w=$w"
if {$colnum ni $columns} {
my _insertColumn $colnum
}
if {$rownum ni $rows} {
my _insertRow $rownum
}
set colidx [lsearch $columns $colnum]; set rowidx [lsearch $rows $rownum]
set row [lindex $tabledata $rowidx]
#puts " row=$row, colidx=$colidx"
set tabledata [lreplace $tabledata $rowidx $rowidx [lreplace $row $colidx $colidx [lreplace [lindex $row $colidx] 2 2 $w]]]
#puts " AFTER: $tabledata\n"
::wtk::toclient "[my jsobj].rows\[$rowidx\].cells\[$colidx\].appendChild(wtk.widgets\['[$w id]'\]);"
return ""
}
method _insertColumn {colnum} {
my variable rows columns tabledata master id slaves
set columns [lsort -integer [concat $columns $colnum]]; set colidx [lsearch $columns $colnum]
set new ""; set rowidx 0
foreach i $tabledata {
lappend new [linsert $i $colidx [list $colidx 1 blank]]
wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($colidx);"
::wtk::toclient "[my jsobj].rows\[$rowidx\].insertCell($colidx);"
incr rowidx
}
set tabledata $new
}
method _insertRow {rownum} {
my variable rows columns tabledata master id slaves
if {$tabledata==""} {wtk::toclient "wtk.newGrid('[$master id]','$id');"}
if {$tabledata==""} {::wtk::toclient "wtk.newGrid('[$master id]','$id');"}
set rows [lsort -integer [concat $rows $rownum]]; set rowidx [lsearch $rows $rownum];
wtk::toclient "[$self jsobj].insertRow($rowidx);"
::wtk::toclient "[my jsobj].insertRow($rowidx);"
set row ""; for {set i 0} {$i<[llength $columns]} {incr i} {
lappend row [list $i 1 blank]
wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($i);"
::wtk::toclient "[my jsobj].rows\[$rowidx\].insertCell($i);"
}
lappend tabledata $row
}
}
}
|
Changes to lib/httpd.tcl.
︙ | | |
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
|
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
|
+
-
+
|
# set url $data(url)
if {[catch {
# set timer [time {
uplevel #0 $Httpd(responsehandler) handle $sock
# }]; puts stderr "-->$timer $url"
} errmsg]!=0} {
set einfo $::errorInfo
Httpd_Log $sock Respond completed error $errmsg
if {$errmsg=="websocket"} {return}
unset -nocomplain data(inprogress)
if {$errmsg=="pending"} {
Httpd_Log $sock Respond pending
# we're waiting on something else to complete, so no sense having our
# own HttpdRead keep getting called asking us to do something with this
# socket
fileevent $sock readable {}
} else {
upvar #0 Httpd$sock data
set url ""
if {[info exists data(url)]} {
set url $data(url)
}
HttpdError $sock 500 "Error processing request"
catch {bgerror "Error processing handler for $url:\n$::errorInfo"}
catch {bgerror "Error processing handler for $url:\n$einfo"}
}
} else {
Httpd_Log $sock Respond completed ok
if {[info exists data] && (![info exists data(sendingfile)] || $data(sendingfile)!=1)} {
Httpd_Log $sock "Return had not been called during request processing; closing connection. data=[array names data]"
HttpdSockDone $sock 1
}
|
︙ | | |
Changes to lib/wtk-base.tcl.
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
|
-
+
-
+
+
+
+
+
+
-
-
-
+
+
+
-
+
-
+
-
+
-
-
-
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
+
-
+
-
+
-
+
-
+
+
+
+
+
+
+
+
|
# This code is loaded into each application instance interpreter. It maintains state
# for each widget, and then actually creates and manipulates widgets on the client side
# by sending Javascript commands. It also receives callbacks from the client side which
# are interpreted and used to update internal widget state here, which often triggers
# callbacks or other event bindings.
#
# Communication with the client is solely via the "fromclient" and "toclient" routines
# (the latter of which is setup in the wtk::init call).
# (the latter of which is setup in the ::wtk::init call).
package require snit
package require TclOO
package require log
source odie/index.tcl
###
# Add "option"
###
namespace eval ::wtk {
variable widgets
variable wobj
variable _nextid -1
variable _sender ""
# Initialization and communication
proc init {sender} {
set wtk::_sender $sender
wtk::Widget "." ""
return ""
set ::wtk::_sender $sender
::wtk::Widget "."
return ""
}
# for debugging
proc _reset {} {
variable wobj; variable widgets; variable _nextid; variable _sender
foreach {id w} [array get wobj] {$w destroy}
unset -nocomplain widgets
unset -nocomplain wobj
set _nextid -1
GridState _reset
::wtk::GridState _reset
init $_sender
return ""
}
proc toclient {cmd} {uplevel #0 $wtk::_sender [list $cmd]}
proc toclient {cmd} {uplevel #0 $::wtk::_sender [list $cmd]}
proc fromclient {cmd} {
switch -exact -- [lindex $cmd 0] {
"EVENT" {
[getwidget [lindex $cmd 1]] _event {*}[lrange $cmd 2 end]
[getwidget [lindex $cmd 1]] wtk_event {*}[lrange $cmd 2 end]
}
"LOG" {
::log::log [lindex $cmd 1] [lrange $cmd 2 end]
}
}
}
# 'Generic' widget object, which handles routines common to all widgets like
# assigning it an id, keeping track of whether or not its been created, etc.
# Purely for convenience, we also include some code here that manages widgets
# that use -text or -textvariable, though not every widget will do so.
snit::type Widget {
variable id; variable created; variable wobj; variable postcreatemsgs ""
::odie::class ::wtk::Widget {
variable id
variable tkpath
variable created
variable wobj
variable postcreatemsgs
variable propertiesDict
variable options
constructor {_wobj} {
if {$_wobj==""} {
# used for root window only
constructor {new_tkpath args} {
puts [list WIDGET [info object class [self]] $new_tkpath $args]
my variable id tkpath postcreatemsgs created options
set created 0
set postcreatemsgs {}
set tkpath $new_tkpath
if { $tkpath eq "." } {
# used for root window only
set _wobj $self
dict set propertiesDict class Toplevel
}
set wobj $_wobj
set id obj[incr wtk::_nextid]
dict set wtk::widgets([namespace tail $wobj]) id $id
set wtk::wobj($id) [namespace tail $wobj]
set created 0
dict set propertiesDict class Toplevel
}
set id obj[incr ::wtk::_nextid]
set wobj [self]
oo::objdefine [self] forward tkpath $tkpath
#my graft tkpath $tkpath
dict set ::wtk::widgets($tkpath) id $id
set ::wtk::wobj($id) [self]
foreach {var info} [my property options] {
set options(-$var) [dictGet $info -default]
}
my configurelist {*}$args
return $new_tkpath
}
method _setProperty {propertyKey value} {
class_method unknown {objname args} {
if {[string index $objname 0] eq "."} {
my create ::$objname $objname {*}$args
return $objname
}
error "Unknown method $objname. Valid: [info class methods [info object class [self]]]"
}
class_method option args {
puts $args
}
method property_set {propertyKey value} {
dict set propertiesDict {*}$propertyKey value
return $value;
}
method _hasProperty {args} {
method property_has {args} {
return [dict exists $propertiesDict {*}$propertyKey]
}
method _getProperty {args} {
method property_get {args} {
return [dict get $propertiesDict {*}$propertyKey]
}
method was_created {} {
my variable created
method _created? {} {return $created}
method _create {} {
set js [$wobj _createjs]
append js $postcreatemsgs; set postcreatemsgs ""
wtk::toclient $js
return $created
}
method do_create {} {
my variable postcreatemsgs
set js [$wobj do_createjs]
append js $postcreatemsgs
set postcreatemsgs ""
::wtk::toclient $js
set created 1
return ""
}
method action_sendWhenCreated {msg} {
if {[my was_created]} {
::wtk::toclient $msg
} else {
my variable postcreatemsgs
method _sendWhenCreated {msg} {if {[$self _created?]} {wtk::toclient $msg} else {append postcreatemsgs $msg}}
append postcreatemsgs $msg
}
}
method configure args {
if {[llength $args] == 1} {
my cget [lindex $args 0]
} else {
my configurelist {*}$args
}
}
method configurelist args {
my variable options
set dat [my info options]
foreach {var val} $args {
set field [string trimleft $var -]
if {![dict exists $dat $field]} {
error "Invalid option $var. Valid: [dict keys $dat]"
}
set info [dict get $dat $field]
set options($var) $val
if {[dict exists $info -configuremethod]} {
my [dict get $info -configuremethod] $var $val
}
}
}
method cget field {
my variable options
set field [string trimleft $field -]
if {![info exists options(-$field)]} {
set dat [my info options]
if {![dict exists $dat $field]} {
error "Invalid option -$field. Valid: [dict keys $dat]"
}
set info [dict get $dat $field]
set options(-$field) [dictGet $info -default]
}
return $options(-$field)
}
method id {} {return $id}
method jqobj {} {return "\$('#[$self id]')"}
method jsobj {} {return "wtk.widgets\['[$self id]'\]"}
method _focus {} {toclient "[$self jsobj].focus();"}
method jqobj {} {return "\$('#[my id]')"}
method jsobj {} {return "wtk.widgets\['[my id]'\]"}
method event_focus {} {toclient "[my jsobj].focus();"}
# text variable handling; only relevant if the main types delegate these options to us
option -text -configuremethod _textchanged
option -textvariable -configuremethod _textvarset
method _textchanged {opt txt {fromwidget 0}} {
set options($opt) $txt;
if {$created && !$fromwidget} {wtk::toclient [$wobj _textchangejs $txt]}
if {$options(-textvariable)!=""} {uplevel #0 set $options(-textvariable) [list $txt]}
}
method _textvariablechanged {args} {
if {$options(-text) ne [uplevel #0 set $options(-textvariable)]} {
$self _textchanged -text [uplevel #0 set $options(-textvariable)]
}
}
method _setuptextvar {} {
if {$options(-textvariable)!=""} {
if {![uplevel #0 info exists $options(-textvariable)]} {
uplevel #0 set $options(-textvariable) [list $options(-text)]
} else {
set options(-text) [uplevel #0 set $options(-textvariable)]
}
uplevel #0 trace add variable $options(-textvariable) write [list [list $self _textvariablechanged]]
}
}
method _textvarset {opt var} {
set options($opt) $var
$self _setuptextvar
}
# TODO - variable handling; only relevant if -variable option is delegated to us
# bindings
variable bindings
method _bind {ev script} {set bindings($ev) $script}
method _fireevent {ev subs} {if {[info exists bindings($ev)]} {uplevel #0 [string map $subs $bindings($ev)]}}
method action_bind {ev script} {set bindings($ev) $script}
method event_fire {ev subs} {if {[info exists bindings($ev)]} {uplevel #0 [string map $subs $bindings($ev)]}}
}
::odie::class ::wtk::LabelWidget {
superclass ::wtk::Widget
# text variable handling; only relevant if the main types delegate these options to us
option -text -configuremethod event_textchanged
option -textvariable -configuremethod event_textvarset
method event_textchanged {opt txt {fromwidget 0}} {
my variable created options
set options($opt) $txt
if {$created && !$fromwidget} {
::wtk::toclient [my _textchangejs $txt]
}
if {$options(-textvariable)!=""} {
uplevel #0 set $options(-textvariable) [list $txt]
}
}
method event_textvariablechanged {args} {
my variable options
if {$options(-text) ne [uplevel #0 set $options(-textvariable)]} {
my event_textchanged -text [uplevel #0 set $options(-textvariable)]
}
}
method event_setuptextvar {} {
my variable options
if {$options(-textvariable)!=""} {
if {![uplevel #0 info exists $options(-textvariable)]} {
uplevel #0 set $options(-textvariable) [list $options(-text)]
} else {
set options(-text) [uplevel #0 set $options(-textvariable)]
}
uplevel #0 trace add variable $options(-textvariable) write [list [list [self] event_textvariablechanged]]
}
}
method event_textvarset {opt var} {
my variable options
set options($opt) $var
my event_setuptextvar
}
}
proc getwidget {id} {return $wtk::wobj($id)}
proc getwidget {id} {return $::wtk::wobj($id)}
proc _VerifyWindowExists {window} {
variable widgets
if {![info exists ::wtk::widgets([string trimleft $window])]} {
return \
-code error \
-level 2 \
[format {bad window path name "%1$s"} $window]
}
return;
}
proc focus {w} {$w _focus; return ""}
proc bind {w ev script} {return [$w _bind $ev $script]}
proc focus {w} {$w event_focus; return ""}
proc bind {w ev script} {return [$w action_bind $ev $script]}
# Macro that can be used to simplify the definition of any widget
snit::macro _wtkwidget {args} {
::odie::macro _wtkwidget {args} {
component W; delegate method * to W; set extrainits ""
if {"-usetextvar" in $args} {delegate option -textvariable to W; delegate option -text to W; set extrainits {$W _setuptextvar}}
if {"-usetextvar" in $args} {delegate option -textvariable to W; delegate option -text to W; set extrainits {$W event_setuptextvar}}
constructor {args} "install W using Widget \$\{selfns\}::W \$self; \$self configurelist \$args; $extrainits"
}
# Macro used to define options which set their value and then send some Javascript command to the widget
snit::macro _wtkoption {opt default msg} {
::odie::macro _wtkoption {opt default msg} {
option $opt -default $default -configuremethod _wtkoption$opt
method _wtkoption$opt {opt val} "set options(\$opt) \$val; set JS \[\$self jsobj\]; set V \$val; \$self _sendWhenCreated \[subst [list $msg]\]"
method _wtkoption$opt {opt val} "
my variable options
set opt [string trimleft $opt -]
set options(\$opt) \$val
set JS \[my jsobj\]
set V \$val
my action_sendWhenCreated \[subst [list $msg]\]
"
}
}
foreach file [glob -- commands/*.tcl] {
source $file
|
︙ | | |
Added odie/codebale.tcl.