Index: README
==================================================================
--- README
+++ README
@@ -1,15 +1,15 @@
-Requires Snit. Run tclsh8.5 server.tcl and open your browser to http://localhost:9001
+Requires TclOO. Run tclsh8.5 server.tcl and open your browser to http://localhost:9001
I've recently started putting together a Tk-over-jQuery routine I'm calling web Tk (wtk). The idea is having full Tcl running on a server, with a Tk-like layer that sends commands to code running in a browser.
For those of you who remember it, this is conceptually similar to ProxyTk (see http://www.markroseman.com/pubs/proxytk.pdf).
An important thing is that its not tied into any particular web server or other communication channel; in fact, it just assumes there is a communication channel of some sort. This might be an AJAX connection pair, WebSockets, socket.io, etc. Or it might not even be a remote communication. You could well have a desktop/iPad app whose UI is a web view, and the "communication" between "server" and "client" might be just a procedure call.
-The implementation is based on Snit, and the demo uses simple Ajax communication over a generic minihttpd.tcl-derived web server. Incidentally, while I've never really used Snit before, it's a clear win for this type of thing; you'll see from the widget code that the amount of overhead needed to translate the "tk-like" commands into Javascript/jQuery calls is fairly minimal. This is important as I want to make this very easy for people to extend, wrap other jQuery widgets, etc.
+The implementation is based on TclOO, and the demo uses simple Ajax communication over a generic minihttpd.tcl-derived web server. TclOO translates the "tk-like" commands into Javascript/jQuery calls with fairly minimal code. This is important as I want to make this very easy for people to extend, wrap other jQuery widgets, etc.
It's still at what I'd consider the proof of concept stage, but it feels very promising.
Notes:
Index: commands/bind.tcl
==================================================================
--- commands/bind.tcl
+++ commands/bind.tcl
@@ -10,14 +10,14 @@
1 {
return -code error -level 1 -errorcode [list WTKNOTIMPYET bind query_for_script] {[bind window pattern] not yet implemented}
}
2 {
lassign $args ev script
- return [$w _bind $ev $script]
+ return [$w action_bind $ev $script]
}
default {
return -code error -level 1 {wrong # args: should be "bind window ?pattern? ?command?"}
}
}
- return [$w _bind $ev $script]
+ return [$w action_bind $ev $script]
}
Index: commands/focus.tcl
==================================================================
--- commands/focus.tcl
+++ commands/focus.tcl
@@ -8,11 +8,11 @@
return \
-code error \
[format {bad option "%1$s": must be -displayof, -force, or -lastfor} [lindex $arg 0]]
} elseif {[llength $args] == 1} {
_VerifyWindowExists $args
- $args _focus
+ $args event_focus
return;
}
switch -exact -- [lindex $args 0] {
-displayof {
return -code error -level 1 -errorcode [list WTKNOTIMPYET focus -displayof] {[focus -displayof] not yet implemented}
Index: commands/wm.tcl
==================================================================
--- commands/wm.tcl
+++ commands/wm.tcl
@@ -1,25 +1,26 @@
namespace eval ::wtk::wm:: {
- namespace ensemble create -map {
- aspect Aspect attributes Attributes client Client colormapwindows Colormapwindows command Command deiconify Deiconify focusmodel Focusmodel frame Frame geometry Geometry grid Grid group Group iconbitmap Iconbitmap iconify Iconify iconmask Iconmask iconname Iconname iconphoto Iconphoto iconposition Iconposition iconwindow Iconwindow maxsize Maxsize minsize Minsize overrideredirect Overrideredirect positionfrom Positionfrom protocol Protocol resizable Resizable sizefrom Sizefrom stackorder Stackorder state State title Title transient Transient withdraw Withdraw
- }
+ namespace ensemble create -map {
+ aspect Aspect attributes Attributes client Client colormapwindows Colormapwindows command Command deiconify Deiconify focusmodel Focusmodel frame Frame geometry Geometry grid Grid group Group iconbitmap Iconbitmap iconify Iconify iconmask Iconmask iconname Iconname iconphoto Iconphoto iconposition Iconposition iconwindow Iconwindow maxsize Maxsize minsize Minsize overrideredirect Overrideredirect positionfrom Positionfrom protocol Protocol resizable Resizable sizefrom Sizefrom stackorder Stackorder state State title Title transient Transient withdraw Withdraw
+ }
}
proc ::wtk::wm::_VerifyWindowExists {window} {
- 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;
+ 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
+ source $file
}
Index: demo.tcl
==================================================================
--- demo.tcl
+++ demo.tcl
@@ -1,105 +1,121 @@
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 "Link To Google"
- wtk::grid [wtk::misc .e.misclink -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 0
-
- wtk::grid [wtk::label .e.spacer -text " "] -column 1 -row 0 -sticky w
-
- set html " Link To Wtk Repo"
- wtk::grid [wtk::misc .e.misclinkwtk -type div -text "$html" -attr "innerHTML" -command nop] -column 2 -row 0
-
-
- set html ""
- wtk::grid [wtk::misc .up -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 5
-}
-
-proc nop {args} {}
-
+ 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 "Link To Google"
+ ::wtk::grid [::wtk::misc .e.misclink -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 0
+
+ ::wtk::grid [::wtk::label .e.spacer -text " "] -column 1 -row 0 -sticky w
+
+ set html " Link To Wtk Repo"
+ ::wtk::grid [::wtk::misc .e.misclinkwtk -type div -text "$html" -attr "innerHTML" -command nop] -column 2 -row 0
+
+
+ set html ""
+ ::wtk::grid [::wtk::misc .up -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 5
+}
+
+proc nop {args} {}
+
proc docheck {} {
- if {$::checkval} {
- set ::ckstatus "checked"
- wtk::focus .c.feet
- } else {
- set ::ckstatus ""
- }
-}
-
+ if {$::checkval} {
+ set ::ckstatus "checked"
+ ::wtk::focus .c.feet
+ } else {
+ set ::ckstatus ""
+ }
+}
+
proc calculate {} {
- if {[catch {
- set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
- set ::textval "hey!"
- }]!=0} {
- set ::meters ""
- }
-}
-
+ if {[catch {
+ set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
+ set ::textval "hey!"
+ }]!=0} {
+ set ::meters ""
+ }
+}
+
proc swapimages {} {
- switch -- $::image {
- 0 {set ::image 1; set ::textval "one"
- .d.ib configure -src /images/cameralens1.jpg}
-
- 1 {set ::image 2; set ::textval "two"
- .d.ib configure -src /images/rainbow.gif}
-
- 2 {set ::image 3; set ::textval "three"
- .d.ib configure -src /images/cameralens2.jpg}
-
- 3 {set ::image 0; set ::textval "zero"
- .d.ib configure -src /images/logo.png}
- }
-}
-
+ switch -- $::image {
+ 0 {
+ set ::image 1; set ::textval "one"
+ .d.ib configure -src /images/cameralens1.jpg
+ }
+
+ 1 {
+ set ::image 2; set ::textval "two"
+ .d.ib configure -src /images/rainbow.gif
+ }
+
+ 2 {
+ set ::image 3; set ::textval "three"
+ .d.ib configure -src /images/cameralens2.jpg
+ }
+
+ 3 {
+ set ::image 0; set ::textval "zero"
+ .d.ib configure -src /images/logo.png
+ }
+ }
+}
+
proc selectimg {} {
- switch -- $::textval {
- zero {set ::image 0
- .d.ib configure -src /images/logo.png}
-
- one {set ::image 1
- .d.ib configure -src /images/cameralens1.jpg}
-
- two {set ::image 2
- .d.ib configure -src /images/rainbow.gif}
-
- three {set ::image 3
- .d.ib configure -src /images/cameralens2.jpg}
-
- }
+ switch -- $::textval {
+ zero {
+ set ::image 0
+ .d.ib configure -src /images/logo.png
+ }
+
+ one {
+ set ::image 1
+ .d.ib configure -src /images/cameralens1.jpg
+ }
+
+ two {
+ set ::image 2
+ .d.ib configure -src /images/rainbow.gif
+ }
+
+ three {
+ set ::image 3
+ .d.ib configure -src /images/cameralens2.jpg
+ }
+ }
}
set ::image 0
render
-wtk::focus .c.feet
-wtk::bind . {calculate}
+::wtk::focus .c.feet
+::wtk::bind . {calculate}
Index: geomanagers/grid/configure.tcl
==================================================================
--- geomanagers/grid/configure.tcl
+++ geomanagers/grid/configure.tcl
@@ -6,15 +6,15 @@
set w [namespace tail $window]
::wtk::_VerifyWindowExists $w
set parent [join [lrange [split $w .] 0 end-1] .]
if {$parent eq ""} {set parent "."}
if {![info exists widgets($parent)]} {error "no parent widget found"}
- if {![$w _created?]} {$w _create}
+ if {![$w was_created]} {$w do_create}
if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
if {[dict keys $args -row]==""} {dict set args -row 0}
- ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
- [GridState for $parent] addSlave $w {*}$args
+ ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
+ [::wtk::GridState for $parent] addSlave $w {*}$args
return;
}
proc ::wtk::grid::Configure2 {cmd window args} {
variable ::wtk::widgets
@@ -22,14 +22,14 @@
set w [namespace tail $window]
::wtk::_VerifyWindowExists $w
set parent [join [lrange [split $w .] 0 end-1] .]
if {$parent eq ""} {set parent "."}
if {![info exists widgets($parent)]} {error "no parent widget found"}
- if {![$w _created?]} {$w _create}
+ if {![$w was_created]} {$w do_create}
if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
if {[dict keys $args -row]==""} {dict set args -row 0}
- ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
- [GridState for $parent] addSlave $w {*}$args
+ ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
+ [::wtk::GridState for $parent] addSlave $w {*}$args
return;
}
Index: geomanagers/wtk-grid.tcl
==================================================================
--- geomanagers/wtk-grid.tcl
+++ geomanagers/wtk-grid.tcl
@@ -6,76 +6,114 @@
variable widgets
switch -exact -- $w {
"columnconfigure" {}
"rowconfigure" {}
default {
- set w [namespace tail $w]
- set parent [join [lrange [split $w .] 0 end-1] .]
- if {$parent eq ""} {set parent "."}
- if {![info exists widgets($parent)]} {error "no parent widget found"}
- if {![$w _created?]} {$w _create}
- if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
- if {[dict keys $args -row]==""} {dict set args -row 0}
- ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
- [GridState for $parent] addSlave $w {*}$args
- return ""
+ set w [namespace tail $w]
+ set wobj ::$w
+
+ puts [list grid $w [info object class $wobj]]
+
+ set parent [join [lrange [split $w .] 0 end-1] .]
+ if {$parent eq ""} {set parent "."}
+ if {![info exists widgets($parent)]} {error "no parent widget found"}
+ if {![$wobj was_created]} {$wobj do_create}
+ if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
+ if {[dict keys $args -row]==""} {dict set args -row 0}
+ ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
+ [::wtk::GridState for $parent] addSlave $w {*}$args
+ return ""
}
}
}
# internal state kept for each master
- snit::type GridState {
- typevariable states
- typemethod for {w} {
- if {![info exists states($w)]} {set states($w) [GridState %AUTO% $w]}
- return $states($w)
+ odie::class ::wtk::GridState {
+
+ class_method for {w} {
+ my variable states
+ set w [namespace tail $w]
+
+ if {![info exists states($w)]} {
+ set states($w) [my create ::wtk::${w}#grid $w]
+ }
+ return $states($w)
}
- typemethod _reset {} {foreach i [$type info instances] {$i destroy}; unset states}
+ class_method _reset {} {
+ my variable states
+ foreach {w obj} [array get states] {
+ $obj destroy
+ }
+ unset states
+ }
variable rows {}
variable columns {}
variable slaves ; # array
variable tabledata {}
variable master
variable id
- constructor {w} {set master $w; set id [string map "obj grid" [$w id]] }
+
+ constructor {w} {
+ set master [namespace tail $w]
+ my variable rows columns tabledata master id
+ set rows {}
+ set columns {}
+ set tabledata {}
+
+ set id [string map "obj grid" [$master id]]
+ }
+
method jqobj {} {return "\$('#$id')"}
method jsobj {} {return "\$('#$id')\[0\]"}
- method _debug {} {return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]}
+ 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} {
- 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 ""
+ my variable rows columns tabledata master id slaves
+ set w [namespace tail $w]
+ if {[dict keys $args -column] eq "" || [dict keys $args -row] eq ""} {error "need to supply -column and -row"}; # NOTE: caller ensures we have a column and row
+ set slaves($w) $args
+ set colnum [dict get $args -column]; set rownum [dict get $args -row]
+ #puts "\n BEFORE: $tabledata -> col=$colnum row=$rownum w=$w"
+ if {$colnum ni $columns} {
+ my _insertColumn $colnum
+ }
+ if {$rownum ni $rows} {
+ my _insertRow $rownum
+ }
+
+ set colidx [lsearch $columns $colnum]; set rowidx [lsearch $rows $rownum]
+ set row [lindex $tabledata $rowidx]
+ #puts " row=$row, colidx=$colidx"
+ set tabledata [lreplace $tabledata $rowidx $rowidx [lreplace $row $colidx $colidx [lreplace [lindex $row $colidx] 2 2 $w]]]
+ #puts " AFTER: $tabledata\n"
+ ::wtk::toclient "[my jsobj].rows\[$rowidx\].cells\[$colidx\].appendChild(wtk.widgets\['[$w id]'\]);"
+ return ""
}
method _insertColumn {colnum} {
+ my variable rows columns tabledata master id slaves
+
set columns [lsort -integer [concat $columns $colnum]]; set colidx [lsearch $columns $colnum]
set new ""; set rowidx 0
foreach i $tabledata {
lappend new [linsert $i $colidx [list $colidx 1 blank]]
- wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($colidx);"
+ ::wtk::toclient "[my jsobj].rows\[$rowidx\].insertCell($colidx);"
incr rowidx
}
set tabledata $new
}
method _insertRow {rownum} {
- if {$tabledata==""} {wtk::toclient "wtk.newGrid('[$master id]','$id');"}
+ 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 "[$self jsobj].insertRow($rowidx);"
+ ::wtk::toclient "[my jsobj].insertRow($rowidx);"
set row ""; for {set i 0} {$i<[llength $columns]} {incr i} {
lappend row [list $i 1 blank]
- wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($i);"
+ ::wtk::toclient "[my jsobj].rows\[$rowidx\].insertCell($i);"
}
lappend tabledata $row
}
}
Index: lib/httpd.tcl
==================================================================
--- lib/httpd.tcl
+++ lib/httpd.tcl
@@ -544,10 +544,11 @@
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
@@ -560,11 +561,11 @@
set url ""
if {[info exists data(url)]} {
set url $data(url)
}
HttpdError $sock 500 "Error processing request"
- catch {bgerror "Error processing handler for $url:\n$::errorInfo"}
+ catch {bgerror "Error processing handler for $url:\n$einfo"}
}
} else {
Httpd_Log $sock Respond completed ok
if {[info exists data] && (![info exists data(sendingfile)] || $data(sendingfile)!=1)} {
Httpd_Log $sock "Return had not been called during request processing; closing connection. data=[array names data]"
Index: lib/wtk-base.tcl
==================================================================
--- lib/wtk-base.tcl
+++ lib/wtk-base.tcl
@@ -3,142 +3,245 @@
# by sending Javascript commands. It also receives callbacks from the client side which
# are interpreted and used to update internal widget state here, which often triggers
# callbacks or other event bindings.
#
# Communication with the client is solely via the "fromclient" and "toclient" routines
-# (the latter of which is setup in the wtk::init call).
+# (the latter of which is setup in the ::wtk::init call).
-package require snit
+package require TclOO
package require log
+source odie/index.tcl
+
+###
+# Add "option"
+###
namespace eval ::wtk {
variable widgets
variable wobj
variable _nextid -1
variable _sender ""
# Initialization and communication
proc init {sender} {
- set wtk::_sender $sender
- wtk::Widget "." ""
- return ""
+ set ::wtk::_sender $sender
+ ::wtk::Widget "."
+ return ""
}
# for debugging
proc _reset {} {
variable wobj; variable widgets; variable _nextid; variable _sender
foreach {id w} [array get wobj] {$w destroy}
unset -nocomplain widgets
unset -nocomplain wobj
set _nextid -1
- GridState _reset
+ ::wtk::GridState _reset
init $_sender
return ""
}
- proc toclient {cmd} {uplevel #0 $wtk::_sender [list $cmd]}
+ proc toclient {cmd} {uplevel #0 $::wtk::_sender [list $cmd]}
proc fromclient {cmd} {
switch -exact -- [lindex $cmd 0] {
"EVENT" {
- [getwidget [lindex $cmd 1]] _event {*}[lrange $cmd 2 end]
+ [getwidget [lindex $cmd 1]] wtk_event {*}[lrange $cmd 2 end]
}
"LOG" {
::log::log [lindex $cmd 1] [lrange $cmd 2 end]
}
}
}
-
# 'Generic' widget object, which handles routines common to all widgets like
# assigning it an id, keeping track of whether or not its been created, etc.
# Purely for convenience, we also include some code here that manages widgets
# that use -text or -textvariable, though not every widget will do so.
- snit::type Widget {
- variable id; variable created; variable wobj; variable postcreatemsgs ""
+ ::odie::class ::wtk::Widget {
+ variable id
+ variable tkpath
+ variable created
+ variable wobj
+ variable postcreatemsgs
variable propertiesDict
-
- 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} {
+ 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] {
+ 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 ::$objname $objname {*}$args
+ return $objname
+ }
+ error "Unknown method $objname. Valid: [info class methods [info object class [self]]]"
+ }
+
+ class_method option args {
+ puts $args
+ }
+
+ method property_set {propertyKey value} {
dict set propertiesDict {*}$propertyKey value
return $value;
}
- method _hasProperty {args} {
+ method property_has {args} {
return [dict exists $propertiesDict {*}$propertyKey]
}
- method _getProperty {args} {
+ method property_get {args} {
return [dict get $propertiesDict {*}$propertyKey]
}
- method _created? {} {return $created}
- method _create {} {
- set js [$wobj _createjs]
- append js $postcreatemsgs; set postcreatemsgs ""
- wtk::toclient $js
+ 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 _sendWhenCreated {msg} {if {[$self _created?]} {wtk::toclient $msg} else {append postcreatemsgs $msg}}
+ 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 "\$('#[$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
- }
+ 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 _bind {ev script} {set bindings($ev) $script}
- method _fireevent {ev subs} {if {[info exists bindings($ev)]} {uplevel #0 [string map $subs $bindings($ev)]}}
+ method action_bind {ev script} {set bindings($ev) $script}
+ method event_fire {ev subs} {if {[info exists bindings($ev)]} {uplevel #0 [string map $subs $bindings($ev)]}}
+ }
+
+ ::odie::class ::wtk::LabelWidget {
+ superclass ::wtk::Widget
+
+
+ # text variable handling; only relevant if the main types delegate these options to us
+ option -text -configuremethod event_textchanged
+ option -textvariable -configuremethod event_textvarset
+
+ method event_textchanged {opt txt {fromwidget 0}} {
+ my variable created options
+ set options($opt) $txt
+ if {$created && !$fromwidget} {
+ ::wtk::toclient [my _textchangejs $txt]
+ }
+
+ if {$options(-textvariable)!=""} {
+ uplevel #0 set $options(-textvariable) [list $txt]
+ }
+ }
+ method event_textvariablechanged {args} {
+ my variable options
+ if {$options(-text) ne [uplevel #0 set $options(-textvariable)]} {
+ my event_textchanged -text [uplevel #0 set $options(-textvariable)]
+ }
+ }
+ method event_setuptextvar {} {
+ my variable options
+ if {$options(-textvariable)!=""} {
+ if {![uplevel #0 info exists $options(-textvariable)]} {
+ uplevel #0 set $options(-textvariable) [list $options(-text)]
+ } else {
+ set options(-text) [uplevel #0 set $options(-textvariable)]
+ }
+ uplevel #0 trace add variable $options(-textvariable) write [list [list [self] event_textvariablechanged]]
+ }
+ }
+ method event_textvarset {opt var} {
+ my variable options
+ set options($opt) $var
+ my event_setuptextvar
+ }
+
}
- proc getwidget {id} {return $wtk::wobj($id)}
+ proc getwidget {id} {return $::wtk::wobj($id)}
proc _VerifyWindowExists {window} {
variable widgets
if {![info exists ::wtk::widgets([string trimleft $window])]} {
@@ -148,25 +251,32 @@
[format {bad window path name "%1$s"} $window]
}
return;
}
- proc focus {w} {$w _focus; return ""}
- proc bind {w ev script} {return [$w _bind $ev $script]}
+ proc focus {w} {$w event_focus; return ""}
+ proc bind {w ev script} {return [$w action_bind $ev $script]}
# Macro that can be used to simplify the definition of any widget
- snit::macro _wtkwidget {args} {
+ ::odie::macro _wtkwidget {args} {
component W; delegate method * to W; set extrainits ""
- if {"-usetextvar" in $args} {delegate option -textvariable to W; delegate option -text to W; set extrainits {$W _setuptextvar}}
+ if {"-usetextvar" in $args} {delegate option -textvariable to W; delegate option -text to W; set extrainits {$W event_setuptextvar}}
constructor {args} "install W using Widget \$\{selfns\}::W \$self; \$self configurelist \$args; $extrainits"
}
# Macro used to define options which set their value and then send some Javascript command to the widget
- snit::macro _wtkoption {opt default msg} {
+ ::odie::macro _wtkoption {opt default msg} {
option $opt -default $default -configuremethod _wtkoption$opt
- method _wtkoption$opt {opt val} "set options(\$opt) \$val; set JS \[\$self jsobj\]; set V \$val; \$self _sendWhenCreated \[subst [list $msg]\]"
+ method _wtkoption$opt {opt val} "
+ my variable options
+ set opt [string trimleft $opt -]
+ set options(\$opt) \$val
+ set JS \[my jsobj\]
+ set V \$val
+ my action_sendWhenCreated \[subst [list $msg]\]
+ "
}
}
ADDED odie/codebale.tcl
Index: odie/codebale.tcl
==================================================================
--- /dev/null
+++ odie/codebale.tcl
@@ -0,0 +1,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
Index: odie/global.tcl
==================================================================
--- /dev/null
+++ odie/global.tcl
@@ -0,0 +1,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
Index: odie/index.tcl
==================================================================
--- /dev/null
+++ odie/index.tcl
@@ -0,0 +1,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
Index: odie/license.terms
==================================================================
--- /dev/null
+++ odie/license.terms
@@ -0,0 +1,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
Index: odie/logicset.tcl
==================================================================
--- /dev/null
+++ odie/logicset.tcl
@@ -0,0 +1,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
Index: odie/moac.tcl
==================================================================
--- /dev/null
+++ odie/moac.tcl
@@ -0,0 +1,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
Index: odie/oosqlite.tcl
==================================================================
--- /dev/null
+++ odie/oosqlite.tcl
@@ -0,0 +1,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
Index: odie/ootools.tcl
==================================================================
--- /dev/null
+++ odie/ootools.tcl
@@ -0,0 +1,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
Index: odie/queue.tcl
==================================================================
--- /dev/null
+++ odie/queue.tcl
@@ -0,0 +1,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
Index: odie/stack.tcl
==================================================================
--- /dev/null
+++ odie/stack.tcl
@@ -0,0 +1,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
Index: odie/yggdrasil.tcl
==================================================================
--- /dev/null
+++ odie/yggdrasil.tcl
@@ -0,0 +1,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 -]]
+
+ }
+}
+
Index: server.tcl
==================================================================
--- server.tcl
+++ server.tcl
@@ -93,11 +93,11 @@
#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]
+ [dict get $::session($sessionid) interp] eval ::wtk::fromclient [list $cmd]
}
}
proc ws_upgrade {sock data} {
@@ -212,17 +212,17 @@
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
+ $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
+ $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
@@ -244,12 +244,12 @@
# 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]}
+# 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,
Index: sketch.tcl
==================================================================
--- sketch.tcl
+++ sketch.tcl
@@ -1,15 +1,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 {
+::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 {
.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
+::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
}
Index: widgets/button.tcl
==================================================================
--- widgets/button.tcl
+++ widgets/button.tcl
@@ -1,14 +1,24 @@
# 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)}}
+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)
+ }
+ }
}
Index: widgets/canvas.tcl
==================================================================
--- widgets/canvas.tcl
+++ widgets/canvas.tcl
@@ -1,48 +1,60 @@
# 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 ""} else {set ev ""}; $W _fireevent $ev [list %x [lindex $args 0] %y [lindex $args 1]]}
- if {$which=="mouseup"} {set mousedown 0; $W _fireevent "" [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)]}}
+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 ""} else {set ev ""}; $W event_fire $ev [list %x [lindex $args 0] %y [lindex $args 1]]}
+ if {$which=="mouseup"} {set mousedown 0; $W event_fire "" [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)]
+ }
+ }
}
Index: widgets/checkbutton.tcl
==================================================================
--- widgets/checkbutton.tcl
+++ widgets/checkbutton.tcl
@@ -1,42 +1,54 @@
# 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]}
- }
+::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]}
+ }
}
Index: widgets/combobox.tcl
==================================================================
--- widgets/combobox.tcl
+++ widgets/combobox.tcl
@@ -1,55 +1,68 @@
# 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+='';"
- }
- 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+='';"
- }
- }
- }
+::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+='';"
+ }
+ 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+='';"
+ }
+ }
+ }
}
Index: widgets/entry.tcl
==================================================================
--- widgets/entry.tcl
+++ widgets/entry.tcl
@@ -1,11 +1,17 @@
# 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}}
+::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
+ }
+ }
}
Index: widgets/frame.tcl
==================================================================
--- widgets/frame.tcl
+++ widgets/frame.tcl
@@ -1,8 +1,9 @@
# Frame
-snit::type frame {
- _wtkwidget
- option -padding
- method _createjs {} {return "wtk.createFrame('[$self id]');"}
+::odie::class ::wtk::frame {
+ superclass wtk::Widget
+
+ option -padding
+ method do_createjs {} {return "wtk.createFrame('[my id]');"}
}
Index: widgets/label.tcl
==================================================================
--- widgets/label.tcl
+++ widgets/label.tcl
@@ -1,9 +1,11 @@
# 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');"}
+::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');"}
}
Index: widgets/labelframe.tcl
==================================================================
--- widgets/labelframe.tcl
+++ widgets/labelframe.tcl
@@ -1,10 +1,13 @@
# 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');"}
+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');"}
}
Index: widgets/listbox.tcl
==================================================================
--- widgets/listbox.tcl
+++ widgets/listbox.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/menu.tcl
==================================================================
--- widgets/menu.tcl
+++ widgets/menu.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/menubutton.tcl
==================================================================
--- widgets/menubutton.tcl
+++ widgets/menubutton.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/message.tcl
==================================================================
--- widgets/message.tcl
+++ widgets/message.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/misc.tcl
==================================================================
--- widgets/misc.tcl
+++ widgets/misc.tcl
@@ -1,64 +1,67 @@
# 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]}
- }
-
-
+::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]}
+ }
}
Index: widgets/panedwindow.tcl
==================================================================
--- widgets/panedwindow.tcl
+++ widgets/panedwindow.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/radiobutton.tcl
==================================================================
--- widgets/radiobutton.tcl
+++ widgets/radiobutton.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/scale.tcl
==================================================================
--- widgets/scale.tcl
+++ widgets/scale.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/scrollbar.tcl
==================================================================
--- widgets/scrollbar.tcl
+++ widgets/scrollbar.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/spinbox.tcl
==================================================================
--- widgets/spinbox.tcl
+++ widgets/spinbox.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}
Index: widgets/text.tcl
==================================================================
--- widgets/text.tcl
+++ widgets/text.tcl
@@ -1,12 +1,18 @@
# 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}}
+::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
+ }
+ }
}
Index: widgets/tk_optionmenu.tcl
==================================================================
--- widgets/tk_optionmenu.tcl
+++ widgets/tk_optionmenu.tcl
@@ -1,10 +1,13 @@
# 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');"}
+::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');"}
}