SR Technology WTK Repo
Check-in [f950e5cf61]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Re-implemented wtk in TclOO Thusfar the demo works
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA1:f950e5cf6157e03dbc4a2877b4a46fc225d815d9
User & Date: seandeelywoods 2013-01-29 20:35:57
Context
2013-02-12
14:57
Merging in changes from trunk check-in: 1cf1e20494 user: seandeelywoods tags: hypnotoad
2013-01-29
20:35
Re-implemented wtk in TclOO Thusfar the demo works check-in: f950e5cf61 user: seandeelywoods tags: hypnotoad
2013-01-22
18:31
Corrected mime type for CSS. check-in: bd8435682a user: gerald tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to README.

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


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.

It's still at what I'd consider the proof of concept stage, but it feels very promising.


Notes:

Starting the wtk app server:
|








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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 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
            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]
        }
        default {
            return  -code error  -level 1  {wrong # args: should be "bind window ?pattern? ?command?"}

        }
    }
    return [$w _bind $ev $script]
}







|






|

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 action_bind $ev $script]
        }
        default {
            return  -code error  -level 1  {wrong # args: should be "bind window ?pattern? ?command?"}

        }
    }
    return [$w action_bind $ev $script]
}

Changes to commands/focus.tcl.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
        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
        return;
    }
    switch -exact -- [lindex $args 0] {
        -displayof {
            return  -code error  -level 1  -errorcode [list WTKNOTIMPYET focus -displayof]  {[focus -displayof] not yet implemented}
        }
        -force {







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
        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 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

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
        }
}

proc ::wtk::wm::_VerifyWindowExists {window} {

    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
}


|
|
|



>
|
|
|
|
|
|
|
|
|
|
|
|



|

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
  }
}

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;
}

foreach file [glob -- [file join [file dirname [info script]] wm *.tcl]] {
  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

proc 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 "&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp"] -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
}

proc nop {args} {}

proc docheck {} {
	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 ""
	}
}

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}
	}
}


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}
		
	}
}

set ::image 0

render

wtk::focus .c.feet
wtk::bind . <Return> {calculate}




>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|

|

|
|
|
|
|
|

|

|
|
|
|
|
|

|

|
>
|
|
|
>
>
|
|
|
>
>
|
|
|
>
>
|
|
|
|
|
>

|
>
|
|
|
>
>
|
|
|
>
>
|
|
|
>
>
|
|
|
|






|
|


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 "&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp"] -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
}
  
proc nop {args} {}
  
proc docheck {} {
  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 ""
  }
}
  
proc swapimages {} {
  switch -- $::image {
    0 {
      set ::image 1; set ::textval "one"
      ::wtk::.d.ib configure -src /images/cameralens1.jpg
    }
    
    1 {
      set ::image 2; set ::textval "two"
      ::wtk::.d.ib configure -src /images/rainbow.gif
    }
    
    2 {
      set ::image 3; set ::textval "three"
      ::wtk::.d.ib configure -src /images/cameralens2.jpg
    }
    
    3 {
      set ::image 0; set ::textval "zero"
      ::wtk::.d.ib configure -src /images/logo.png
    }
  }
}
  
proc selectimg {} {
  switch -- $::textval {
    zero  {
      set ::image 0
      ::wtk::.d.ib configure -src /images/logo.png
    }
    
    one   {
      set ::image 1
      ::wtk::.d.ib configure -src /images/cameralens1.jpg
    }
    
    two   {
      set ::image 2
      ::wtk::.d.ib configure -src /images/rainbow.gif
    }
    
    three {
      set ::image 3
      ::wtk::.d.ib configure -src /images/cameralens2.jpg
    }    
  }
}

set ::image 0

render

::wtk::focus .c.feet
::wtk::bind . <Return> {calculate}


Changes to geomanagers/grid/configure.tcl.

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
    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 {[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;
}

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 {[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;
}









|


|
|











|


|
|




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
    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 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]');"
    [::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 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]');"
    [::wtk::GridState for $parent] addSlave $w {*}$args
    return;
}


Changes to geomanagers/wtk-grid.tcl.

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
    # 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 ""   
            }
        }
    }
    
    # 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)
        }
        typemethod _reset {} {foreach i [$type info instances] {$i 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]] }


        method jqobj {} {return "\$('#$id')"}
        method jsobj {} {return "\$('#$id')\[0\]"}


        method _debug {} {return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]}

        method addSlave {w args} {


            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 ""
        }
        method _insertColumn {colnum} {


            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);"
                incr rowidx
            }
            set tabledata $new
        }
        method _insertRow {rownum} {


            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);"
            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);"
            }
            lappend tabledata $row
        }
    }
    
}







|
>
>
>
>
|
|
|
<
>
|
|
|
|
|





|
>
>
|
<
|
>
>
|

<
>
>
>
>
>
>
>







>
>
>
>
>
>
>
>
|
>
>


>
>
|
>

>
>
|
|
|
|
|
>
>
|
>
|
>
|
|
|
|
|
|
|


>
>




|





>
>
|

|


|






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
    # 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 wobj ::wtk::$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
    odie::class ::wtk::GridState {

        class_method for {w} {
          my variable states

          if {![info exists states($w)]} {
            set states($w) [my create ::wtk::${w}#grid ::wtk::$w]
          }
          return $states($w)
        }

        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 ::wtk::[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
          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 ::wtk::[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} {
            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 "[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');"}
            set rows [lsort -integer [concat $rows $rownum]]; set rowidx [lsearch $rows $rownum];
            ::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 "[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
...
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572

#	set url $data(url)
	if {[catch {
#	    set timer [time {
		uplevel #0 $Httpd(responsehandler) handle $sock
#	    }]; puts stderr "-->$timer $url"
	} errmsg]!=0} {

	    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
................................................................................
	    } 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"}
	    }
	} 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
            }







>







 







|







542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
...
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
................................................................................
	    } 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$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
# 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).


package require snit







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 ""
    }

    # 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
        init $_sender
        return ""
    }

    proc toclient {cmd} {uplevel #0 $wtk::_sender [list $cmd]}

    proc fromclient {cmd} {if {[lindex $cmd 0]=="EVENT"} {[getwidget [lindex $cmd 1]] _event {*}[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 ""
        variable propertiesDict


        constructor {_wobj} {
            if {$_wobj==""} {






                # 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



        }


















        method _setProperty {propertyKey value} {
            dict set propertiesDict {*}$propertyKey value
            return $value;
        }
        method _hasProperty {args} {

            return [dict exists $propertiesDict {*}$propertyKey]
        }
        method _getProperty {args} {

            return [dict get $propertiesDict {*}$propertyKey]
        }



        method _created? {} {return $created}

        method _create {} {

            set js [$wobj _createjs]
            append js $postcreatemsgs; set postcreatemsgs ""

            wtk::toclient $js
            set created 1
            return ""
        }





        method _sendWhenCreated {msg} {if {[$self _created?]} {wtk::toclient $msg} else {append postcreatemsgs $msg}}












































        method id {} {return $id}
        method jqobj {} {return "\$('#[$self id]')"}
        method jsobj {} {return "wtk.widgets\['[$self id]'\]"}
        method _focus {} {toclient "[$self 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)]}}
    }

    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]}

    # Macro that can be used to simplify the definition of any widget
    snit::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}}
        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} {
        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]\]"

    }

}


foreach file [glob -- commands/*.tcl] {
    source $file
}
foreach file [glob -- geomanagers/*.tcl] {
    source $file
}
source widgets/wtk-widgets.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
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).

package require TclOO
package require snit

source odie/index.tcl

###
# Add "option"
###

namespace eval ::wtk {
    variable widgets
    variable wobj
    variable _nextid -1
    variable _sender ""

    # Initialization and communication
    proc init {sender} {
      puts [list ::wtk::init $sender]
      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
        ::wtk::GridState _reset
        init $_sender
        return ""
    }

    proc toclient {cmd} {uplevel #0 $::wtk::_sender [list $cmd]}

    proc fromclient {cmd} {if {[lindex $cmd 0]=="EVENT"} {[getwidget [lindex $cmd 1]] wtk_event {*}[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.

    ::odie::class ::wtk::Widget {
        variable id
        variable tkpath
        variable created
        variable wobj
        variable postcreatemsgs
        variable propertiesDict
        variable options

        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

            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] {
            puts [list -$var [dictGet $info -default]]
            set options(-$var) [dictGet $info -default]
          }
          
          my configurelist {*}$args
          return $new_tkpath
        }
        

        class_method unknown {objname args} {
          if {[string index $objname 0] eq "."} {
            my create ::wtk::$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 property_has {args} {
            return [dict exists $propertiesDict {*}$propertyKey]
        }

        method property_get {args} {
            return [dict get $propertiesDict {*}$propertyKey]
        }

        method was_created {} {
          my variable created
          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
            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 "\$('#[my id]')"}
        method jsobj {} {return "wtk.widgets\['[my id]'\]"}
        method event_focus {} {toclient "[my jsobj].focus();"}



        # TODO - variable handling; only relevant if -variable option is delegated to us


        # bindings
        variable bindings
        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 _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 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
    ::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 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
    ::odie::macro _wtkoption {opt default msg} {
        option $opt -default $default -configuremethod _wtkoption$opt
        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
}
foreach file [glob -- geomanagers/*.tcl] {
    source $file
}
source widgets/wtk-widgets.tcl

Added odie/codebale.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
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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
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
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
###
# codebale.tcl
#
# This file defines routines used to bundle and manage Tcl and C
# code repositories
#
# Copyright (c) 2012 Sean Woods
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
###

::namespace eval ::codebale {}

::namespace eval ::codebale::parse {}

###
# topic: a5992c7f-8340-ba02-d40e-386aac95b1b8
# description: Records an alias for a Tcl keyword
###
proc ::codebale::alias {alias cname} {
  variable cnames
  set cnames($alias) $cname
}

###
# topic: 0e883f35-83c0-ccd3-eddc-6b297ac2ea77
###
proc ::codebale::buffer_append {varname args} {
  upvar 1 $varname result
  if {![info exists result]} {
    set result {}    
  }
  if {[string length $result]} {
    set result [string trimright $result \n]
    append result \n
  }
  set priorarg {}
  foreach arg $args {
    if {[string length [string trim $arg]]==0} continue
    #if {[string match $arg $priorarg]} continue
    set priorarg $arg
    append result \n [string trim $arg \n] \n
  }
  set result [string trim $result \n]
  append result \n
  return $result
}

###
# topic: 926c564a-a678-8498-6f74-89f37da3fb32
###
proc ::codebale::buffer_merge args {
  set result {}
  set priorarg {}
  foreach arg $args {
    if {[string length [string trim $arg]]==0} continue
    if {[string match $arg $priorarg]} continue
    set priorarg $arg
    append result [string trim $arg \n] \n
  }
  set result [string trim $result \n]
  return $result
}

###
# topic: c1e66f4a-20e3-97a5-d254-1714575c165f
###
proc ::codebale::buffer_puts {varname args} {
  upvar 1 $varname result
  if {![info exists result]} {
    set result {}    
  }
  set result [string trimright $result \n]
  #if {[string length $result]} {
  #  set result [string trimright $result \n]
  #}
  set priorarg {}
  foreach arg $args {
    #if {[string length [string trim $arg]]==0} continue
    #if {[string match $arg $priorarg]} continue
    #set priorarg $arg
    append result \n $arg
    #[string trim $arg \n]
  }
  #set result [string trim $result \n]
  #append result \n
  return $result
}

###
# topic: 951f31f2-cb24-992f-34d9-7e3deb16b43f
# description: Reports back the canonical name of a tcl keyword
###
proc ::codebale::canonical alias {
  variable cnames
  if {[info exists cnames($alias)]} {
    return $cnames($alias)
  }
  return $alias
}

###
# topic: b1e5e6ca-f0bf-9e78-695f-995a35af7c2f
# description: Provide a keyword handler to the autodoc parser
###
proc ::codebale::define {name info} {
  global cmdref
  foreach {var val} $info {
      dict set cmdref($name) $var $val
  }
}

###
# topic: 9cca11ca-4447-43a3-21d3-ad5ac85538b1
# description:
#    A simpler implementation of digest_comment, this proc
#    takes in the raw buffer and returns a dict of the annotations
#    it found
###
proc ::codebale::digest_comment {buffer {properties {}}} {
  set result(description) {}
  set appendto description
  
  foreach line [split $buffer \n] {
    set line [string trimleft [string range $line [string first # $line] end] #]
    set line [string trimright [string trim $line] -]
    if [catch {lindex $line 0} token] {
      append result($appendto) $line \n
      #set result($appendto) [buffer_merge $result($appendto) $line]
      continue
    }
    if {[string index $token end] ne ":"} {
      append result($appendto) $line \n
      #buffer_puts result($appendto) $line
    } else {
      set field [string tolower [string trimright $token :]]
      switch $field {
        topic {
          set result(topic) [lrange $line 1 end]
          append result(description) \n
          set appendto description
        }
        comment -
        desc -
        description {
          #append result(description) [lrange $line 1 end] \n
          set result(description) [buffer_merge $result(description) [lrange $line 1 end]]
          append result(description) \n
          set appendto description
        }
        title -
        headline {
          set result(title) [lrange $line 1 end]
          append result(description) \n
          set appendto description          
        }
        ensemble_method {
          set result(type) proc
          append result(description) \n
          set appendto description
        }
        ensemble -
        nspace -
        namespace -
        class -
        agent_class -
        task -
        subtask -
        method -
        class_function -
        class_method -
        phase -
        function -
        action {
          set result(type) $field
          set result(arglist) [lrange $field 1 end]
          append result(description) \n
          set appendto description
         }
        default {
          set result($field) [lrange $line 1 end]
          append result($field) \n
          set appendto $field
        }
      }
    }
  }
  foreach {field} [array names result] {
    set result($field) [string trim $result($field)]
  }
  return [array get result]
}

###
# topic: c0304a04-9be6-f312-06a0-2d15813720ce
###
proc ::codebale::meta_output outfile {
  set fout [open $outfile w]
  puts "SAVING TO $outfile"
  
  #puts $fout "array set filemd5 \x7b"
  #array set temp [array get ::filemd5]
  #foreach {file md5} [lsort -dictionary [array names temp]] {
  #  set md5 $temp($file)
  #  puts $fout "    [list $file $md5]"
  #}
  #array unset temp
  #puts $fout "\x7d"
  puts $fout "helpdoc eval {begin transaction}"
  helpdoc eval {
    select handle,localpath from repository
  } {
    puts $fout [list ::helpdoc repository_restore $handle [list localpath $localpath]]
  }
  helpdoc eval {
    select hash,fileid from file
  } {
    puts $fout [helpdoc file_serialize $fileid]
  }
  puts $fout [helpdoc node_serialize 0]
  helpdoc eval {
    select entryid from entry
    where class='section'
    order by name
  } {
    puts $fout [helpdoc node_serialize $entryid]
  }
  helpdoc eval {
    select entryid from entry
    where class!='section'
    order by parent,class,name
  } {
    puts $fout [helpdoc node_serialize $entryid]
  }
  puts $fout "helpdoc eval {commit}"
  close $fout
}

###
# topic: cd6e815c-2e68-b751-656a-4c9bbe8918dd
# description: Filters extranous fields from meta data
###
proc ::codebale::meta_scrub {aliases info} {
  foreach {c alist} $aliases {
    foreach a $alist {
      set canonical($a) $c
    }
  }

  set outfo {}
  foreach {field val} $info {
    if {[info exists canonical($field)]} {
      set cname $canonical($field)
    } else {
      set cname $field
    }
    if {$cname eq {}} continue
    if {[string length [string trim $val]]} {
      dict set outfo $cname $val
    }
  }
  return $outfo
}

###
# topic: ead7e6fe-5660-70cc-79f0-eb2f5182465e
###
proc ::codebale::normalize_tabbing {rawblock {newspace 0}} {
  set result {}
  ###
  # clean up spaces
  ###
  set block [string map [list \t "    "] $rawblock]
  
  set spaces -1
  while {[string index $block [incr spaces]] eq " " } {}
  if { $spaces < 0} {
    return $rawblock
  }
  set count 0
  foreach line [split $block \n] {
    if {[string first " " $line] > 0} {
      set spaces -1
      break
    }
    incr count
    set i [string last " " $line]
    if { ($i+1) < $spaces } {
      set spaces [expr $i + 1]
    }
  }
  if {$spaces <= 0} {
    return $rawblock
  }
  set head [string repeat " " $newspace]
  foreach line [split $block \n] {
    append result $head [string range $line $spaces end] \n
  }
  return $result
}

###
# topic: a6ee7ffd-7430-c9cc-d666-9addf08fd039
# description:
#    Parses a script, namespace body, or class
#    definition.
###
proc ::codebale::parse_body {meta body modvar} {
  
  upvar 1 $modvar match
  set match 0
  set patterns [parser_patterns [dictGet $meta scope]]
  foreach {pat info} $patterns {
    if {[regexp $pat $body]} {
      set match 1
      break
    }      
  }

  ###
  # Pass through if we don't see any patterns to match
  ###
  if {!$match} {
    return [list body $body]
  }
  
  set thisline {}
  set thiscomment {}
  set incomment 0
  set linecount 0
  set inheader 1

  array set result {
    namespace {}
    header    {}
    body      {}
    command   {}
    comment   {}
  }
  dict set meta comment {}

  foreach line [split $body \n] {
    append thisline \n $line
    if {![info complete $thisline]} continue
    
    set parseline [string range $thisline 1 end]
    set thisline {}

    if { $incomment } {
      if {[string index [string trimleft $parseline] 0] ne "#"} {
        set incomment 0
        set thiscomment [string trimright $thiscomment \n]
      } else {
        append thiscomment $parseline \n
        continue
      }
    } elseif {[string index [string trimleft $parseline] 0] eq "#"} {
      set incomment 1
      if {$inheader} {
        if {[string length $thiscomment]} {
          append result(header) $thiscomment \n
        }
      } else {
        if {[string length $thiscomment]} {
          append result(body) $thiscomment \n
        }
      }
      set thiscomment {}
      append thiscomment $parseline \n
      continue     
    }
    
    set cmd [pattern_match $patterns $parseline]
    if {$cmd eq {}} {
      set var body
      if {$inheader} {
        set var header
      } else {
        set var body
      }    
      if {[string length $thiscomment]} {
        append result($var) [string trimright $thiscomment \n] \n
        set thiscomment {}
      }
      append result($var) $parseline \n
    } else {
      set inheader 0
      set info $meta
      dict set info comment [string trim $thiscomment]
      if {[catch {{*}$cmd $info $parseline} lresult]} {
        puts "Error: [list {*}$cmd $info $parseline]"
        puts "$lresult"
        puts $::errorInfo
        exit
        error DIE
      }
      foreach {type info} $lresult {
        switch $type {
          header - body {
            #append result($type) $info \n
            buffer_append result($type) $info
          }
          command {
            foreach {pname pinfo} $info {
              dict set result($type) $pname $pinfo           
            }
          }
          namespace {
            logicset add result(namespace) {*}$info
          }
          default {
            append result($type) $info \n
          }
        }
      }
    }
    set thiscomment {}
  }
  return [array get result]
}

###
# topic: a18c5371-2559-4150-a50c-0a21013ba712
# description:
#    Parses a namespace and redeclares any procs as
#    glob procs pointing to the current namespace
###
proc ::codebale::parse_namespace {meta def} {
  global cmdref base block fileinfo
  set nspace [lindex $def end-1]
  set body [lindex $def end]

  set nspace [string trim $nspace :]
  if { $nspace eq {} } {
    set Nspace Global
  } else {
    set Nspace $nspace
  }
  set thisline {}
  array set result {
    command {}
    body    {}
    header  {}
  }
  
  dict set aliases {} [list topic subtopic proc namespace nspace class arglist method]
  set info [digest_comment [dict get $meta comment] $meta]
  set info [meta_scrub $aliases $info]
  dict set info type namespace
  
  helpdoc node_define namespace $Nspace $info nodeid
  set result(meta) [helpdoc node_properties $nodeid]

  set comment         [rewrite_comment 0 $nodeid $result(meta)]

  array set result [parse_body [list {*}$meta namespace $nspace parent $nodeid] $body mod]
  buffer_append newbody [get result(header)] [get result(body)]
  set result(header) {}

  if {[string length [string trim $newbody]]} {
    set result(body) [buffer_merge $comment "[list namespace eval ::$nspace] \{\n$newbody\}"]
  } else {
    logicset add result(namespace) $nspace
    set result(body) {}
    #[dict get $meta comment]
  }
  set result(comment) $comment
  return [array get result]
}

###
# topic: bab541dc-7ab2-5960-b7b3-75553ef388aa
###
proc ::codebale::parse_ooclass {meta def} {
  set nspace [lindex $def end-1]
  set body   [lindex $def end]

  set nspace [string trim $nspace :]
  
  set thisline {}
  array set result {
    command {}
    body    {}
    header  {}
  }
  
  set info [digest_comment [dict get $meta comment] $meta]
  dict set aliases {} [list topic subtopic proc namespace nspace class arglist method]
  set info [meta_scrub $aliases $info]
  dict set info type class
  helpdoc node_define class $nspace $info nodeid
  set result(meta)    [helpdoc node_properties $nodeid]
  set comment         [rewrite_comment 0 $nodeid $result(meta)]
  
  ###
  # Write in the results
  ###
  array set result [parse_body [list {*}$meta class $nspace parent $nodeid scope ooclass] $body mod]
  buffer_append newbody [get result(header)] [get result(body)]
  set result(header) {}
  foreach {mname} [lsort -dictionary [dict keys $result(command)]] {
    buffer_append newbody [dict get $result(command) $mname]
  }
  unset result(command)

  set result(body) [buffer_merge $comment "[list {*}[lrange $def 0 end-1]] \{\n$newbody\}"]
  set result(comment) $comment
  return [array get result]
}

###
# topic: 16fbb45b-8e9a-a13b-0b89-2270fd7537ff
# description:
#    This procedure reads in the definition of a method,
#    marks it up in the help documentation, and seeds the
#    re-writer so that this method is creates in sorted order
###
proc ::codebale::parse_oomethod {meta def} {
  set token    [lindex $def 0]
  if {[string range $token 0 5]=="class_"} {
    set cmd "class_method"
    set class class_method
  } else {
    set cmd "method"
    set class method
  }
  set def "  [list $cmd {*}[lrange $def 1 end-1]] \{[lindex $def end]\}"
  set def [normalize_tabbing $def 2]

  set token    [lindex $def 0]
  set procname [string trim [lindex $def 1] :]
  set fullname [string trimleft $class :]::$procname
  if {[llength $def] < 4} {
    set arglist dictargs
    set darglist dictargs
    set body [lindex $def 3]
  } else {
    set arglist [lindex $def 2]
    set body [lindex $def 4]
    ###
    # Clean up args
    ###
    set darglist {}
    foreach n $arglist {
      if [catch {
      if {[llength $n] > 1} {
        lappend darglist "?[lindex $n 0]?"
      } else {
        lappend darglist [lindex $n 0]
      }
      } err] {
        lappend darglist $n
      }
    }
  }
  
  ###
  # Document
  ###
  set info [digest_comment [dict get $meta comment] $meta]
  set type [dictGet $info type]

  if {$type eq {}} {
    set type [string trim $token :]
    if { $type ne "method" } {
      dict set info type $type
    }
  }
  
  dict set aliases returns {return yields}
  dict set aliases {} [list topic subtopic proc namespace nspace class arglist method $type]
  set info [meta_scrub $aliases $info]
  dict set info type $type
  dict set info arglist $darglist
  helpdoc node_define_child [dictGet $meta parent] $class $procname $info nodeid
  set result(meta)    [helpdoc node_properties $nodeid]
  set result(comment) [rewrite_comment 2 $nodeid $result(meta)]

  set result(command) $def
  return [list command [list ${class}::${procname} [buffer_merge $result(comment) $result(command)]]]
}

###
# topic: 2e9b9100-a28c-1d6d-d421-95779706ad24
# description:
#    This procedure reads in the definition of a method,
#    marks it up the ancestors for this object
###
proc ::codebale::parse_oosuperclass {meta def} {
  set parentid [dictGet $meta parent]
  foreach class [lrange $def 1 end] {
    set ancestor [helpdoc node_id [list class $class] 1]
    helpdoc link_create $parentid $ancestor class_ancestor
  }
  return [list header $def]
}

###
# topic: 0360b378-6857-5d30-2ab6-f15e88365266
###
proc ::codebale::parse_path {info base args} {
  set rewrite 0
  set repo    source
  dict with info {}

  set pathlist $args
  if {[llength $pathlist]==0} {
    set pathlist $base
  }
  
  set stack {}
  foreach path $pathlist {
    stack push stack $path
  }
  set filelist {}
  while {[stack pop stack stackpath]} {
    lappend filelist {*}[sniffPath $stackpath stack]
  }
  set meta [list repo $repo rewrite $rewrite base $base]
  if {![helpdoc exists {select localpath from repository where handle=:repo}]} {
    helpdoc eval {insert into repository (handle,localpath) VALUES (:repo,:base);}
  } else {
    helpdoc eval {update repository set localpath=:base where handle=:repo;}
  }
  foreach {type file} $filelist {
    switch $type {
      parent_name -
      source {
        if { [file tail $file] in {version_info.tcl packages.tcl lutils.tcl}} continue
        if {[catch {
          parse_tclsourcefile $meta $file $rewrite
        } err]} {
          puts [list $file $err]
          puts $::errorInfo
          if {[file exists $file.new]} {
            puts "X $file.new"
            file delete $file.new
          }
        }
      }
      csource {
        if {[catch {
          read_csourcefile $file
        } err]} {
          puts [list $file $err]
        }
      }
      index {
        continue
      }
    }
  }
}

###
# topic: 70a6c102-860a-d996-77f3-c4f2021a5308
# description:
#    This procedure reads in the definition of a procedures,
#    marks it up in the help documentation, and seeds the
#    re-writer so that this procedure is defined from the
#    global namespace
###
proc ::codebale::parse_procedure {meta def} {
  set def [normalize_tabbing $def]

  foreach {token procname arglist body} $def break;
  set rawproc $procname
  set proc [namespace tail $procname]
  set nspace [string trimleft [proc_nspace $rawproc] :]
  if { $nspace eq {} } {
    set nspace [dictGet $meta namespace]
  }
  if {$nspace in {{} ::}} {
    set fullname [string trim $proc :]
  } else {
    set fullname ${nspace}::${proc}
  }
  set result(namespace) $nspace
  set result(command) [list $token ::$fullname $arglist]
  append result(command) " \{$body\}"

  ###
  # Document
  ###
  set type [string trim $token :]
  dict set aliases yields return
  dict set aliases {} [list topic subtopic proc namespace nspace class arglist $type]

  set info [digest_comment [dict get $meta comment] $meta]
  set info [meta_scrub $aliases $info]
  
  dict set info type $type
  ###
  # Clean up args
  ###
  set darglist {}
  foreach n $arglist {
    if {[llength $n] > 1} {
      lappend darglist "?[lindex $n 0]?"
    } else {
      lappend darglist [lindex $n 0]
    }
  }
  dict set info arglist $darglist

  helpdoc node_define proc $fullname $info nodeid
  set result(meta) [helpdoc node_properties $nodeid]
  set result(comment) [rewrite_comment 0 $nodeid $result(meta)]

  return [list command [list $fullname [buffer_merge $result(comment) $result(command)]] namespace $result(namespace)]
}

###
# topic: 7c9f9cea-7829-7eef-903b-3f711033a993
###
proc ::codebale::parse_tclsourcefile {meta file {rewrite 0}} {
  global classes block filename fileinfo
  variable parser_patterns
  array unset filestore
  
  dict with meta {}

  set i [string length $base]

  set fname [file rootname [file tail $file]]
  set dir [string trimleft [string range [file dirname $file] $i end] /]
  set fpath $dir/[file tail $file]
  set filename $dir/[file tail $file]

  set repomd5 [helpdoc file_hash [list $repo $fpath]]
  set md5 [::md5::md5 -hex -file $file]
  
  if {!$::force_check} {
    if { $md5 eq $repomd5} { return 0 }
  }
  
  set info {}
  dict set info mtime [file mtime $file]
  dict set info hash  $md5
  dict set info path  $fpath
  dict set info filename [file tail $file]
  dict set info repo  $repo
  helpdoc file_restore [list $repo $fpath] $info
  
  #set ::filemd5($fpath) $md5
  
  set fin [open $file r]
  set dat [read $fin]
  close $fin
  
  puts "<< $fpath"
  set fileinfo {}
  set result [parse_body [list namespace {} file $file] $dat patmatch]
  if {!$rewrite || !$patmatch} {
    return $patmatch
  }
  ###
  # Rewrite the tcl sourcefile
  ###
  set buffer {}

  set ndefined {}
  set header {}
  set body {}
  set command {}
  set namespace {}
  set buffer {}
  dict with result {}
  buffer_append buffer $header
  foreach ns [lsort -dictionary $namespace] {
    if { $ns ne {} } {
      append buffer \n [list ::namespace eval ::$ns {}] \n
    }
  }  
  if {[llength $command]} {
    foreach {nsproc} [lsort -dictionary [dict keys $command]] {
      buffer_append buffer [dict get $command $nsproc]
    }
  }
  buffer_append buffer $body

  set oldlines [split $dat \n]
  set newlines [split $buffer \n]
  set idx -1
  set identical 1
  foreach oldline $oldlines {
    set newline [lindex $newlines [incr idx]]
    if {[string trim $oldline] ne [string trim $newline]} {
      set identical 0
      break
    }
  }
  if {$identical} {
    if {[file exists $file.new]} {
      puts "~ $file.new"
      file delete $file.new
    }
    return $patmatch
  }
  puts ">> $fpath.new"
  set fout [open $file.new w]
  fconfigure $fout -translation crlf
  puts $fout $buffer
  close $fout
  return $patmatch
}

###
# topic: 233756d1-a3b7-6fa9-3023-ccae156e0ec5
###
proc ::codebale::parser_addpattern args {
  variable parser_patterns
  dict set parser_patterns {*}$args
}

###
# topic: d086f779-79bd-e4d7-f60d-41af050c529d
###
proc ::codebale::parser_patterns scope {
  variable parser_patterns
  set result {}
  foreach {pat info} [dictGet $parser_patterns $scope] {
    dict set result $pat $info
  }
  return $result
}

###
# topic: 6fd968f4-2730-f701-c0fa-3ca32b8f7785
###
proc ::codebale::pattern_match {patterns parseline} {
  set parseline [string trimleft $parseline :]
  foreach {pat patinfo} $patterns {
    set idx -1
    set match 1
    foreach a $pat {
      incr idx
      if [catch {lindex $parseline $idx} token] {
        set match 0
        break
      }
      if {![string match $token $a] } {
        set match 0
        break
      }
    }
    if { $match } {
      return $patinfo
    }
  }
  return {}
}

###
# topic: 929629f0-ebaa-5547-10f6-6410dfa51f8a
###
proc ::codebale::pkgindex_path {base stackvar} {
  upvar 1 $stackvar stack

  set buffer {
set BASE [file dirname [file normalize [info script]]]
}
  set base [file normalize $base]
  set i    [string length  $base]
  
  set result {}
  while {[stack pop stack stackpath]} {
    foreach {type file} [::codebale::sniffPath $stackpath stack] {
      switch $type {
        parent_name {
          set file [file normalize $file]
          set fname [file rootname [file tail $file]]
          ###
          # Assume the package is correct in the filename
          ###
          set package [lindex [split $fname -] 0]
          set version [lindex [split $fname -] 1]
          set path [string trimleft [string range [file dirname $file] $i end] /]
          ###
          # Read the file, and override assumptions as needed
          ###
          set fin [open $file r]
          set dat [read $fin]
          close $fin
          foreach line [split $dat \n] {
            set line [string trim $line]
            if { [string range $line 0 9] != "# Package " } continue
            set package [lindex $line 2]
            set version [lindex $line 3]
            break
          }
          append buffer "package ifneeded $package $version \[list source \[file join \$BASE $path [file tail $file]\]\]"
          append buffer \n
        }
        source {
          set file [file normalize $file]
          if { $file == [file join $base packages.tcl] } continue
          if { $file == [file join $base main.tcl] } continue
          if { [file tail $file] == "version_info.tcl" } continue
          set fin [open $file r]
          set dat [read $fin]
          close $fin
          if {![regexp "package provide" $dat]} continue
          set fname [file rootname [file tail $file]]
          set dir [string trimleft [string range [file dirname $file] $i end] /]
          
          foreach line [split $dat \n] {
            set line [string trim $line]              
            if { [string range $line 0 14] != "package provide" } continue
            set package [lindex $line 2]
            set version [lindex $line 3]
            append buffer "package ifneeded $package $version \[list source \[file join \$BASE $dir [file tail $file]\]\]"
            append buffer \n
            break
          }
        }
        index {
          set dir [string trimleft [string range [file dirname $file] $i end] /]
          append buffer "set dir \[file join \$BASE $dir\] \; source \[file join \$BASE $dir pkgIndex.tcl\]"
          append buffer \n
        }
      }
    }
  }
  return $buffer
}

###
# topic: f9b3ce3a-afc9-72b5-5e33-0ac9b62c31db
###
proc ::codebale::proc_nspace procname {
  set rawproc $procname
  set proc [namespace tail $procname]
  set n [string last $proc $rawproc]
  if { $n == 0 } {
    set nspace {}
  } else {
    set nspace [string range $rawproc 0 [expr {$n - 1}]]
    set nspace [string trimleft $nspace :]
    set nspace [string trimright $nspace :]
  }
  return $nspace
}

###
# topic: 27a7f169-8a00-fb29-4f2c-700a8d8acb7e
###
proc ::codebale::read_csourcefile file {
  global classes base filename
  puts "Reading $file"
  ###
  # Skip the sqlite amalgamation file. It's huge and not marked
  # up the way we need anyway
  ###
  if {[file tail $file] eq "tclsqlite3.c"} {return 0}
  set i [string length $base]

  set fname [file rootname [file tail $file]]
  set dir [string trimleft [string range [file dirname $file] $i end] /]
  set fpath $dir/[file tail $file]
  set filename $dir/[file tail $file]
  set fin [open $file r]
  set dat [read $fin]
  close $fin
  set found 0

  set thisline {}
  set thiscomment {}
  set incomment 0
  set parentid tclcmd
  foreach line [split $dat \n] {
    set line [string trim $line]
    if {[string range $line 0 1] == "/*" } {
        set incomment 1
    }
    if { $incomment } {
      set pline [string trimleft $line "/"]
      set pline [string trimleft $pline "*"]
      set pline [string trimright $pline "/"]
      set pline [string trimright $pline "*"]
      append thiscomment $pline \n


      if {[string range $line end-1 end] eq "*/" } {
        set incomment 0
        #if {[file tail $filename] eq "wallset.c"} {
        #  puts "...COMMENT..."
        #  puts $thiscomment
        #}
        set info [digest_comment $thiscomment [list file $fpath]]
        set thiscomment {}
        set nodeid {}
        set found 0
        foreach {var val} $info {
          switch $var {
            topic {
              set nodeid $val
              dict unset info $var
            }
            tclcmd -
            tclmod {
              if { $nodeid eq {} } {
                set nodeid   [helpdoc node_id [list tclcmd [lindex $val 0]] 1]
              }
              set parentid $nodeid
              helpdoc node_property_set $nodeid usage $val
              dict unset info $var
            }
            tclmethod -
            tclsubcmd {
              if { $nodeid eq {} } {
                set nodeid [helpdoc node_id [list tclcmd [lindex $val 0] method [lindex $val 1]] 1]
              }
              dict unset info $var
              helpdoc node_property_set $nodeid usage   $val              
              helpdoc node_property_set $nodeid arglist [lrange $val 2 end]
            }
          }
        }
        if { $nodeid ne {} } {
          #puts [list $nodeid $info]
          helpdoc node_property_set $nodeid file $fpath

          dict set info file $fpath
          foreach {var val} $info {
            switch $var {
              topic -
              tclcmd -
              tclmod -
              tclmethod -
              tclsubcmd {}
              default {
                helpdoc node_property_set $nodeid $var $val
              }
            }
          }
        }
      }
    }
  }
  return 1
}

###
# topic: 7958a706-b48a-9bc4-4cbb-ef73813e0fb2
###
proc ::codebale::rewrite_comment {spaces topic info} {
  set result {}
  set head [string repeat " " $spaces]
  set class [helpdoc one {select class from entry where entryid=:topic}]
  if { $class eq [dictGet $info type] } {
    dict unset info type
  }

  set order [dict keys $info]
  logicset remove order type description arguments returns yields title
  set order [linsert order 0 title type]
  lappend order description arguments returns yields
  foreach {field} $order {
    set val [dictGet $info $field]
    ###
    # Fields to drop for meta-data
    ###
    set dtext [split [string trim $val] \n]
    if {![llength $dtext]} {
      continue
    }
    if {[llength $dtext] == 1} {
      append result \n "${head}# ${field}: [string trim [lindex $dtext 0]]"
    } else {
      append result \n "${head}# ${field}:"
      foreach dline $dtext {
        append result \n "${head}#    [string trim $dline]"
      }
    }
  }

  set result [buffer_merge "${head}###" "${head}# topic: $topic" $result "${head}###"]
}

###
# topic: d8ef9620-b068-3a82-3761-1725abc83192
# description:
#    Descends into a directory structure, returning
#    a list of items found in the form of:
#    type object
#    where type is one of: csource source parent_name
#    and object is the full path to the file
###
proc ::codebale::sniffPath {spath stackvar} {
  upvar 1 $stackvar stack    
  set result {}

  if { ![file isdirectory $spath] } {
    switch [file extension $spath] {
      .tm {
        return [list parent_name $spath]
      }
      .tcl {
        return [list source $spath]
      }
      .c {
        return [list csource $spath]
      }
    }
  }
  if { [string toupper [file tail $spath]] == "CVS" } return
  if {[file extension $spath] eq ".vfs"} return
  if {[file exists [file join $spath pkgIndex.tcl]]} {
    lappend result index [file join $spath pkgIndex.tcl]
  } else {
    foreach f [glob -nocomplain $spath/*.tcl] {
      lappend result source $f
    }
  }
  foreach f [glob -nocomplain $spath/*.tm] {
    lappend result parent_name $f
  }
  foreach f [glob -nocomplain $spath/*.c] {
    lappend result csource $f
  }
  foreach f [glob -nocomplain $spath/*] {
    while {[file type $f]=="link"} {
      set f [file readlink $f]
    }
    if [file isdirectory $f] {
      stack push stack $f
    }
  }
  return $result
}

set ::force_check 0

###
# topic: c790d2a5-043a-5f76-a476-143db91bd729
###
namespace eval ::codebale {
  alias nspace namespace

  parser_addpattern {}  {namespace eval}   ::codebale::parse_namespace
  parser_addpattern {}  proc               ::codebale::parse_procedure
  parser_addpattern {}  ensemble_method    ::codebale::parse_procedure
  parser_addpattern {}  odie::class        ::codebale::parse_ooclass  
  parser_addpattern {}  {oo::class create} ::codebale::parse_ooclass
  parser_addpattern ooclass method         ::codebale::parse_oomethod
  parser_addpattern ooclass proc           ::codebale::parse_oomethod
  parser_addpattern ooclass class_method   ::codebale::parse_oomethod
  parser_addpattern ooclass superclasses   ::codebale::parse_oosuperclass
}

Added odie/global.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
###
# global.tcl
#
# This file defines Global functions that are genuinely useful
#
# Copyright (c) 2012 Sean Woods
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
###


###
# topic: 4dffef8f-9697-b8e7-e868-c3ad6cae2f00
# description: Export a namespace as an ensemble command
###
proc ::ensemble_build namespace {
  #if {[info command $namespace] ne {}} {
  #  return
  #}
  namespace eval $namespace {
    namespace export *
    namespace ensemble create
  }
}

###
# topic: 74aa80cd-d83e-751b-aa89-c413b6834b12
# description:
#    Provide an implementation in Tcl
#    for a function if none exists already in C
###
proc ::ensemble_method {name args body} {
  #puts [list ensemble_method $name [info script]]
  if {[info command $name] ne {}} return
  #proc $name $args "puts $name \n $body"
  proc $name $args $body
}

###
# topic: 87bd2757-7441-255a-f6fb-8781aacdb50d
# type: ensemble_method
###
ensemble_method ::dictGet {dictvar args} {
  if {[dict exists $dictvar {*}$args]} {
    return [dict get $dictvar {*}$args]
  }
  return {}
}

###
# topic: 58ef6deb-c315-edf9-c8ec-fe5ed710b07d
# type: ensemble_method
###
ensemble_method ::get varname {
  upvar 1 $varname var
  if {[info exists var]} {
    return [set var]
  }
  return {}
}

###
# topic: 84ff222d-9f57-4a40-5804-0b99485cd6ff
# type: ensemble_method
###
ensemble_method ::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
    set var {}
  }
  foreach item $args {
    if { $item ni $var} {
      lappend var $item
    }
  }
  return $var
}

###
# topic: 9591fb2c-2d1d-be3e-b92d-6e993589a452
# type: ensemble_method
###
ensemble_method ::ladd_sorted {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
    set var {}
  }
  foreach item $args {
    lappend var $item
  }
  set var [lsort -dictionary -unique $var]
  return $var
}

###
# topic: f0367444-a3ae-9186-1ee8-31f757fc4621
# type: ensemble_method
###
ensemble_method ::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i {}]
    }
  }
}

Added odie/index.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
###
# index.tcl
#
# This file loads the rest of the odie package
#
# Copyright (c) 2012 Sean Woods
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
###

package provide odie 0.1

###
# topic: 8b8d3c47-197b-0abe-5005-b2a644ebcb7d
###
proc ::load_path {path {ordered_files {}}} {
  lappend loaded index.tcl pkgIndex.tcl
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $ordered_files {
    lappend loaded $file
    uplevel #0 [list source [file join $path $file]]
  }
  foreach file [glob -nocomplain [file join $path *.tcl]] {
    if {[file tail $file] in $loaded} continue
    lappend loaded [file tail $file]
    uplevel #0 [list source $file]
  }
}

set loaded {pkgIndex.tcl index.tcl}

set odie_path [file dirname [info script]]

load_path $odie_path {
  global.tcl
  logicset.tcl
  stack.tcl
  ootools.tcl
  moac.tcl
}

Added odie/license.terms.













































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
This software is copyrighted by the Sean Woods.  The following terms apply
to all files associated with the software unless explicitly disclaimed in
individual files.

The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.

IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.

GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal 
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license. 

Added odie/logicset.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
###
# logicset.tcl
#
# This file defines the method needed for the tcl inplementation
# of logical sets
#
# Copyright (c) 2012 Sean Woods
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
###

::namespace eval ::logicset {}

###
# topic: 08efb87d-9c9b-36e8-64f5-0a05ff0811f5
# type: ensemble_method
###
ensemble_method ::logicset::add {setvar args} {
  upvar 1 $setvar result
  if {![info exists result]} {
    set result {}
  }
  foreach arg $args {
    if { $args ni $result } {
      lappend result $arg
    }
  }
  return $result
}

###
# topic: bd1fdea7-e32f-113f-6b4b-b1fe7455d5fd
# type: ensemble_method
###
ensemble_method ::logicset::cartesian_product {A B} {
  set result {}
  foreach alement [sort $A] {
    foreach blement [sort $B] {
      lappend result $alement $blement
    }
  }
  return $result
}

###
# topic: d3032d6a-b1d1-656e-afab-a99bb80e09a9
# type: ensemble_method
###
ensemble_method ::logicset::contains {setval args} {
  foreach arg $args {
    if { $arg ni $setval } {
      return 0
    }
  }
  return 1
}

###
# topic: d642d345-9294-81a0-cd88-38b825966629
# type: ensemble_method
###
ensemble_method ::logicset::empty setval {
  if {[llength $setval] == 0} {
    return 1
  }
  return 0
}

###
# topic: aaf46124-7085-3353-aba3-88d113cd0e78
# type: ensemble_method
###
ensemble_method ::logicset::intersection {A B} {
  set result {}
  foreach element $B {
    if { $element in $A } {
      add result $element
    }
  }
  return $result
}

###
# topic: 5ff774e0-3ce3-fd96-38e0-3c83a0c7b1a4
# type: ensemble_method
###
ensemble_method ::logicset::remove {setvar args} {
  upvar 1 $setvar result
  if {![info exists result]} {
    set result {}
  }
  foreach arg $args {
    while { $arg in $result } {
      ldelete result $arg
    }
  }
  return $result
}

###
# topic: ca1ffbc9-d3ff-fbc4-4a2e-d63ed823573d
# type: ensemble_method
###
ensemble_method ::logicset::set_difference {U A} {
  set result {}
  foreach element $A {
    if { $element ni $U } {
      add result $element
    }
  }
  return $result
}

###
# topic: ddb93085-3ab4-a3b3-61e1-fc2133a7c79a
# type: ensemble_method
###
ensemble_method ::logicset::sort A {
  return [lsort -dictionary -unique $A]
}

###
# topic: 13e4ecbf-7e85-e27f-c293-a4b42ad48c30
# type: ensemble_method
###
ensemble_method ::logicset::symmetric_difference {A B} {
  set result {}
  foreach element $A {
    if { $element ni $B } {
      add result $element
    }
  }
  foreach element $B {
    if { $element ni $A } {
      add result $element
    }
  }
  return $result
}

###
# topic: 49074428-2a40-261f-0d63-192290657d9b
# type: ensemble_method
###
ensemble_method ::logicset::union {A B} {
  set result {}
  add result {*}$A
  add result {*}$B
  return $result
}

ensemble_build ::logicset

Added odie/moac.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
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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
###
# topic: 5539066c-3e90-2cbd-b008-77a2eb4e7acd
# title: Mother of all Classes
# description:
#    Base class used to define a global
#    template of expected behaviors
###
odie::class moac {
  variable objectInfo
  

  ###
  # topic: 3c54cd52-e671-de60-2102-ebf9d5562a2d
  ###
  method debugOut string {}

  ###
  # topic: dfd570ca-bd5e-28af-f080-8fc28d36b54d
  # description: Bind an object to an event
  ###
  method event:bind {
    my variable event_map

    set event {}
    set script {}
    set idvar {}
    my event declare $dictargs
    dict with dictargs {}
    
    if { [string length $idvar] } { upvar $idvar id }

    if { ![info exists event_map($event)] } {
      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
        [format "unknown event \"%s\"" $event]
    }
  
    set id [incr event_map($event)]
    set event_map($event:$id) $script
    lappend event_map($event:list) $id
    return $id
  }

  ###
  # topic: 74d04ba1-8164-691a-91c9-e553c74f5cbe
  # description: Declares an oo event
  ###
  method event:declare {
    my variable event_map
    set event [dictGet $dictargs event]
    if { [string length $event] } {
      if {![info exists event_map($event)]} {
        set event_map($event)      -1
        set event_map($event:list) {}
        set event_map($event:subscribers) {}
      }
    } else {
      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
        "null event identifier"
    }
    return
  }

  ###
  # topic: a037c835-6d4c-767d-5104-78770a4b63ae
  # description: Detach an event from an object
  ###
  method event:detach {
    my variable event_map
    
    set event {}
    set id    {}
    dict with dictargs {}
    
    if { ! [info exists event_map($event)] } {
      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
        [format "unknown event \"%s\"" $event]
    }
    if { ! [info exists event_map($event:$id)] } {
      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
        [format "unknown script identifier \"%s\" for event \"%s\"" \
        $id $event]
    }
    
    unset event_map($event:$id)
    set idx [lsearch -sorted $event_map($event:list) $id]
    set event_map($event:list) [lreplace $event_map($event:list) $idx $idx]
  }

  ###
  # topic: 35db60ff-f0bb-e3df-3b41-126a38a49b2c
  # description: Forget an event
  ###
  method event:forget {
    my variable event_map

    set event {}
    dict with dictargs {}

    foreach key [array names event_map $event*] { unset event_map($key) }
    foreach event [lrange $args 1 end] {
      foreach key [array names event_map $event*] { unset event_map($key) }
    }
  }

  ###
  # topic: 401fbdb2-1e5b-47b0-ecbb-78c3f3ceaa71
  # description:
  #    Generate an event
  #    Adds a subscription mechanism for objects
  #    to see who has recieved this event and prevent
  #    spamming or infinite recursion
  ###
  method event:generate {
    my variable event_map

    set event {}
    set info $dictargs
    set strict 0
    set sender [self]
    dict with dictargs {}

    set self [self]

      dict set info id     event#[format %0.8x [incr ::odie::event_count]]
      dict set info origin $self
      dict set info event  $event
      dict set info sender $self
      dict set info rcpt   {}
    
    dict set info self $self
    set rcpt [dictGet $info rcpt]
    if {![info exists event_map($event)]} {
      if { $strict && $sender eq {} } {
        return -code error -errorcode "LOGIC INVALID_ARGUMENT" [format "unknown event \"%s\"" $event]
      }
      return
    }
    foreach pat [get event_map($event:subscribers)] {
      logicset add wholist {*}[info command $pat]
    }
    logicset remove wholist $self
    dict unset info self
    foreach who [lsort -dictionary -decreasing $wholist] {
      $who event notify $info
    }
    my event notify $info
  }

  ###
  # topic: 6056849a-7b71-f512-4f45-bc5d71c62cdf
  # description: Pass a subscribed event to this object
  ###
  method event:notify {
    my variable event_map
    set sender [self]
    dict with dictargs {}
    if {![info exists event_map]} return
    foreach {field value} $dictargs {
      lappend valuemap %${field} $value
    }
    dict set valuemap %sender [dictGet $dictargs $sender]
    dict set valuemap %self   [self]
    
    foreach id [get event_map($event:list)] {
      eval [string map $valuemap [list {*}$event_map($event:$id)]]
    }
  }

  ###
  # topic: 2955042c-8789-2c89-e4e1-eb55c1c35635
  # description:
  #    Subscribe calls for an ensemble to be
  #    passed on to another object
  ###
  method event:subscribe {
    my variable event_map

    set event {}
    set who   {}
    dict with dictargs {}
    
    my event declare event $event
    ::logicset add event_map($event:subscribers) $who
  }

  ###
  # topic: 1c0f43e0-e33d-bb2a-4923-4b7b79ea5252
  # description:
  #    Subscribe calls for an ensemble to be
  #    passed on to another object
  ###
  method event:unsubscribe {
    my variable event_map

    set event {}
    set who   {}
    dict with dictargs {}
    
    my event declare event $event
    ::logicset remove event_map($event:subscribers) $who
  }

  ###
  # topic: e04b7ac7-2d11-853d-e591-28469a01f1b8
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }

  ###
  # topic: 92971042-7138-47f7-88b0-7704312df200
  ###
  method get {{field {}}} {
    my variable objectInfo
    if { $field == {} } {
      set result {}
      foreach f [::info object vars [self]] {
        my variable $f
        if {[array exists $f]} {
          dict set result @$f [::array get $f]
        } else {
          dict set result $f [set $f]
        }
      }
      return $result
    }
    my variable $field
    if {[array exists $field]} {
      return [::array get $field]
    }
    if {[info exists $field]} {
      return [set $field]
    }
    return {}
  }

  ###
  # topic: 7be7adbd-32da-8c19-909a-eab4d140fce4
  ###
  method getVarname field {
    return [my varname $field]
  }

  ###
  # topic: e1c1cccb-5201-997d-e0c5-4e04394b61e2
  ###
  method graft args {
    my variable organs
    foreach {stub object} $args {
      set stub [string trimleft $stub /]
      logicset add organs $stub
      my put [list $stub $object]
      my forward ${stub} $object
      # Provide a more standard "/->object" stub
      #my forward /${stub} $object
    }
  }

  ###
  # topic: df00845e-dcbf-6f93-65b9-ee824513102a
  ###
  method morph newclass {
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command $newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      oo::objdefine [self] class ::${newclass}
    }
  }

  ###
  # topic: 3826d482-8446-2b39-4590-1d02d1ba67e2
  ###
  method organsExport {} {
    my variable organs
    set result {}
    if {![info exists organs]} return
    foreach organ $organs {
      lappend result $organ [my get $organ]
    }
    return $result
  }

  ###
  # topic: 886b734b-f9a9-8aa7-82e8-f77b9a42c344
  ###
  method put args {
    if { [llength $args] == 1 } {
      set args [lindex $args 0]
    }
    foreach {key val} $args {
      string trimleft $key -
      my variable $key
      set $key $val
    }
  }

  ###
  # topic: 5b9a51d5-e327-84f0-8cb7-973e8f4115f0
  ###
  method sensai object {
    foreach {stub obj} [$object organsExport] {
      my graft $stub $obj
    }
  }
}

Added odie/oosqlite.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
###
# topic: cceceb5d-a991-e07b-6eeb-21375178fa46
###
odie::class moac.sqliteDb {
  superclass moac
  property docentry {}

  ###
  # topic: 6e0d9dea-cbb3-7b09-98b4-d1b3f2fcc1e3
  ###
  method attach {alias filename} {
    set exists [file exists $filename]
    sqlite3 [self]::${alias} $filename
    my database_functions [self]::${alias}
    my graft $alias [self]::${alias}
    my attach_sqlite_methods [self]::${alias}
    if {!$exists} {
      my database_create $alias
    }
  }

  ###
  # topic: 080a0a01-e018-a81c-9f3d-7a696a0698c9
  ###
  method attach_sqlite_methods sqlchan {
    my graft db $sqlchan
foreach func {
authorizer
backup
busy
cache
changes
close
collate
collation_needed
commit_hook
complete
copy
enable_load_extension
errorcode
eval
exists
function
incrblob
last_insert
last_insert_rowid
nullvalue
one
onecolumn
profile
progress
restore
rollback_hook
status
timeout
total_changes
trace
transaction
unlock_notify
update_hook
version
    } {
        my forward $func $sqlchan $func
    }
  }

  ###
  # topic: d4ac9357-de80-79b0-24a8-a48c07ceac06
  # title: Default implementation of change
  # description: Just a simple passthrough to eval
  ###
  method change args {
    uplevel 1 [list [self] eval {*}$args]
  }

  ###
  # topic: a8f26a9d-1cbd-4992-dfe3-3a4a25a065b0
  ###
  method database_create alias {
    
  }

  ###
  # topic: 76de1589-de3f-78c3-b38c-83502c65cc30
  ###
  method database_functions sqlchan {
  }

  ###
  # topic: af76cd3e-8d30-4841-95d5-99d44e4a00b3
  ###
  method native_tableget table {
    set info {}
    my one {select type,sql from sqlite_master where tbl_name=$table} {
      foreach {type field value} [::schema::createsql_to_dict $sql] {
        dict set info $type $field $value
      }
    }
    return $info
  }

  ###
  # topic: e1811960-ced8-4756-76b4-64def58a2a1c
  ###
  method native_tablelist {} {
      return [my eval {SELECT name FROM sqlite_master WHERE type ='table'}]
  }

  ###
  # topic: cac2e473-a72e-f1d2-180a-fdd417117b0d
  ###
  method schema_dump {} {
    set result {}
    foreach table [my schema_tablelist] {
      dict set result $table [my schema_get $table]
    }
    return $result
  }

  ###
  # topic: 60cc2296-f2e2-4a12-24b7-4dd459d8b49b
  ###
  method schema_fields table {
    set dentry [my property docentry]
    if {![::helpdoc node_exists [list schema $dentry sqltable $table] entryid]} {
      return {}
    }
    set result {}
    helpdoc eval {select name,entryid as fieldid from entry where parent=:entryid and class='field' order by name} {
      dict set result $name [helpdoc node_get $fieldid]
    }
    return $result
  }

  ###
  # topic: a601c2ea-28ad-4dc6-40b6-b6be22cd590e
  ###
  method schema_get table {
    set dentry [my property docentry]
    if {![::helpdoc node_exists [list schema $dentry sqltable $table] entryid]} {
      return {}
    }
    set info [::helpdoc node_get $entryid]
    dict set info fields [my schema_fields $table]
    return $info
  }

  ###
  # topic: ba74ec88-9d25-c62c-fcd0-a50d61c36a99
  ###
  method schema_sql {} {
    set result {}
    foreach table [my schema_tablelist] {
      set info [my schema_get $table]
      append result "-- BEGIN $table" \n
      append result [dict get $info create_sql] \n
      append result "-- END $table" \n
    }
    return $result
  }

  ###
  # topic: f8feb545-51d7-1c81-3ed8-1fb468cb0f6a
  ###
  method schema_tablelist {} {
    set dentry [my property docentry]
    if {![::helpdoc node_exists [list schema $dentry] did]} {
      return {}
    }
    return [helpdoc eval {select name from entry where parent=:did order by name}]
  }
}

Added odie/ootools.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
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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
package require TclOO

::namespace eval ::classDefine {}

::namespace eval ::odie {}

::namespace eval ::viewobj {}


###
# topic: 14474616-1674-47d6-673c-5059adc6bbb0
###
proc ::classDefine::class_method {name arglist body} {  
  method $name $arglist $body
  dict set ::class_property([peek]) class_methods $name [list arglist $arglist body $body]
}

proc ::classDefine::component args {
  
}

proc ::classDefine::delegate {keyword object args} {
  switch $keyword {
    method {}
    option {}
    typemethod -
    class_method {} 
  }
}

###
# topic: 0bde8c29-3e7d-a6b5-193b-a3c856f0ed0a
# title: Define an ensemble method for this agent
###
::proc ::classDefine::ensemble {ensemble ebody} {
  set class [peek]
  foreach {method body} $ebody {
    dict set ::class_ensemble($class) $ensemble:$method $body
  }
}

###
# topic: e4bf9a80-4e2e-49c9-5547-a1d17af9dfcc
# title: Define an ensemble method for this agent
###
::proc ::classDefine::ensemble_method {ensemble method body} {
  set class [peek]
  dict set ::class_ensemble($class) $ensemble:$method $body
}

###
# topic: 13591268-7a5e-0459-1d8a-467d4875b753
# title: Define an ensemble method for this agent
###
::proc ::classDefine::method {rawmethod args} {
  set class [peek]
  if {[string first : $rawmethod] < 0} {
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  dict set ::class_ensemble($class) $rawmethod [lindex $args end]
}

proc ::classDefine::option {name args} {
  ::global class_property
  set class [peek]
  dict set class_property($class) [string trimleft $name -] [list option $args]
}

###
# topic: b6fb7bbf-f61b-cecb-d5a6-608bd3c59db9
###
proc ::classDefine::peek args {
  if {[llength $args] == 2} {
    upvar 1 [lindex $args 0] class
  }
  ::variable classStack
  set class   [lindex $classStack end]
  return ${class}
}

###
# topic: 0e4e2742-3217-5838-bd78-43374d6daf13
###
proc ::classDefine::pop {} {
  ::variable classStack
  set class      [lindex $classStack end]
  set classStack [lrange $classStack 0 end-1]
  return $class
}

###
# topic: 0968eef3-84f2-c6db-1d59-0abcd79680d4
# title: Define the properties for this agent
###
proc ::classDefine::properties info {
  ::global class_property
  set class [peek]
  foreach {var val} $info {
    dict set class_property($class) $var [list const $val]
  }
}

###
# topic: 8316d501-0155-f0e9-2d71-fb1d13f38b09
# title: Define the properties for this agent
###
proc ::classDefine::property {property type {value {}}} {
  ::global class_property
  set class [peek]
  if { $value eq {} } {
    dict set class_property($class) $property [list const $type]
    return
  }
  switch $type {
    {} - eval {
      dict set class_property($class) $property [list eval $value]
    }
    option {
      dict set class_property($class) $property [list option $value]      
    }
    subst {
      dict set class_property($class) $property [list subst $value]
    }
    const {
      dict set class_property($class) $property [list const $value]      
    }
  }
}

###
# topic: b89c6b36-37ef-4c22-8ee5-26a4b1723bba
# description:
#    Here is the guts of our machine
#    In a seperate namespace so a developer can't accidentally
#    overwrite an important function
###
proc ::classDefine::push type {
  ::variable classStack
  lappend classStack $type
}

###
# topic: e710754b-3fe2-f0f1-fd52-58e24bc0e5dc
# title: Closes all floating windows
###
proc ::closeAllWindows {} {
  namespace delete ::viewobj
  namespace eval ::viewobj {}
}

###
# topic: 9242436a-9453-4827-14ee-766ed8ae9b20
###
proc ::odie::class {name body} {
  set class ::[string trimleft $name :]
  logicset add ::odie::class_list $class
  if { [::info command $class] == {} } {
    oo::class create $class
  }
  ::classDefine::push $class
  namespace eval ::classDefine $body
  ::classDefine::pop
  ::odie::class_properties $class
}

###
# topic: 80b8b5f1-ec02-3ee6-cd3e-34be71d2ffa4
###
proc ::odie::class_ancestors {class {stackvar {}}} {
  if { $stackvar ne {} } {
    upvar 1 $stackvar stack
  } else {
    set stack {}
  }
  if { $class in $stack } {
    return {}
  }
  stack push stack $class
  if {![catch {::info class superclasses $class} ancestors]} {
    foreach ancestor $ancestors {
      class_ancestors $ancestor stack
    }
  }
  if {![catch {::info class mixins $class} ancestors]} {
    foreach ancestor $ancestors {
      class_ancestors $ancestor stack
    }
  }
  return $stack
}

###
# topic: 1c1ea49e-6292-f4e3-e530-9f8af9374810
###
proc ::odie::class_build_ensembles class {
  set info {}
  set ancestors [::odie::class_ancestors $class]
  foreach ancestor $ancestors {
    foreach {path body} [get ::class_ensemble($ancestor)] {
      set ensemble [lindex [split $path :] 0]
      set method   [join [lrange [split $path :] 1 end] :]
      if {![dict exists $info $ensemble $method]} {
        dict set info $ensemble $method $body
      }
    }
  }
  return $info
}

###
# topic: 5fa9aec3-7717-5ab6-413d-0e24ec6f008e
###
proc ::odie::class_build_properties class {
  set info {}
  set ancestors [::odie::class_ancestors $class]
  foreach ancestor $ancestors {
    foreach {var val} [get ::class_property($ancestor)] {
      if {![dict exists $info $var]} {
        dict set info $var $val
      }
    }
  }
  dict set info class [list const $class]
  dict set info ancestors [list const $ancestors]
  return $info
}

###
# topic: 6d31677b-47b0-d566-8d91-a86902573335
# description: Return a list of IRM classes
###
proc ::odie::class_choices {} {
  return [lsort -dictionary -unique $::odie::class_list]
}

###
# topic: 9364ad08-92de-9b3d-df4f-48cc4b31e711
###
proc ::odie::class_properties class {
  foreach {ensemble einfo} [class_build_ensembles $class] {
    set eswitch {}
    foreach {method} [lsort -dictionary [dict keys $einfo]] {
      append eswitch [list $method [dict get $einfo $method]] \n
    }
    if {![dict exists $eswitch default]} {
      set msg "error \"unknown method \[subst \$method\]. Valid: [dict keys $eswitch]\""
      append eswitch [list default $msg] \n
    }
    set body {
if {[llength $args] > 1} {
  set dictargs $args
} else {
  set dictargs [lindex $args 0]
}
  }
    append body \n "set code \[catch {switch \$method [list $eswitch]} result opts\]"
    
    #if { $ensemble == "action" } {
    #  append body \n {  if {$code == 0} { my event generate event $method {*}$dictargs}}
    #}
    append body \n {return -options $opts $result}
    oo::define $class method $ensemble {method args} $body
  }
  ###
  # Apply properties
  ###
  set info [class_build_properties $class]
  set body "my variable options
switch \$field \{"
  append body \n " [list list [list return [lsort -dictionary [dict keys $info]]]]"
  set optiondict {}
  foreach {var val} $info {
    if { $var eq "class_methods" } {
      append body \n " [list $var [dict keys $val]]"
    }
    switch [lindex $val 0] {
      eval {
        append body \n " [list $var [lindex $val 1]]"
      }
      subst {
        append body \n " [list $var [list return [subst [lindex $val 1]]]]"
      }
      const {
        append body \n " [list $var [list return [lindex $val 1]]]"        
      }
      option {
        dict set optiondict $var [lindex $val 1]
        append body \n " [list $var [list return [lindex $val 1]]]"
      }
      default {
        append body \n " [list $var [list return $val]]"
      }
    }
  }
  ###
  # Build options
  ###
  append body \n "  [list options [list return $optiondict]]"
  append body \n "\}"
  append body \n {return [my get $field]}
  oo::define $class method info field $body
  oo::define $class method property field $body

  set cmethods {}
  foreach {method methodinfo} [dictGet $info class_methods] {
    dict with methodinfo {
      logicset add cmethods $method
      ::oo::objdefine $class method $method [get arglist] [get body]
    }
  }
  foreach anc [class_ancestors $class] {
    set ainfo [class_build_properties $anc]

    foreach {method methodinfo} [dictGet $ainfo class_methods] {
      if {$method in $cmethods} continue
      dict with methodinfo {
        logicset add cmethods $method
        ::oo::objdefine $class method $method [get arglist] [get body]
      }
    }
  }
}

proc ::odie::macro {name arglist body} {
  proc ::classDefine::$name $arglist $body
}

###
# topic: bcb549b7-ddbc-16e1-aafe-14cf30ed039a
# description: Work space for the IRM class parser
###
namespace eval ::classDefine {
foreach keyword {
    constructor deletemethod destructor export filter forward  renamemethod
    self superclass unexport unknown variable
  } {
    proc $keyword args "::oo::define \[peek\] $keyword {*}\$args"
  }
  namespace export *
}

###
# topic: ffd7dfab-3eb2-649f-4f78-349603275682
###
namespace eval ::odie {
  namespace export *
}

Added odie/queue.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
###
# queue.tcl
#
# This file defines the method needed for the tcl inplementation
# of queues
#
# Copyright (c) 2012 Sean Woods
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
###

::namespace eval ::queue {}

###
# topic: faf2fff4-8cce-65a9-1aa9-aebbd88abb93
# type: ensemble_method
###
ensemble_method ::queue::add {queuevar value} {
  upvar 1 $queuevar queue
  lappend queue $value
}

###
# topic: efe3829e-7435-57ee-356a-2e454a035da1
# type: ensemble_method
###
ensemble_method ::queue::head_insert {queuevar value} {
  upvar 1 $queuevar queue
  set queue [linsert $queue 0 $value]
}

###
# topic: 19078eef-4bc4-b494-9b90-eabf7e88ac1d
# type: ensemble_method
###
ensemble_method ::queue::next {queuevar resultvar} {
  upvar 1 $queuevar queue 
  upvar 1 $resultvar result
  if { [set len [llength $queue]] == 0 } { 
       set result {}
       return 0
  }
  set result [lindex $queue 0]
  if { $len == 1 } { 
       set queue {}
  } else {
    set queue [lrange $queue 1 end]
  }
  return 1 
}

ensemble_build ::queue

Added odie/stack.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
###
# queue.tcl
#
# This file defines the method needed for the tcl inplementation
# of stacks
#
# Copyright (c) 2012 Sean Woods
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
###

::namespace eval ::stack {}

###
# topic: 31fdcfe6-70eb-f454-2963-201fa6d15d70
# type: ensemble_method
###
ensemble_method ::stack::head_insert {stackvar value} {
  upvar 1 $stackvar stack
  set stack [linsert $stack 0 $value]
}

###
# topic: dc304faa-b514-d4ba-c7a5-f14287c4a710
# type: ensemble_method
###
ensemble_method ::stack::peek stackvar {
  upvar 1 $stackvar stack
  if {[info exists stack]} {
    return [lindex $stack end]
  }
  return {}
}

###
# topic: 79827956-1a8b-edda-397c-f9d076b9d8a9
# type: ensemble_method
###
ensemble_method ::stack::pop {stackvar resultvar} {
  upvar 1 $stackvar stack 
  upvar 1 $resultvar result
  if { [set len [llength $stack]] == 0 } { 
       set result {}
       return 0
  }
  set result [lindex $stack end]
  if { $len == 1 } { 
       set stack {}
  } else {
    set stack [lrange $stack 0 end-1]
  }
  return 1 
}

###
# topic: de540806-071f-5e11-d270-34e040a4b46c
# type: ensemble_method
###
ensemble_method ::stack::push {stackvar args} {
  upvar 1 $stackvar stack
  lappend stack {*}$args
}

ensemble_build ::stack

Added odie/yggdrasil.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
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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
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
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
###
# Structure that manages an interactive help system
###
package provide ::odie::helpdoc 0.1

###
# topic: 57343680-c66e-0427-ac2c-217bff50a365
###
odie::class odie.yggdrasil {
  superclass moac.sqliteDb
  property create_sql {
    create table if not exists entry (
      entryid string default (uuid_generate()),
      indexed integer default 0,
      parent integer references entry (entryid),
      class string,
      name string,
      mtime integer,
      primary key (entryid)
    );
    create table if not exists property (
      entryid    string references entry (entryid),
      field      string,
      value      string,
      primary key (entryid,field)
    );
    create table if not exists link (
      linktype string,
      entry integer references entry (entryid),
      refentry integer references entry (entryid)
    );
    create table if not exists idset (
      class string,
      id    integer,
      name  string,
      primary key (class,id)
    );
    create table if not exists aliases (
      class string,
      alias string,
      cname string references entry (name),
      primary key (class,alias)
    );
    create table if not exists repository (
      handle string,
      localpath string,
      primary key (handle)
    );
    create table if not exists file (
      fileid         string default (uuid_generate()),
      repo           string references repository (handle),
      path           string,  --path relative to repo
      localpath      string,  --cached path to local file
      filename       string,  --filename
      content_type   string,  --Content/Type of file
      package        string,  --Name of any packages provided,
      size           integer, --File size in bytes
      mtime          integer, --mtime in unix time
      hash           string,   --md5 hash of file
      primary key (fileid)
    );
    create table if not exists filelink (
      linktype string,
      entryid integer references entry (entryid),
      fileid integer references file   (fileid)
    )
  }
  property create_index_sql {
    create index if not exists nameidx on entry (entryid,name);
    create index if not exists parentidx on entry (parent,entryid);
  }
  constructor filename {
    package require sqlite3
    my variable tcllib_md5

    if {[info command ::md5] eq {} } {
      set tcllib_md5 1
      package require md5
    } else {
      set tcllib_md5 0
    }

    catch {rename [self].db [self].db.old}
    if [catch {
      my attach db $filename
      ###
      # Allow up to 2 seconds of
      # slack time for another process to
      # write to the database
      ###
      my db timeout 2000
  
      my put [list filename $filename]
      my put [list initdir [file dir $filename]]
    }] {
      puts "Falling back to temporary storage"
      my attach db {}
      my put [list filename {}]
      my put [list initdir ~]
    }
    
    catch {rename [self].db.old {}}
    return 0
  }

  ###
  # topic: bf756514-f69b-697b-eb91-22dd9b9bf699
  ###
  method alias_list class {
    return [my db eval {select alias,cname from aliases where class=:class order by cname,alias}]
  }

  ###
  # topic: bd5398c9-a66d-c9f4-e692-4eb220fec800
  ###
  method canonical {class name} {
    set name [string tolower $name]
    if { $class in {{} * any}} {
      return [my db eval {select distinct class from aliases order by class}]
    }
    if { $name in {{} * any}} {
      return [my db eval {select alias,cname from aliases where class=:class order by cname,alias}]
    }
    set rows [my db eval {select entryid from entry where class=:class and name=:name}]
    if {[llength $rows] == 1} {
      return $name
    }
    if {[my db exists {select cname from aliases where class=:class and (alias=:name or cname=:name)}]} {
      return [my db one {select cname from aliases where class=:class and (alias=:name or cname=:name) limit 1}]
    }
  }

  ###
  # topic: 093a6db9-b548-c37f-eb65-8c6f4d465dcd
  ###
  method canonical_aliases {class name} {
    set name [string tolower $name]
    return [my db eval {select distinct alias from aliases where class=:class and cname=:name and alias!=:name}]
  }

  ###
  # topic: d6ac748e-6dff-ce69-fbd6-6cea74252a02
  ###
  method canonical_id {class name} {
    return [my db eval {select id from idset where class=:class and name=:name}]
  }

  ###
  # topic: 7150f504-e786-fa88-0bfa-7771b344c442
  ###
  method canonical_set {type name cname} {
    set class [string tolower $type]
    set name [string tolower $name]
    set cname [string tolower $cname] 
    variable canonical_name
    dict set canonical_name $class $name $cname
    set address $type/$name
    my db eval {replace into aliases (class,alias,cname) VALUES ($class,$name,$cname)}
  }

  ###
  # topic: c4c5d5bf-0980-7644-9f1f-8b8ac2a42f4c
  ###
  method class_list class {
    return [lsort -dictionary [my db eval {select name from entry where class=:class}]]
  }

  ###
  # topic: c521688b-4ca8-9bf0-d46e-a724c1b7ae4f
  ###
  method class_nodes class {
    set result {}
    foreach {entryid name} [my db eval {select entryid,name from entry where class=:class order by name}] {
      lappend result $name [my node_properties $entryid]
    }
    return $result
  }

  ###
  # topic: 10518da5-9ca8-ea62-c047-6ed05a6dbc96
  ###
  method database_create alias {
    my $alias eval [my property create_sql]
  }

  ###
  # topic: 5adf83a8-668b-157b-e6fa-72716a3998de
  ###
  method database_functions alias {
    package require uuid
    $alias function uuid_generate [list [self] uuid_generate]
  }

  ###
  # topic: 4c04478b-06d5-9bd5-8ae1-a6df2170d2e9
  ###
  method enum_dump class {
    return [my eval {select id,name from idset where class=:class order by id}]
  }

  ###
  # topic: a1250c93-e5cd-53c1-93df-d7832c47357c
  ###
  method enum_id {class name} {
    set arr ::irm::${class}_name_to_idx
    if {![info exists $arr]} {
      my db eval {select name as aname,id as aid from idset where class=:class} {
        set ${arr}($aname) $aid
      }
    }
    set cname [my canonical $class $name]
    if {![info exists ${arr}($cname)]} {
      error "Invalid $class $name"
    }
    return [set ${arr}($cname)]
  }

  ###
  # topic: ded135de-4cb9-003c-7bb4-70b7943052b1
  ###
  method enum_name {class id} {
    return [my db one {select name from idset where class=:class and id=:id}]
  }

  ###
  # topic: 76cfb43e-2bfd-986c-3316-d3706061dba6
  ###
  method enum_set {class name id} {
    set class [string tolower $class]
    set name [string tolower $name]
    set ::irm::${class}_name_to_idx($name) $id
    set ::irm::${class}_idx_to_name($id) $name
    my db eval {insert or replace into idset (class,id,name) VALUES ($class,$id,$name)}
  }

  ###
  # topic: 1c6106a6-8bf6-9dcc-021d-b31cbb561d4d
  ###
  method file_hash {fileid {newhash {}}} {
    set fileid [my file_id $fileid]
    if {$fileid ne {}} {
      return [my db one {select hash from file where fileid=:fileid}]
    }
    return {}
  }

  ###
  # topic: 9a2b2f20-ada2-155c-8a72-5917435ac127
  ###
  method file_id {addr {create 0}} {
    if {[string is integer $addr]} {
      return $addr
    }
    if {[my db exists {select fileid from file where hash=:addr}]} {
      return [my db one {select fileid from file where hash=:addr}]
    }
    if {[llength $addr]==2} {
      set repo [lindex $addr 0]
      set path [lindex $addr 1]
      if {[my db exists {select fileid from file where repo=:repo and path=:path}]} {
        return [my db one {select fileid from file where repo=:repo and path=:path}]
      }
    }
    if {[my db exists {select fileid from file where path=:addr}]} {
      return [my db one {select fileid from file where path=:addr}]
    }
    if {[my db exists {select fileid from file where localpath=:addr}]} {
      return [my db one {select fileid from file where localpath=:addr}]
    }
    return {}
  }

  ###
  # topic: 78c6fca8-3198-1b80-cc69-3b3ed59334b0
  ###
  method file_restore {nodeid info} {
    set stmtl {}
    dict with info {}
    if {[string is integer $nodeid]} {
      set _fileid $nodeid
    } else {
      set _fileid [my file_id $nodeid]
      if {$_fileid eq {}} {
        set _fileid {}
      }
    }
    if {$_fileid ne {}} {
      set fields fileid
      set values "\$_fileid"
    } else {
      set fields {}
      set values {}
    }
    foreach {field value} $info {
      switch $field {
        repo -
        path -
        localpath -
        filename -
        content_type -
        package -
        size -
        mtime -
        hash {
          if { $value ne {} } {
            lappend fields $field
            lappend values :_$field
            set _$field $value
          }
        }
      }
    }
    my db eval "insert or replace into file ([join $fields ,]) VALUES ([join $values ,]);"
  }

  ###
  # topic: 2d990f66-5ca7-6ad2-e5ef-05e364399b49
  ###
  method file_serialize nodeid {
    set result {}
    my db eval {
      select * from file
      where fileid=$nodeid
    } record {
      set fileid $record(fileid)
      append result "[list [self] file_restore [list $record(repo) $record(path)]] \{" \n
      
      foreach {field value} [array get record] {
        if { $field in {* fileid indexed export} } continue
        append result "  [list $field $value]" \n
      }
      append result "\}"
    }
    return $result
  }

  ###
  # topic: 2514ca1a-6e9c-1af1-275c-1ea253706daa
  ###
  method link_create {entryid to {type {}}} {
    if { $type eq {} } {
      set exists [my one {select count(entry) from link where entry=$entryid and refentry=$to}]
      if {!$exists} {
        my db eval {insert or replace into link (entry,refentry) VALUES ($entryid,$to)}
      }
    } else {
      set exists [my one {select count(entry) from link where entry=$entryid and refentry=$to and linktype=$type}]
      if {!$exists} {
        my db eval {insert or replace into link (entry,refentry,linktype) VALUES ($entryid,$to,$type)}
      } 
    }
  }

  ###
  # topic: f9685bcf-fb03-9e78-3938-4898c01a59c5
  ###
  method link_detect_address args {
    if {[my node_exists $args entryid]} {
      return [my eval {select entryid from entry where entryid=$entryid}]
    }
    ###
    # If the link contains a / we know it is a hard
    # path
    ###
    if {[my node_exists $args entryid]} {
      return $entryid
    }
    if {[llength $args] > 1} {
      set rootentries [my eval {select name from entry where class='section'}]
      
      if {[lindex $args 0] in $rootentries} {
        set type [lindex $args 0]
        set name [my canonical $type [lindex $args 1]]
        if {[my node_exists [list $type $name] entryid]} {
          return $entryid
        }
      }
      if {[lindex $args 1] in $rootentries} {
        set type [lindex $args 1]
        set name [my canonical $type [lindex $args 0]]
        if {[my node_exists [list $type $name] entryid]} {
          return $entryid
        }
      }
    }
    set addr [lindex $args 0]
    set cnames [my eval {select class,cname from aliases where alias=$addr}]
  
    if {[llength $cnames] == 2} {
      if {[my node_exists $cnames entryid]} {
        return $entryid
      }
    }
    #if {[string first / $addr] > 0 } {
    #  return $addr
    #}
    set candidates [my eval {select entryid,name from entry where name like '%$addr%'}]
    foreach address $candidates {
      if {[regexp simnode $address]} {
        return $address
      }
    }
    #puts [list CAN'T RESOLVE $args]
    return $args
  }

  ###
  # topic: 612a2335-0b20-ae08-c159-97a025d11390
  ###
  method node_alloc_child {parent entry {class {}}} {
    if { $parent eq $class } {
      set row [my one {select entryid from entry where parent is null and class=$class and name=$entry}]
    } elseif { $class ne {} } {
      set row [my one {select entryid from entry where parent=$parent and class=$class and name=$entry}]    
    } else {
      set row [my one {select entryid from entry where parent=$parent and name=$entry}]    
    }
    if { [llength $row] && $row != $parent } {
      return $row
    }
    set row [my uuid_generate $parent $class $entry]
    if { $class eq $parent } {
      set row $parent/$entry
      my db eval {insert into entry (entryid,class,name) VALUES ($row,$parent,$entry)}
    } elseif { $class ne {} } {
      my db eval {insert into entry (entryid,parent,class,name) VALUES ($row,$parent,$class,$entry)}
    } else {
      my db eval {insert into entry (entryid,parent,name) VALUES ($row,$parent,$entry)}
    }
    return $row
  }

  ###
  # topic: 522463d0-c361-0c5e-1e00-06469359750b
  # description:
  #    Return a list of all children of node,
  #    Filter is a key/value list that understands
  #    the following:
  #    type - Limit children to type
  #    dump - Output the contents of the child node, not their id
  ###
  method node_children {nodeid class} {
    set dump 1
    set entryid [my node_id $nodeid]
    if { $class eq {} } {
      set nodes [my eval {select name,entryid from entry where parent=$entryid}]
    } else {
      set nodes [my eval {select name,entryid from entry where parent=$entryid and class=$class}]
    }
    if {!$dump} {
      return $nodes
    }
    set result {}
    foreach {cname cid} $nodes {
      dict set result $cname [my eval {select field,value from property where entryid=$cid order by field}]
    }
    return $result
  }

  ###
  # topic: b4954836-f396-6f2c-92cc-4c8251572bd8
  ###
  method node_define {class name info {nodeidvar {}}} {
    if {$nodeidvar ne {}} {
      upvar 1 $nodeidvar nodeid
    }
    
    if { $class eq {} || $class eq "section" } {
      set nodeid $name
    } else {
      set nodeid {}
      if {[dict exists $info topic]} {
        set nodeid [dict get $info topic]
        dict unset info topic
      }
    }    
    if { $nodeid eq {} } {
      if {![my node_exists [list $class $name] nodeid]} {
        set nodeid [helpdoc node_id [list $class $name] 1]
        foreach {var val} [my node_empty $class] {
          my node_property_set $nodeid $var $val        
        }
      }
    } elseif {![my node_exists $nodeid]} {
      my canonical_set $class $name $name
      my eval {insert into entry (entryid,class,name) VALUES (:nodeid,:class,:name)}
      foreach {var val} [my node_empty $class] {
        my node_property_set $nodeid $var $val        
      }
    }
  
    foreach {var val} $info {
      my node_property_set $nodeid $var $val
    }
  }

  ###
  # topic: 07210b77-287a-e0a4-b5e5-d877a5aadb15
  ###
  method node_define_child {parent class name info {nodeidvar {}}} {
    if {$nodeidvar ne {}} {
      upvar 1 $nodeidvar nodeid
    }
    ###
    # Return an already registered node with this address
    ###
    if {[my db exists {select entryid from entry where parent=:parent and class=:class and name=:name}]} {
      set nodeid [my db one {select entryid from entry where parent=:parent and class=:class and name=:name}]
    } else {
      set nodeid {}
  
      if {[dict exists $info topic]} {
        set topicid [dict get $info topic]
        dict unset info topic
        if {![my db exists {select entryid from entry where entryid=:topicid}]} {
          # If we are recycling an unused UUID re-create the entry in the table
          my eval {insert into entry (entryid,parent,class,name) VALUES (:topicid,:parent,:class,:name)}
          set nodeid $topicid
        }
      }
      if { $nodeid eq {} } {
        set nodeid [my uuid_generate $parent $class $name]
      }
      if {[my db exists {select entryid from entry where entryid=:nodeid and class=:class and name=:name}]} {
        ###
        # Correct a misfiled node
        ###
        my db eval {update entry set parent=:parent where entryid=:nodeid}
      } else {
        my eval {insert into entry (entryid,parent,class,name) VALUES (:nodeid,:parent,:class,:name)}
      }
      foreach {var val} [my node_empty $class] {
        if {![dict exists $info $var]} {
          dict set info $var $val
        }
      }
    }
    foreach {var val} $info {
      my node_property_set $nodeid $var $val        
    }
    return $nodeid
  }

  ###
  # topic: ea04bf60-c884-5477-a841-87bb3d571e16
  ###
  method node_empty class {
    set id [my db one {select entryid from entry where name=:class and class='section'}]
    return [my db one {select value from property where entryid=:id and field='template'}]
  }

  ###
  # topic: c7b902b4-c9de-98dc-8230-c099b75a2067
  ###
  method node_exists {node {resultvar {}}} {
    set parent 0
    if { $resultvar != {} } {
      upvar 1 $resultvar row
    }
    if {[llength $node]==1} {
      set name [lindex $node 0]
      if {[my db exists {select entryid from entry where name=:name or entryid=:name}]} {
        set row [my db one {select entryid from entry where name=:name or entryid=:name}]
        return 1
      }
    } elseif {[llength $node]==2} {
      set class [lindex $node 0]
      set name [lindex $node 1]
      if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
        set row [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
        return 1
      }
    }
    set class [lindex $node 0]
    set name [lindex $node 1]
    if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
      set parent [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
    } else {
      return 0
    }
    foreach {eclass ename} [lrange $node 2 end] {
      set row {}
      if {$eclass eq {}} {
        if {[my db exists {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]} {
          set row [my db one {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]
        }
      } else {
        if {[my db exists {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]} {
          set row [my db one {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]
        }
      }
      if { $row eq {} } {
        return 0
      }
      set parent $row
    }
    return 1
  }

  ###
  # topic: 7f77641d-fbdf-50bc-acfe-1513f2d0a267
  ###
  method node_get {nodeid {field {}}} {
    set result {}
    if {[my node_exists $nodeid entryid]} {
      set result [helpdoc node_properties $entryid]
    } else {
      if {[llength $nodeid] > 1} {
        set type [lindex $nodeid 0]
        set result [my node_empty $type]
      }
    }
    if { $field eq {} } {
      return $result    
    }
    return [dictGet $result $field]
  }

  ###
  # topic: b2ab54e8-34d9-7dbe-cfa9-21066fc20d4e
  ###
  method node_id {node {create 0}} {
    if {[my db exists {select entryid from entry where entryid=:node;}]} {
      return [my db one {select entryid from entry where entryid=:node;}]
    }
    if {[llength $node]==1} {
      set name [lindex $node 0]
      if {[my db exists {select entryid from entry where name=:name or entryid=:name}]} {
        return [my db one {select entryid from entry where name=:name or entryid=:name}]
      }
      if { $create } {
        my db eval {insert into entry (class,name) VALUES ('section',:name)}
        return $name
      } else {
        error "Node $node does not exist"
      }
    } elseif {[llength $node]==2} {
      set class [lindex $node 0]
      set name [lindex $node 1]

      if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
        set row [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
        return $row
      }
    }
    set class [lindex $node 0]
    set name [lindex $node 1]
    if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
      set parent [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
    } else {
      if {!$create} {
        error "Node $node does not exist"
      }

      ###
      # If the name contains no spaces, dots, slashes, or ::
      ###
      set row [my uuid_generate $class $name]
      my db eval {insert into entry (entryid,class,name) VALUES (:row,:class,:name)}
      set parent $row
    }
    if { $create } {
      set classes [my db eval {select distinct class from entry}]
    }
    set eclass {}
    foreach token [lrange $node 2 end] {
      set ename $token
      set row {}
      if {$eclass eq {}} {
        if {[my db exists {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]} {
          set row [my db one {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]
        }
      } else {
        if {[my db exists {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]} {
          set row [my db one {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]
        }
      }
      if { $row eq {} } {
        if { $create } {
          if { $ename in $classes } {
            set eclass $token
            continue            
          } else {
            set eclass {}
            set row [my node_alloc_child $parent $ename $eclass]
          }          
        } else {
          error "Node $node does not exist"
        }
      }
      set parent $row
    }
    return $row
  }

  ###
  # topic: eb137c42-eacd-7016-7a91-7056ba96ed70
  ###
  method node_properties entryid {
    return [my eval {select field,value from property where entryid=$entryid}]
  }

  ###
  # topic: 8d72229b-f33b-acd0-cd41-b4584fa240eb
  ###
  method node_property_append {nodeid field text} {
    set buffer [my one {select value from property where entryid=:nodeid and field=:field}]
    append buffer " " [string trim $text]
    my db eval {insert or replace into property (entryid,field,value) VALUES (:nodeid,:field,:buffer)}
  }

  ###
  # topic: e1a3da3c-7005-1c92-0aed-5bde26228ee1
  ###
  method node_property_get {nodeid field} {
    return [my db one {select value from property where entryid=:nodeid and field=:field}]
  }

  ###
  # topic: c4e91fb2-44d0-aee6-8454-1effc7012081
  # description: nodeid is any value acceptable to {[my node_alloc]}
  ###
  method node_property_lappend {entryid field args} {
    if {![llength $args]} return
    set dbvalue [my eval {select value from property where entryid=$entryid and field=$field}]
    foreach value $args {
      if { $value eq {} } continue
      logicset add dbvalue $value
    }
    my db eval {update property set value=$dbvalue where entryid=$entryid and field=$field}
  }

  ###
  # topic: 89d208ff-7b88-3985-1167-8c025f82d4d6
  ###
  method node_property_set {entryid args} {
    my variable property_info property_cname
    if {[llength $args]==1} {
      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {field value} $arglist {
      if {[info exists property_cname($field)]} {
        set cname $property_cname($field)
        set rawvalue $value
        eval [dictGet $property_info $cname script]
      } else {
        set cname $field
      }
      if {![my db exists {select value from property where entryid=:entryid and field=:cname and value=:value}]} {
        my db eval {insert or replace into property (entryid,field,value) VALUES (:entryid,:cname,:value)}
      }
    }
  }

  ###
  # topic: f7de1b2d-7c51-6c15-abfa-5a2a2f4d4b22
  ###
  method node_restore {nodeid info} {
    set stmtl {}
    dict with info {}
    set fields entryid
    set _entryid $nodeid
    set values "\$_entryid"
    
    foreach {field value} $info {
      switch $field {
        properties {
          foreach {var val} $value {
            my node_property_set $_entryid $var $val
          }
        }
        references {
          foreach {refid reftype} $references {
            my link_create $_entryid $refid $reftype
          }
        }
        enumid {
          my enum_set [lindex $value 0] [dict get $info name] [lindex $value 1]
        }
        aliases {
          foreach a $value {
            my canonical_set $_class $a $_name
          }
        }
        parent {
          if {![string is integer $value]} {
            set value [my node_id $value 1]
          }
          lappend fields $field
          lappend values "\$_$field"
          set _$field $value            
        }
        class -
        address -
        name {
          if { $value ne {} } {
            lappend fields $field
            lappend values "\$_$field"
            set _$field $value
          }
        }
      }
    }
    my db eval "insert or replace into entry ([join $fields ,]) VALUES ([join $values ,]);"
  }

  ###
  # topic: 478123c9-d7df-a4ed-e50f-4b6ae0778ae0
  ###
  method node_serialize nodeid {
    set result {}
    my db eval {
      select * from entry
      where entryid=$nodeid
    } record {
      set entryid $record(entryid)
      append result "[list [self] node_restore $entryid] \{" \n
      
      foreach {field value} [array get record] {
        if { $field in {* entryid indexed export} } continue
        append result "  [list $field $value]" \n
      }
      set class $record(class)
  
      set id [my canonical_id $class $record(name)]
      if { $id ne {} } {
          append result "  [list enumid [list $class $id]]" \n
      }
      
      append result "  properties \{" \n
      set info [my node_empty $record(class)]
      foreach {var val} [my node_properties $entryid] {
        dict set info $var $val
      }

      foreach {var} [lsort -dictionary [dict keys $info]] {
        if { $var in {aliases field method fields methods references id} } continue
        append result "    [list $var [string trim [dict get $info $var]]]" \n
      }
      
      append result "  \}" \n
      set references [my db eval {select refentry,linktype from link where entry=$entryid}]
      if {[llength $references]} {
        append result "  [list references $references]" \n
      }
      set aliases [my canonical_aliases $record(class) $record(name)]
      if {[llength $aliases]} {
        append result "  [list aliases $aliases]" \n
      }
      set attachments [my db eval {select file.hash,filelink.linktype from file,filelink where filelink.entryid=$entryid and filelink.fileid=file.fileid}]
      if {[llength $attachments]} {
        append result "  [list attachments $attachments]" \n
      }
      append result "\}"
    }
    return $result
  }

  ###
  # topic: e2cc4f04-58df-6611-55d2-1e0861a67299
  ###
  method property_define {property info} {
    my variable property_info property_cname
    foreach {f v} $info {
      dict set property_info $property $f $v
    }
    foreach alias [dictGet $property_info $property aliases] {
      set property_cname($alias) $property
    }
    set property_cname($property) $property
  }

  ###
  # topic: 540bbeb4-3def-889d-5c48-72bebf9ace6a
  ###
  method reindex {} {
    my variable canonical_name
    my db eval {select class,alias,cname from aliases order by class,cname,alias} {
      dict set canonical_name $class $alias $cname
    }
  }

  ###
  # topic: 0301bbb1-0f67-8314-b81d-f4a3d30b3123
  ###
  method repository_restore {handle info} {
    set stmtl {}
    dict with info {}
    set fields handle
    set _handle $handle
    set values "\$_handle"
    foreach {field value} $info {
      switch $field {
        localpath {
          if { $value ne {} } {
            lappend fields $field
            lappend values "\$_$field"
            set _$field $value
          }
        }
      }
    }
    my db eval "insert or replace into repository ([join $fields ,]) VALUES ([join $values ,]);"
  }

  ###
  # topic: e89c52fc-d941-f3a3-f2ef-9957ddbb63f2
  # description:
  #    Because the tcllib version of uuid generate requires
  #    network port access (which can be slow), here's a fast
  #    and dirty rendition
  ###
  method uuid_generate args {
    my variable tcllib_md5
    if {![llength $args]} {
      set block [list [info hostname] [get env(USER)] [get env(user)] [clock seconds] [clock microseconds]]
    } else {
      set block $args
    }
    if {$tcllib_md5} {
      set tok [md5::MD5Init]  
      foreach item $block {
        md5::MD5Update $tok $item
      }
      set uuid [md5::MD5Final $tok]
    } else {
      set uuid [md5 [join $block ""]]
    }
    binary scan $uuid H* s
    foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
        append r [string range $s $a $b] -
    }
    return [string tolower [string trimright $r -]]

  }
}

Changes to server.tcl.

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

		#$handler message $sock $msg
		#puts "ws receive $sock $msg"
		set sessionid [dict get $::sock($sock) sessionid]

		set cmd $msg
		if {$::events_on_stdout} {puts "WSCLIENT: $cmd"}
		[dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]
	}
}


proc ws_upgrade {sock data} {
	fileevent $sock readable {}

................................................................................
	if {$isnewsess} {
		set interp [interp create]
		dict set ::session($sessionid) interp $interp
		dict set ::session($sessionid) sock $sock
		dict set ::session($sessionid) wsock 0
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp alias sendto toclient $sessionid
		$interp eval wtk::init sendto
	} else {
		dict set ::session($sessionid) wsock 0
		set interp [dict get $::session($sessionid) interp]
		$interp eval namespace delete ::wtk
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp eval wtk::init sendto
	}

	#update the clients cookie, todo: should do this periodically
	set msgq "(function () { document.cookie= 'wtksess=${sessionid};expires=0;path=/;' })();"
	dict set ::session($sessionid) msgq $msgq

	#pass in the server header vars first
................................................................................
}


# fromclient -- Receive a message from a web client and route it to the correct app instance
#
# This is called when the client wants to send its application instance a message (via
# the /wtkcb.html callback in this case), typically an event like a button press.
# We invoke the 'wtk::fromclient' routine in the instance's interpreter to process it.
proc fromclient {sessionid cmd} {puts "CLIENT: $cmd"; [dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]}


# toclient -- Send Javascript commands from an app instance to the web client
#
# This is called when the application instance wants to send its client a message,
# in the form of a Javascript command.  The message is queued and the actual
# sending is taken care of by the next routine.







|







 







|





|







 







|
|







91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

		#$handler message $sock $msg
		#puts "ws receive $sock $msg"
		set sessionid [dict get $::sock($sock) sessionid]

		set cmd $msg
		if {$::events_on_stdout} {puts "WSCLIENT: $cmd"}
		[dict get $::session($sessionid) interp] eval ::wtk::fromclient [list $cmd]
	}
}


proc ws_upgrade {sock data} {
	fileevent $sock readable {}

................................................................................
	if {$isnewsess} {
		set interp [interp create]
		dict set ::session($sessionid) interp $interp
		dict set ::session($sessionid) sock $sock
		dict set ::session($sessionid) wsock 0
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp alias sendto toclient $sessionid
		$interp eval ::wtk::init sendto
	} else {
		dict set ::session($sessionid) wsock 0
		set interp [dict get $::session($sessionid) interp]
		$interp eval namespace delete ::wtk
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp eval ::wtk::init sendto
	}

	#update the clients cookie, todo: should do this periodically
	set msgq "(function () { document.cookie= 'wtksess=${sessionid};expires=0;path=/;' })();"
	dict set ::session($sessionid) msgq $msgq

	#pass in the server header vars first
................................................................................
}


# fromclient -- Receive a message from a web client and route it to the correct app instance
#
# This is called when the client wants to send its application instance a message (via
# the /wtkcb.html callback in this case), typically an event like a button press.
# We invoke the '::wtk::fromclient' routine in the instance's interpreter to process it.
proc fromclient {sessionid cmd} {puts "CLIENT: $cmd"; [dict get $::session($sessionid) interp] eval ::wtk::fromclient [list $cmd]}


# toclient -- Send Javascript commands from an app instance to the web client
#
# This is called when the application instance wants to send its client a message,
# in the form of a Javascript command.  The message is queued and the actual
# sending is taken care of by the next routine.

Changes to sketch.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
set color black
wtk::grid [wtk::canvas .c -width 400 -height 400 -background #eeeeee] -column 0 -row 0
wtk::bind .c <1> "set x %x; set y %y"
wtk::bind .c <B1-Motion> { 
   .c create line $x $y %x %y -fill $color
   set x %x; set y %y
}

set colors "black blue red green yellow orange brown"
wtk::grid [wtk::canvas .palette -background #cccccc -width 400 -height 30] -column 0 -row 2
set x 25
foreach i $colors {
    .palette bind [.palette create rectangle $x 5 [expr {$x+25}] 25 -fill $i] <1> "set color $i"
    incr x 28
}

|
|
|





|





1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
set color black
::wtk::grid [::wtk::canvas .c -width 400 -height 400 -background #eeeeee] -column 0 -row 0
::wtk::bind .c <1> "set x %x; set y %y"
::wtk::bind .c <B1-Motion> { 
   .c create line $x $y %x %y -fill $color
   set x %x; set y %y
}

set colors "black blue red green yellow orange brown"
::wtk::grid [::wtk::canvas .palette -background #cccccc -width 400 -height 30] -column 0 -row 2
set x 25
foreach i $colors {
    .palette bind [.palette create rectangle $x 5 [expr {$x+25}] 25 -fill $i] <1> "set color $i"
    incr x 28
}

Changes to widgets/button.tcl.

1
2
3

4
5
6
7
8
9

10

11

12




13
14


# Button widgets
snit::type button {
    _wtkwidget -usetextvar

    _wtkoption -src "" {$JS.style.background='url($V)';}
    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}
    _wtkoption -width "" {$JS.style.width=$V;}
    _wtkoption -height "" {$JS.style.height=$V;}
    _wtkoption -radius "" {$JS.style.borderRadius=$V;}

    option -command

    method _createjs {} {return "wtk.createButton('[$self id]','[$self cget -text]');"}

    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}




    method _event {which} {if {$which eq "pressed"} {uplevel #0 $options(-command)}}
}



|
|
>
|
|
|
|
|
|
>
|
>
|
>
|
>
>
>
>
|
|
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# Button widgets
odie::class ::wtk::button {
  superclass wtk::LabelWidget
  
  _wtkoption -src "" {$JS.style.background='url($V)';}
  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  _wtkoption -width "" {$JS.style.width=$V;}
  _wtkoption -height "" {$JS.style.height=$V;}
  _wtkoption -radius "" {$JS.style.borderRadius=$V;}
  
  option -command -default {}
  
  method do_createjs {} {return "wtk.createButton('[my id]','[my cget -text]');"}
  
  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}
  
  method wtk_event {which} {
    if {$which eq "pressed"} {
      variable options
      uplevel #0 $options(-command)
    }
  }
}

Changes to widgets/canvas.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



# Canvas
snit::type canvas {


    typevariable itemtypes "line rectangle"
    typevariable opts.line {-fill strokeStyle -width lineWidth}
    typevariable opts.rectangle {-fill fillStyle -width lineWidth -outline strokeStyle}
    _wtkwidget

    _wtkoption -width 100 {$JS.width=$V;$JS.style.width='${V}px';}
    _wtkoption -height 100 {$JS.height=$V;$JS.style.height='${V}px';}
    _wtkoption -background "#ffffff" {$JS.style.background='$V';}

    variable mousedown 0
    variable nextid 1
    variable items

    method _createjs {} {return "wtk.createCanvas('[$self id]');"}

    method create {itemtype args} {
        if {$itemtype ni $itemtypes} {error "bad item type"}
        lassign [_parseCoordsAndOptions $args [set opts.$itemtype]] coords opts
        set cid $nextid; incr nextid
        set items($cid) [list type $itemtype coords $coords]
        wtk::toclient "wtk.objs\['[$self id]'\].createItem($cid,'$itemtype',\[[join $coords ,]\],$opts);"
        return $cid
    }

    method _event {which args} {; # todo - make generic
        if {$which=="mousedown"} {set mousedown 1; set subs [list %x [lindex $args 0] %y [lindex $args 1]]; $W _fireevent "<1>" $subs; if {[lindex $args 3]!=""} {$self _fireevent [lindex $args 3] "<1>" $subs}}
        if {$which=="mousemove"} {if {$mousedown} {set ev "<B1-Motion>"} else {set ev "<Motion>"}; $W _fireevent $ev [list %x [lindex $args 0] %y [lindex $args 1]]}
        if {$which=="mouseup"} {set mousedown 0; $W _fireevent "<B1-Release>" [list %x [lindex $args 0] %y [lindex $args 1]]}
    }

    proc _parseCoordsAndOptions {s optmap} {
        set coords ""; set inopts 0; set opts ""
        foreach {x y} [split $s] {
            if {!$inopts && [string is integer $x]} {
                if {![string is integer $y]} {error "odd number of coordinates"}
                lappend coords $x $y
            } else {
                set inopts 1
                if {![dict exists $optmap $x]} {error "bad option"}
                lappend opts "[dict get $optmap $x]:\"$y\""
            }
        }
        return [list $coords "\{[join $opts ,]\}"]
    }

    variable bindings

    method bind {id ev script} {set bindings(${id},$ev) $script}



    method _fireevent {id ev subs} {if {[info exists bindings(${id},$ev)]} {uplevel #0 [string map $subs $bindings(${id},$ev)]}}
}





|
>
>
|
|
|
<
>
|
|
|

|
|
|
>
|
>
|
|
|
|
|
|
|
|
>
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
>
|
>
>
>
|
|
|
>
>
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

# Canvas
odie::class ::wtk::canvas {
  superclass wtk::Widget

  property itemtypes "line rectangle"
  property opts.line {-fill strokeStyle -width lineWidth}
  property opts.rectangle {-fill fillStyle -width lineWidth -outline strokeStyle}


  _wtkoption -width 100 {$JS.width=$V;$JS.style.width='${V}px';}
  _wtkoption -height 100 {$JS.height=$V;$JS.style.height='${V}px';}
  _wtkoption -background "#ffffff" {$JS.style.background='$V';}

  variable mousedown 0
  variable nextid 1
  variable items
  
  method do_createjs {} {return "wtk.createCanvas('[my id]');"}
  
  method create {itemtype args} {
      if {$itemtype ni [my property itemtypes]} {error "bad item type"}
      lassign [_parseCoordsAndOptions $args [my property opts.$itemtype]] coords opts
      set cid $nextid; incr nextid
      set items($cid) [list type $itemtype coords $coords]
      ::wtk::toclient "wtk.objs\['[my id]'\].createItem($cid,'$itemtype',\[[join $coords ,]\],$opts);"
      return $cid
  }
  
  method wtk_event {which args} {; # todo - make generic
      if {$which=="mousedown"} {set mousedown 1; set subs [list %x [lindex $args 0] %y [lindex $args 1]]; $W event_fire "<1>" $subs; if {[lindex $args 3]!=""} {$self event_fire [lindex $args 3] "<1>" $subs}}
      if {$which=="mousemove"} {if {$mousedown} {set ev "<B1-Motion>"} else {set ev "<Motion>"}; $W event_fire $ev [list %x [lindex $args 0] %y [lindex $args 1]]}
      if {$which=="mouseup"} {set mousedown 0; $W event_fire "<B1-Release>" [list %x [lindex $args 0] %y [lindex $args 1]]}
  }
  
  method _parseCoordsAndOptions {s optmap} {
      set coords ""; set inopts 0; set opts ""
      foreach {x y} [split $s] {
          if {!$inopts && [string is integer $x]} {
              if {![string is integer $y]} {error "odd number of coordinates"}
              lappend coords $x $y
          } else {
              set inopts 1
              if {![dict exists $optmap $x]} {error "bad option"}
              lappend opts "[dict get $optmap $x]:\"$y\""
          }
      }
      return [list $coords "\{[join $opts ,]\}"]
  }

  variable bindings
  
  method bind {id ev script} {set bindings(${id},$ev) $script}
  
  method event_fire {id ev subs} {
    if {[info exists bindings(${id},$ev)]} {
      uplevel #0 [string map $subs $bindings(${id},$ev)]
    }
  }
}

Changes to widgets/checkbutton.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

# Checkbutton
snit::type checkbutton {
    _wtkwidget -usetextvar

    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}
    variable currentvalue 0
    option -command
    option -onvalue -default 1 -configuremethod _onoffchanged
    option -offvalue -default 0 -configuremethod _onoffchanged
    option -variable -configuremethod _varnameset

    # TODO : move -variable handling into generic widget base
    method _createjs {} {set r "wtk.createCheckButton('[$self id]','[$self cget -text]');"; if {$currentvalue==$options(-onvalue)} {append r "[$self jsobj].childNodes\[0\].checked=true;"}; return $r}

    method _textchangejs {txt} {return "[$self jqobj].children(':last').html('$txt');"}
    method _event {which} {
        if {$which in "checked unchecked"} {




            if {$which=="checked"} {set val $options(-onvalue)} else {set val $options(-offvalue)}

            $self _changevalue $val 1; uplevel #0 $options(-command)
        }
    }
    method _varnameset {opt var} {set options($opt) $var;


        if {$var!=""} {



            if {![uplevel #0 info exists $var]} {uplevel #0 set $var $currentvalue} else {set currentvalue [uplevel #0 set $var]}

            uplevel #0 trace add variable $var write [list [list $self _varchanged]]
        }
    }
    method _onoffchanged {opt val} {if {$currentvalue==$options($opt)} {set options($opt) $val; $self _changevalue $val} else {set options($opt) $val}}
    method _varchanged {args} {if {$currentvalue ne [uplevel #0 set $options(-variable)]} {$self _changevalue [uplevel #0 set $options(-variable)]}}; # trace callback
    method _changevalue {newval {fromwidget 0}} {
        if {[$self _created?] && !$fromwidget} {
            if {$newval eq $options(-onvalue) && $options(-onvalue) ne $currentvalue} {
                wtk::toclient "[$self jsobj].childNodes\[0\].checked=true;"
            } elseif {$newval ne $options(-onvalue) && $options(-onvalue) eq $currentvalue} {
                wtk::toclient "[$self jsobj].childNodes\[0\].checked=false;"
            }
        }
        set currentvalue $newval
        if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
    }

}


|
|
>
|
|
|
|
|
|
|

|
<
>
|
|
|
>
>
>
>
|
>
|
|
|
|
>
>
|
>
>
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


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

# Checkbutton
::odie::class ::wtk::checkbutton {
  superclass wtk::LabelWidget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  variable currentvalue 0
  option -command
  option -onvalue -default 1 -configuremethod _onoffchanged
  option -offvalue -default 0 -configuremethod _onoffchanged
  option -variable -configuremethod _varnameset

  # TODO : move -variable handling into generic widget base

  method do_createjs {} {set r "wtk.createCheckButton('[my id]','[my cget -text]');"; if {$currentvalue==$options(-onvalue)} {append r "[my jsobj].childNodes\[0\].checked=true;"}; return $r}
  method _textchangejs {txt} {return "[my jqobj].children(':last').html('$txt');"}
  method wtk_event {which} {
    if {$which in "checked unchecked"} {
      variable options
      if {$which=="checked"} {
        set val $options(-onvalue)
      } else {
        set val $options(-offvalue)
      }
      my _changevalue $val 1; uplevel #0 $options(-command)
    }
  }
  method _varnameset {opt var} {
    my variable options
    set options($opt) $var;
    if {$var!=""} {
      if {![uplevel #0 info exists $var]} {
        uplevel #0 set $var $currentvalue
      } else {
        set currentvalue [uplevel #0 set $var]
      }
      uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    }
  }
  method _onoffchanged {opt val} {if {$currentvalue==$options($opt)} {set options($opt) $val; $self _changevalue $val} else {set options($opt) $val}}
  method _varchanged {args} {if {$currentvalue ne [uplevel #0 set $options(-variable)]} {$self _changevalue [uplevel #0 set $options(-variable)]}}; # trace callback
  method _changevalue {newval {fromwidget 0}} {
    if {[my was_created] && !$fromwidget} {
      if {$newval eq $options(-onvalue) && $options(-onvalue) ne $currentvalue} {
        ::wtk::toclient "[my jsobj].childNodes\[0\].checked=true;"
      } elseif {$newval ne $options(-onvalue) && $options(-onvalue) eq $currentvalue} {
        ::wtk::toclient "[my jsobj].childNodes\[0\].checked=false;"
      }
    }
    set currentvalue $newval
    if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
  }

}

Changes to widgets/combobox.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

# Combobox widgets
snit::type combobox {
    _wtkwidget -usetextvar

    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}
    _wtkoption -width "" {$JS.style.width=$V;}
    _wtkoption -height "" {$JS.style.height=$V;}
    _wtkoption -radius "" {$JS.style.borderRadius=$V;}
    variable optionsvalue ""
    variable currentvalue ""


    option -options  -configuremethod _setoptions 
    option -variable -configuremethod _varnameset
    option -command

    method _createjs {} {

    	 set r "wtk.createCombobox('[$self id]','[$self cget -text]');"
    	 foreach e $optionsvalue {
	    	 	 append r "[$self jsobj].innerHTML+='<option>$e</option>';"
	    	 }
	    return $r
    }
    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}
    method _event {which value} {
	    	if {$which eq "value"} {
	    		 $self _changevalue $value 1;
	    		 uplevel #0 $options(-command)
	    	}
    }    
    method _varnameset {opt var} {set options($opt) $var;
        if {$var!=""} {
            if {![uplevel #0 info exists $var]} {uplevel #0 set $var $currentvalue} else {set currentvalue [uplevel #0 set $var]}
            uplevel #0 trace add variable $var write [list [list $self _varchanged]]
        }
    }

    method _varchanged {args} {if {$currentvalue ne [uplevel #0 set $options(-variable)]} {$self _changevalue [uplevel #0 set $options(-variable)]}}; # trace callback




		method _changevalue {newval {fromwidget 0}} {
        if {[$self _created?] } {

            if {$newval ne $currentvalue} {
                wtk::toclient "[$self jsobj].value = '$newval';"
            }
        }
        set currentvalue $newval

        if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
    }


    method _setoptions {op values} {

    	set optionsvalue $values
    	if {$options(-options) ne ""} {uplevel #0 set $options(-options) [list $values]}
    	if {[$self _created?]} {

	    	 foreach e $values {
	    	 	 wtk::toclient "[$self jsobj].innerHTML+='<option>$e</option>';"
	    	 }
	    	}
    }
}


|
|
>
|
|
|
|
|
|
|
>
>
|
|
|
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
>
>
>
>
|
<
>
|
|
|
|
|
>
|

|
>
|
>
|
|
<
>
|
|
|
|
|

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

# Combobox widgets
::odie::class ::wtk::combobox {
  superclass wtk::Widget
  
  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  _wtkoption -width "" {$JS.style.width=$V;}
  _wtkoption -height "" {$JS.style.height=$V;}
  _wtkoption -radius "" {$JS.style.borderRadius=$V;}
  variable optionsvalue ""
  variable currentvalue ""
  
  option -text -configuremethod event_textchanged
  option -options  -configuremethod _setoptions 
  option -variable -configuremethod _varnameset
  option -command
  
  method do_createjs {} {
    my variable optionsvalue
    set r "wtk.createCombobox('[my id]','[my cget -text]');"
    foreach e [get optionsvalue] {
      append r "[my jsobj].innerHTML+='<option>$e</option>';"
    }
    return $r
  }
  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}
  method wtk_event {which value} {
              if {$which eq "value"} {
                       $self _changevalue $value 1;
                       uplevel #0 $options(-command)
              }
  }    
  method _varnameset {opt var} {set options($opt) $var;
      if {$var!=""} {
          if {![uplevel #0 info exists $var]} {uplevel #0 set $var $currentvalue} else {set currentvalue [uplevel #0 set $var]}
          uplevel #0 trace add variable $var write [list [list $self _varchanged]]
      }
  }
  method _varchanged {args} {
    if {$currentvalue ne [uplevel #0 set $options(-variable)]} {
      my _changevalue [uplevel #0 set $options(-variable)]
    }
  }
  
  method _changevalue {newval {fromwidget 0}} {

    if {[my was_created] } {
      if {$newval ne $currentvalue} {
        ::wtk::toclient "[my jsobj].value = '$newval';"
      }
    }
    set currentvalue $newval
    if {$options(-variable) ne ""} {
      uplevel #0 set $options(-variable) [list $newval]
    }
  }

  method _setoptions {op values} {
    my variable optionsvalue
    set optionsvalue $values
    if {$options(-options) ne ""} {uplevel #0 set $options(-options) [list $values]}

    if {[my was_created]} {
      foreach e $values {
        ::wtk::toclient "[my jsobj].innerHTML+='<option>$e</option>';"
      }
    }
  }
}

Changes to widgets/entry.tcl.

1
2
3
4

5
6
7

8
9

10

11



# Entry widgets
snit::type entry {
    _wtkwidget -usetextvar

    _wtkoption -width "" {$JS.size=$V;}
    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createEntry('[$self id]','[$self cget -text]');"}
    method _textchangejs {txt} {return "[$self jqobj].val('$txt');"}

    method _event {which args} {if {$which eq "value"} {$self _textchanged -text $args 1}}

}




|
|
>
|
|
|
>
|
|
>
|
>
|
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

# Entry widgets
::odie::class ::wtk::entry {
  superclass wtk::LabelWidget
  
  _wtkoption -width "" {$JS.size=$V;}
  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createEntry('[my id]','[my cget -text]');"}
  method _textchangejs {txt} {return "[my jqobj].val('$txt');"}
  method wtk_event {which args} {
    if {$which eq "value"} {
      my event_textchanged -text $args 1
    }
  }
}

Changes to widgets/frame.tcl.

1
2
3
4

5
6
7
8

# Frame
snit::type frame {
    _wtkwidget

    option -padding
    method _createjs {} {return "wtk.createFrame('[$self id]');"}
}



|
|
>
|
|


1
2
3
4
5
6
7
8
9

# Frame
::odie::class ::wtk::frame {
  superclass wtk::Widget

  option -padding
  method do_createjs {} {return "wtk.createFrame('[my id]');"}
}

Changes to widgets/label.tcl.

1
2
3
4

5
6

7
8
9

# Label widgets
snit::type label {
    _wtkwidget -usetextvar

    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','[$self cget -text]');"}
    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}
}


|
|
>
|
|
>
|
|

1
2
3
4
5
6
7
8
9
10
11

# Label widgets
::odie::class ::wtk::label {
  superclass wtk::LabelWidget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','[my cget -text]');"}
  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}
}

Changes to widgets/labelframe.tcl.

1
2
3
4


5
6

7
8
9
10


# labelframe widgets
snit::type Labelframe {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','labelframe');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# labelframe widgets
odie::class Labelframe {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','labelframe');"}
}


Changes to widgets/listbox.tcl.

1
2
3
4


5
6

7
8
9
10


# listbox widgets
snit::type Listbox {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','listbox');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# listbox widgets
::odie::class ::wtk::Listbox {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','listbox');"}
}


Changes to widgets/menu.tcl.

1
2
3
4


5
6

7
8
9
10


# menu widgets
snit::type Menu {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','menu');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# menu widgets
::odie::class ::wtk::Menu {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','menu');"}
}


Changes to widgets/menubutton.tcl.

1
2
3
4


5
6

7
8
9
10


# menubutton widgets
snit::type Menubutton {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','menubutton');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# menubutton widgets
::odie::class ::wtk::Menubutton {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','menubutton');"}
}


Changes to widgets/message.tcl.

1
2
3
4


5
6

7
8
9
10


# message widgets
snit::type Message {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','message');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# message widgets
::odie::class ::wtk::Message {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','message');"}
}


Changes to widgets/misc.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

# Label widgets
snit::type misc {
    _wtkwidget -usetextvar

    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}
    variable typevalue ""
    variable attrvalue ""
    variable currentvalue ""

    option -type  -configuremethod _setoption
    option -attr  -configuremethod _setoption
    option -variable -configuremethod _varnameset
    option -command

		method _createjs {} {
				set r "wtk.createMisc('[$self id]','[$self cget -type]','[$self cget -text]','[$self cget -attr]');"

				return $r
    }
    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}   
 
		method _setoption {opt var} {
				set options($opt) $var
        if {$var!=""} {
            if {![uplevel #0 info exists $options($opt)]} {
							uplevel #0 set $options($opt) [list $var]
            } else {
							set typevalue [uplevel #0 set $options($opt)]
						}
            #uplevel #0 trace add variable $options($opt) write [list [list $self _varchanged]]
        }
    }  
  
		method _event {which args} {
	    		 uplevel #0 $options(-command) $args
    }   

    method _varnameset {opt var} {
				set options($opt) $var
        if {$var!=""} {
            if {![uplevel #0 info exists $var]} {
							uplevel #0 set $var $currentvalue
            } else {
							set currentvalue [uplevel #0 set $var]
						}
            uplevel #0 trace add variable $var write [list [list $self _varchanged]]
        }
    }

		method _varchanged {args} {
			if {$currentvalue ne [uplevel #0 set $options(-variable)]} {
				$self _changevalue [uplevel #0 set $options(-variable)]
      }
    };


		method _changevalue {newval {fromwidget 0}} {
        if {[$self _created?] } {

            if {$newval ne $currentvalue} {
                wtk::toclient "[$self jsobj].value = '$newval';"
            }
        }
        set currentvalue $newval
        if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
    }
	


}


|
|
>
|
|
|
|
|
>
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
<
>
>
|
<
>
|
|
|
|
|
|
|
|
|
<
<
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



# Label widgets
::odie::class ::wtk::misc {
  superclass wtk::LabelWidget
  
  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  variable typevalue ""
  variable attrvalue ""
  variable currentvalue ""

  option -type  -configuremethod _setoption
  option -attr  -configuremethod _setoption
  option -variable -configuremethod _varnameset
  option -command
  
  method do_createjs {} {

      set r "wtk.createMisc('[my id]','[my cget -type]','[my cget -text]','[my cget -attr]');"
      return $r
  }
  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}   
  
  method _setoption {opt var} {
    set options($opt) $var
    if {$var!=""} {
      if {![uplevel #0 info exists $options($opt)]} {
        uplevel #0 set $options($opt) [list $var]
      } else {
        set typevalue [uplevel #0 set $options($opt)]
      }
      #uplevel #0 trace add variable $options($opt) write [list [list $self _varchanged]]
    }
  }
  
  method wtk_event {which args} {
    uplevel #0 $options(-command) $args
  }
  
  method _varnameset {opt var} {
    set options($opt) $var
    if {$var!=""} {
      if {![uplevel #0 info exists $var]} {
        uplevel #0 set $var $currentvalue
      } else {
        set currentvalue [uplevel #0 set $var]
      }
      uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    }
  }
  
  method _varchanged {args} {
    if {$currentvalue ne [uplevel #0 set $options(-variable)]} {
            $self _changevalue [uplevel #0 set $options(-variable)]
    }

  }
              
  method _changevalue {newval {fromwidget 0}} {

    if {[my was_created] } {
      if {$newval ne $currentvalue} {
          ::wtk::toclient "[my jsobj].value = '$newval';"
      }
    }
    set currentvalue $newval
    if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
  }

}


Changes to widgets/panedwindow.tcl.

1
2
3
4


5
6

7
8
9
10


# panedwindow widgets
snit::type Panedwindow {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','panedwindow');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# panedwindow widgets
::odie::class ::wtk::Panedwindow {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','panedwindow');"}
}


Changes to widgets/radiobutton.tcl.

1
2
3
4


5
6

7
8
9
10


# radiobutton widgets
snit::type Radiobutton {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','radiobutton');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# radiobutton widgets
::odie::class ::wtk::Radiobutton {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','radiobutton');"}
}


Changes to widgets/scale.tcl.

1
2
3
4


5
6

7
8
9
10


# scale widgets
snit::type Scale {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','scale');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# scale widgets
::odie::class ::wtk::Scale {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','scale');"}
}


Changes to widgets/scrollbar.tcl.

1
2
3
4


5
6

7
8
9
10


# scrollbar widgets
snit::type Scrollbar {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','scrollbar');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# scrollbar widgets
::odie::class ::wtk::Scrollbar {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','scrollbar');"}
}


Changes to widgets/spinbox.tcl.

1
2
3
4


5
6

7
8
9
10


# spinbox widgets
snit::type Spinbox {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','spinbox');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# spinbox widgets
::odie::class ::wtk::Spinbox {
  superclass wtk::Widget

  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','spinbox');"}
}


Changes to widgets/text.tcl.

1
2
3


4
5
6
7
8
9
10

11

12



# TextArea widgets
snit::type text {


    _wtkwidget -usetextvar
    _wtkoption -cols "" {$JS.cols=$V;}
    _wtkoption -rows "" {$JS.rows=$V;}
    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}
    method _createjs {} {return "wtk.createText('[$self id]','[$self cget -text]');"}
    method _textchangejs {txt} {return "[$self jqobj].val('$txt');"}

    method _event {which args} {if {$which eq "value"} {$self _textchanged -text $args 1}}

}




|
>
>
|
|
|
|
|
|
|
>
|
>
|
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

# TextArea widgets
::odie::class ::wtk::text {
  superclass wtk::LabelWidget
    
  #_wtkwidget -usetextvar
  _wtkoption -cols "" {$JS.cols=$V;}
  _wtkoption -rows "" {$JS.rows=$V;}
  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  method do_createjs {} {return "wtk.createText('[my id]','[my cget -text]');"}
  method _textchangejs {txt} {return "[my jqobj].val('$txt');"}
  method wtk_event {which args} {
    if {$which eq "value"} {
      my event_textchanged -text $args 1
    }
  }
}

Changes to widgets/tk_optionmenu.tcl.

1
2
3
4


5
6

7
8
9
10


# tk_optionmenu widgets
snit::type Tk_optionmenu {


    _wtkoption -bg "" {$JS.style.background='$V';}
    _wtkoption -fg "" {$JS.style.color='$V';}

    method _createjs {} {return "wtk.createLabel('[$self id]','tk_optionmenu');"}
}





|
>
>
|
|
>
|



1
2
3
4
5
6
7
8
9
10
11
12
13


# tk_optionmenu widgets
::odie::class ::wtk::Tk_optionmenu {
  superclass wtk::Widget
  
  _wtkoption -bg "" {$JS.style.background='$V';}
  _wtkoption -fg "" {$JS.style.color='$V';}
  
  method do_createjs {} {return "wtk.createLabel('[my id]','tk_optionmenu');"}
}