SR Technology WTK Repo
Check-in [833107b47e]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Ported code to TclOO. Demos all work. Integrated the Odie package to extend TclOO and add extra keywords and to make TclOO more snitlike.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 833107b47e9e4873046a7582b3254ae3fcd612b9
User & Date: seandeelywoods 2013-02-12 15:13:25
Context
2013-02-12
15:35
Removed several debugging puts statements Fixed some snitizisms I had missed in the canvas implementation. Rather than use delegation to re-use the "event_fire" method, I've simply created an object_event_fire method for the canvas to distinguish between widget bindings and canvas object bindings check-in: b88021946e user: seandeelywoods tags: trunk
15:13
Ported code to TclOO. Demos all work. Integrated the Odie package to extend TclOO and add extra keywords and to make TclOO more snitlike. check-in: 833107b47e user: seandeelywoods tags: trunk
15:11
Moved wtk widgets back to the global namespace Leaf check-in: c4c1ad43fd user: seandeelywoods tags: hypnotoad
2013-02-05
02:15
Add logging methods. check-in: 04e9c7f911 user: gerald tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to README.

     1         -Requires Snit.  Run tclsh8.5 server.tcl and open your browser to http://localhost:9001
            1  +Requires TclOO.  Run tclsh8.5 server.tcl and open your browser to http://localhost:9001
     2      2   
     3      3   
     4      4   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.
     5      5   
     6      6   For those of you who remember it, this is conceptually similar to ProxyTk (see http://www.markroseman.com/pubs/proxytk.pdf).
     7      7   
     8      8   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.
     9      9   
    10         -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.
           10  +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.
    11     11   
    12     12   It's still at what I'd consider the proof of concept stage, but it feels very promising.
    13     13   
    14     14   
    15     15   Notes:
    16     16   
    17     17   Starting the wtk app server:

Changes to commands/bind.tcl.

     8      8               return  -code error  -level 1  -errorcode [list WTKNOTIMPYET bind query_for_events]  {[bind window] not yet implemented}
     9      9           }
    10     10           1 {
    11     11               return  -code error  -level 1  -errorcode [list WTKNOTIMPYET bind query_for_script]  {[bind window pattern] not yet implemented}
    12     12           }
    13     13           2 {
    14     14               lassign $args ev script
    15         -            return [$w _bind $ev $script]
           15  +            return [$w action_bind $ev $script]
    16     16           }
    17     17           default {
    18     18               return  -code error  -level 1  {wrong # args: should be "bind window ?pattern? ?command?"}
    19     19   
    20     20           }
    21     21       }
    22         -    return [$w _bind $ev $script]
           22  +    return [$w action_bind $ev $script]
    23     23   }

Changes to commands/focus.tcl.

     6      6           set args [list  -displayof .]
     7      7       } elseif {[llength $args] > 2} {
     8      8           return \
     9      9               -code error \
    10     10               [format {bad option "%1$s": must be -displayof, -force, or -lastfor} [lindex $arg 0]]
    11     11       } elseif {[llength $args] == 1} {
    12     12           _VerifyWindowExists $args
    13         -        $args _focus
           13  +        $args event_focus
    14     14           return;
    15     15       }
    16     16       switch -exact -- [lindex $args 0] {
    17     17           -displayof {
    18     18               return  -code error  -level 1  -errorcode [list WTKNOTIMPYET focus -displayof]  {[focus -displayof] not yet implemented}
    19     19           }
    20     20           -force {

Changes to commands/wm.tcl.

     1      1   
     2      2   namespace eval ::wtk::wm:: {
     3         -    namespace ensemble create  -map {
     4         -            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
     5         -        }
            3  +  namespace ensemble create  -map {
            4  +    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
            5  +  }
     6      6   }
     7      7   
     8      8   proc ::wtk::wm::_VerifyWindowExists {window} {
     9         -    if {![info exists ::wtk::widgets([string trimleft $window])]} {
    10         -        return \
    11         -            -code error \
    12         -            -level 2 \
    13         -            [format {bad window path name "%1$s"} $window]
    14         -    } elseif {![string equal $window {.}]} {
    15         -        return \
    16         -            -code error \
    17         -            -level 2 \
    18         -            [format {window "%1$s" isn't a top-level window} $window]
    19         -    }
    20         -    return;
            9  +  parray ::wtk::widgets
           10  +  if {![info exists ::wtk::widgets([string trimleft $window])]} {
           11  +    return \
           12  +      -code error \
           13  +      -level 2 \
           14  +      [format {bad window path name "%1$s"} $window]
           15  +  } elseif {![string equal $window {.}]} {
           16  +    return \
           17  +      -code error \
           18  +      -level 2 \
           19  +      [format {window "%1$s" isn't a top-level window} $window]
           20  +  }
           21  +  return;
    21     22   }
    22     23   
    23     24   foreach file [glob -- [file join [file dirname [info script]] wm *.tcl]] {
    24         -    source $file
           25  +  source $file
    25     26   }

Changes to demo.tcl.

     1      1   
     2      2   proc render {} {
     3         -	wtk::wm title . "Feet to Meters"
     4         -	
     5         -	wtk::grid [wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
     6         -	wtk::grid columnconfigure .c 0 -weight 1; wtk::grid rowconfigure .c 0 -weight 1
     7         -	wtk::grid [wtk::button .c.calc -text "Calculate" -radius 7 -bg #ffccff -fg darkgreen -command calculate] -column 0 -row 1 -sticky w
     8         -	wtk::grid [wtk::entry .c.feet -width 7 -textvariable feet -bg GreenYellow -fg Red] -column 1 -row 1 -sticky we
     9         -	wtk::grid [wtk::label .c.flbl -text "feet" -bg yellow] -column 2 -row 1 -sticky w
    10         -	wtk::grid [wtk::label .c.islbl -text "is equivalent to"] -column 0 -row 2 -sticky e
    11         -	wtk::grid [wtk::label .c.meters -textvariable meters] -column 1 -row 2 -sticky we
    12         -	wtk::grid [wtk::label .c.mlbl -text "meters"] -column 2 -row 2 -sticky w
    13         -	#foreach w [wtk::winfo children .c] {wtk::grid configure $w -padx 50 -pady 50}; #not working yet
    14         -	
    15         -	wtk::grid [wtk::text .text -rows 4 -cols 40 -bg GreenYellow -fg Red -textvariable textval] -column 0 -row 2 -sticky ew
    16         -	
    17         -	wtk::grid [wtk::frame .d -padding "3 3 12 12"] -column 0 -row 3 -sticky nwes
    18         -	wtk::grid columnconfigure .d 0 -weight 1; wtk::grid rowconfigure .d 0 -weight 1
    19         -	wtk::grid rowconfigure . 3 -weight 1
    20         -	wtk::grid [wtk::button .d.ib  -text "" -src /images/logo.png -width 63 -height 63 -command swapimages]  -column 0 -row 0 -sticky e
    21         -	wtk::grid [wtk::label .d.iblbl -text "<-- Click Me"] -column 1 -row 0 -sticky w
    22         -	wtk::grid [wtk::combobox .d.cb  -text "ComboBox" -options "zero one two three" -variable textval -command selectimg]  -column 2 -row 0 -sticky w
    23         -	wtk::grid [wtk::checkbutton .d.ck  -bg violet -fg Red -variable checkval -command docheck] -column 3 -row 0 -sticky w
    24         -	wtk::grid [wtk::label .d.cklbl  -textvariable ckstatus] -column 4 -row 0 -sticky w
    25         -	#foreach w [wtk::winfo children .d] {wtk::grid configure $w -padx 150 -pady 150}; #not working yet
    26         -	
    27         -	wtk::grid [wtk::frame .e -padding "3 3 12 12"] -column 0 -row 4 -sticky nwes
    28         -	wtk::grid columnconfigure .e 0 -weight 1; wtk::grid rowconfigure .e 0 -weight 1	
    29         -	set html "<a href=\"http://www.google.com\">Link To Google<a/>"
    30         -	wtk::grid [wtk::misc .e.misclink -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 0
    31         -	
    32         -  wtk::grid [wtk::label .e.spacer -text "&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp"] -column 1 -row 0 -sticky w
            3  +  puts RENDER
            4  +  ::wtk::wm title . "Feet to Meters"
            5  +  
            6  +  ::wtk::grid [::wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
            7  +  ::wtk::grid columnconfigure .c 0 -weight 1; ::wtk::grid rowconfigure .c 0 -weight 1
            8  +  ::wtk::grid [::wtk::button .c.calc -text "Calculate" -radius 7 -bg #ffccff -fg darkgreen -command calculate] -column 0 -row 1 -sticky w
            9  +  ::wtk::grid [::wtk::entry .c.feet -width 7 -textvariable feet -bg GreenYellow -fg Red] -column 1 -row 1 -sticky we
           10  +  ::wtk::grid [::wtk::label .c.flbl -text "feet" -bg yellow] -column 2 -row 1 -sticky w
           11  +  ::wtk::grid [::wtk::label .c.islbl -text "is equivalent to"] -column 0 -row 2 -sticky e
           12  +  ::wtk::grid [::wtk::label .c.meters -textvariable meters] -column 1 -row 2 -sticky we
           13  +  ::wtk::grid [::wtk::label .c.mlbl -text "meters"] -column 2 -row 2 -sticky w
           14  +  #foreach w [::wtk::winfo children .c] {::wtk::grid configure $w -padx 50 -pady 50}; #not working yet
           15  +  
           16  +  ::wtk::grid [::wtk::text .text -rows 4 -cols 40 -bg GreenYellow -fg Red -textvariable textval] -column 0 -row 2 -sticky ew
           17  +  
           18  +  ::wtk::grid [::wtk::frame .d -padding "3 3 12 12"] -column 0 -row 3 -sticky nwes
           19  +  ::wtk::grid columnconfigure .d 0 -weight 1; ::wtk::grid rowconfigure .d 0 -weight 1
           20  +  ::wtk::grid rowconfigure . 3 -weight 1
           21  +  ::wtk::grid [::wtk::button .d.ib  -text "" -src /images/logo.png -width 63 -height 63 -command swapimages]  -column 0 -row 0 -sticky e
           22  +  ::wtk::grid [::wtk::label .d.iblbl -text "<-- Click Me"] -column 1 -row 0 -sticky w
           23  +  ::wtk::grid [::wtk::combobox .d.cb  -text "ComboBox" -options "zero one two three" -variable textval -command selectimg]  -column 2 -row 0 -sticky w
           24  +  ::wtk::grid [::wtk::checkbutton .d.ck  -bg violet -fg Red -variable checkval -command docheck] -column 3 -row 0 -sticky w
           25  +  ::wtk::grid [::wtk::label .d.cklbl  -textvariable ckstatus] -column 4 -row 0 -sticky w
           26  +  #foreach w [::wtk::winfo children .d] {::wtk::grid configure $w -padx 150 -pady 150}; #not working yet
           27  +  
           28  +  ::wtk::grid [::wtk::frame .e -padding "3 3 12 12"] -column 0 -row 4 -sticky nwes
           29  +  ::wtk::grid columnconfigure .e 0 -weight 1; ::wtk::grid rowconfigure .e 0 -weight 1	
           30  +  set html "<a href=\"http://www.google.com\">Link To Google<a/>"
           31  +  ::wtk::grid [::wtk::misc .e.misclink -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 0
           32  +  
           33  +  ::wtk::grid [::wtk::label .e.spacer -text "&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp"] -column 1 -row 0 -sticky w
           34  +  
           35  +  set html "<a href=\"http://dev.sr-tech.com:8100/wtk/timeline?n=200\">   Link To Wtk Repo<a/>"
           36  +  ::wtk::grid [::wtk::misc .e.misclinkwtk -type div -text "$html" -attr "innerHTML" -command nop] -column 2 -row 0
           37  +  
    33     38     
    34         -	set html "<a href=\"http://dev.sr-tech.com:8100/wtk/timeline?n=200\">   Link To Wtk Repo<a/>"
    35         -	wtk::grid [wtk::misc .e.misclinkwtk -type div -text "$html" -attr "innerHTML" -command nop] -column 2 -row 0
    36         -	
    37         -	
    38         -	set html "<form action=\"demo.tcl\" method=\"post\" enctype=\"multipart/form-data\">"
    39         -	append html "<input type=\"file\" name=\"upfile\" id=\"file\">"
    40         -	append html "<input type=\"submit\" name=\"submit\" value=\"Submit\">"
    41         -	append html "</form>"
    42         -	wtk::grid [wtk::misc .up -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 5
           39  +  set html "<form action=\"demo.tcl\" method=\"post\" enctype=\"multipart/form-data\">"
           40  +  append html "<input type=\"file\" name=\"upfile\" id=\"file\">"
           41  +  append html "<input type=\"submit\" name=\"submit\" value=\"Submit\">"
           42  +  append html "</form>"
           43  +  ::wtk::grid [::wtk::misc .up -type div -text "$html" -attr "innerHTML" -command nop] -column 0 -row 5
    43     44   }
    44         -
           45  +  
    45     46   proc nop {args} {}
    46         -
           47  +  
    47     48   proc docheck {} {
    48         -	if {$::checkval} {
    49         -		set ::ckstatus "checked"
    50         -		wtk::focus .c.feet
    51         -	} else {
    52         -		set ::ckstatus ""
    53         -	}
           49  +  if {$::checkval} {
           50  +        set ::ckstatus "checked"
           51  +        ::wtk::focus .c.feet
           52  +  } else {
           53  +        set ::ckstatus ""
           54  +  }
    54     55   }
    55         -
           56  +  
    56     57   proc calculate {} {
    57         -	if {[catch {
    58         -			set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
    59         -			set ::textval "hey!"
    60         -		}]!=0} {
    61         -		set ::meters ""
    62         -	}
           58  +  if {[catch {
           59  +                set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
           60  +                set ::textval "hey!"
           61  +        }]!=0} {
           62  +        set ::meters ""
           63  +  }
    63     64   }
    64         -
           65  +  
    65     66   proc swapimages {} {
    66         -	switch -- $::image {
    67         -		0 {set ::image 1; set ::textval "one"
    68         -			.d.ib configure -src /images/cameralens1.jpg}
    69         -		
    70         -		1 {set ::image 2; set ::textval "two"
    71         -			.d.ib configure -src /images/rainbow.gif}
    72         -		
    73         -		2 {set ::image 3; set ::textval "three"
    74         -			.d.ib configure -src /images/cameralens2.jpg}
    75         -		
    76         -		3 {set ::image 0; set ::textval "zero"
    77         -			.d.ib configure -src /images/logo.png}
    78         -	}
           67  +  switch -- $::image {
           68  +    0 {
           69  +      set ::image 1; set ::textval "one"
           70  +      .d.ib configure -src /images/cameralens1.jpg
           71  +    }
           72  +    
           73  +    1 {
           74  +      set ::image 2; set ::textval "two"
           75  +      .d.ib configure -src /images/rainbow.gif
           76  +    }
           77  +    
           78  +    2 {
           79  +      set ::image 3; set ::textval "three"
           80  +      .d.ib configure -src /images/cameralens2.jpg
           81  +    }
           82  +    
           83  +    3 {
           84  +      set ::image 0; set ::textval "zero"
           85  +      .d.ib configure -src /images/logo.png
           86  +    }
           87  +  }
    79     88   }
    80         -
           89  +  
    81     90   proc selectimg {} {
    82         -	switch -- $::textval {
    83         -		zero  {set ::image 0
    84         -			.d.ib configure -src /images/logo.png}
    85         -		
    86         -		one   {set ::image 1
    87         -			.d.ib configure -src /images/cameralens1.jpg}
    88         -		
    89         -		two   {set ::image 2
    90         -			.d.ib configure -src /images/rainbow.gif}
    91         -		
    92         -		three {set ::image 3
    93         -			.d.ib configure -src /images/cameralens2.jpg}
    94         -		
    95         -	}
           91  +  switch -- $::textval {
           92  +    zero  {
           93  +      set ::image 0
           94  +      .d.ib configure -src /images/logo.png
           95  +    }
           96  +    
           97  +    one   {
           98  +      set ::image 1
           99  +      .d.ib configure -src /images/cameralens1.jpg
          100  +    }
          101  +    
          102  +    two   {
          103  +      set ::image 2
          104  +      .d.ib configure -src /images/rainbow.gif
          105  +    }
          106  +    
          107  +    three {
          108  +      set ::image 3
          109  +      .d.ib configure -src /images/cameralens2.jpg
          110  +    }    
          111  +  }
    96    112   }
    97    113   
    98    114   set ::image 0
    99    115   
   100    116   render
   101    117   
   102         -wtk::focus .c.feet
   103         -wtk::bind . <Return> {calculate}
          118  +::wtk::focus .c.feet
          119  +::wtk::bind . <Return> {calculate}
   104    120   
   105    121   

Changes to geomanagers/grid/configure.tcl.

     4      4       variable ::wtk::widgets
     5      5   
     6      6       set w [namespace tail $window]
     7      7       ::wtk::_VerifyWindowExists $w
     8      8       set parent [join [lrange [split $w .] 0 end-1] .]
     9      9       if {$parent eq ""} {set parent "."}
    10     10       if {![info exists widgets($parent)]} {error "no parent widget found"}
    11         -    if {![$w _created?]} {$w _create}
           11  +    if {![$w was_created]} {$w do_create}
    12     12       if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
    13     13       if {[dict keys $args -row]==""} {dict set args -row 0}
    14         -    ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
    15         -    [GridState for $parent] addSlave $w {*}$args
           14  +    ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
           15  +    [::wtk::GridState for $parent] addSlave $w {*}$args
    16     16       return;
    17     17   }
    18     18   
    19     19   proc ::wtk::grid::Configure2 {cmd window args} {
    20     20       variable ::wtk::widgets
    21     21   
    22     22       set w [namespace tail $window]
    23     23       ::wtk::_VerifyWindowExists $w
    24     24       set parent [join [lrange [split $w .] 0 end-1] .]
    25     25       if {$parent eq ""} {set parent "."}
    26     26       if {![info exists widgets($parent)]} {error "no parent widget found"}
    27         -    if {![$w _created?]} {$w _create}
           27  +    if {![$w was_created]} {$w do_create}
    28     28       if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
    29     29       if {[dict keys $args -row]==""} {dict set args -row 0}
    30         -    ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
    31         -    [GridState for $parent] addSlave $w {*}$args
           30  +    ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"
           31  +    [::wtk::GridState for $parent] addSlave $w {*}$args
    32     32       return;
    33     33   }
    34     34   
    35     35   

Changes to geomanagers/wtk-grid.tcl.

     4      4       # Place a slave inside its master.  Right now this doesn't process any actual grid options. Or handle multiple widgets. Or etc.
     5      5       proc grid {w args} {
     6      6           variable widgets
     7      7           switch -exact -- $w {
     8      8               "columnconfigure" {}        
     9      9               "rowconfigure" {}
    10     10               default {
    11         -                set w [namespace tail $w]
    12         -                set parent [join [lrange [split $w .] 0 end-1] .]
    13         -                if {$parent eq ""} {set parent "."}
    14         -                if {![info exists widgets($parent)]} {error "no parent widget found"}
    15         -                if {![$w _created?]} {$w _create}
    16         -                if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
    17         -                if {[dict keys $args -row]==""} {dict set args -row 0}
    18         -                ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"     
    19         -                [GridState for $parent] addSlave $w {*}$args
    20         -                return ""   
           11  +              set w [namespace tail $w]
           12  +              set wobj ::$w
           13  +              
           14  +              puts [list grid $w [info object class $wobj]]
           15  +              
           16  +              set parent [join [lrange [split $w .] 0 end-1] .]
           17  +              if {$parent eq ""} {set parent "."}
           18  +              if {![info exists widgets($parent)]} {error "no parent widget found"}
           19  +              if {![$wobj was_created]} {$wobj do_create}
           20  +              if {[dict keys $args -column]==""} {dict set args -column 0}; # TODO - proper defaults
           21  +              if {[dict keys $args -row]==""} {dict set args -row 0}
           22  +              ###::wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"     
           23  +              [::wtk::GridState for $parent] addSlave $w {*}$args
           24  +              return ""   
    21     25               }
    22     26           }
    23     27       }
    24     28       
    25     29       # internal state kept for each master
    26         -    snit::type GridState {
    27         -        typevariable states
    28         -        typemethod for {w} {
    29         -            if {![info exists states($w)]} {set states($w) [GridState %AUTO% $w]}
    30         -            return $states($w)
           30  +    odie::class ::wtk::GridState {
           31  +
           32  +        class_method for {w} {
           33  +          my variable states
           34  +          set w [namespace tail $w]
           35  +
           36  +          if {![info exists states($w)]} {
           37  +            set states($w) [my create ::wtk::${w}#grid $w]
           38  +          }
           39  +          return $states($w)
    31     40           }
    32         -        typemethod _reset {} {foreach i [$type info instances] {$i destroy}; unset states}
           41  +        class_method _reset {} {
           42  +          my variable states
           43  +          foreach {w obj} [array get states] {
           44  +            $obj destroy
           45  +          }
           46  +          unset states
           47  +        }
    33     48           
    34     49           variable rows {}
    35     50           variable columns {}
    36     51           variable slaves ; # array
    37     52           variable tabledata {}
    38     53           variable master
    39     54           variable id
    40         -        constructor {w} {set master $w; set id [string map "obj grid" [$w id]] }
           55  +
           56  +        constructor {w} {
           57  +          set master [namespace tail $w]
           58  +          my variable rows columns tabledata master id
           59  +          set rows {}
           60  +          set columns {}
           61  +          set tabledata {}
           62  +
           63  +          set id [string map "obj grid" [$master id]]
           64  +        }
           65  +        
    41     66           method jqobj {} {return "\$('#$id')"}
    42     67           method jsobj {} {return "\$('#$id')\[0\]"}
    43         -        method _debug {} {return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]}
           68  +        method _debug {} {
           69  +          my variable rows columns tabledata master id slaves
           70  +          return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]
           71  +        }
    44     72           method addSlave {w args} {
    45         -            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
    46         -            set slaves($w) $args
    47         -            set colnum [dict get $args -column]; set rownum [dict get $args -row]
    48         -            #puts "\n        BEFORE: $tabledata  -> col=$colnum row=$rownum w=$w"
    49         -            if {$colnum ni $columns} {$self _insertColumn $colnum}
    50         -            if {$rownum ni $rows} {$self _insertRow $rownum}
    51         -            
    52         -            set colidx [lsearch $columns $colnum]; set rowidx [lsearch $rows $rownum]
    53         -            set row [lindex $tabledata $rowidx]
    54         -            #puts "             row=$row, colidx=$colidx"
    55         -            set tabledata [lreplace $tabledata $rowidx $rowidx [lreplace $row $colidx $colidx [lreplace [lindex $row $colidx] 2 2 $w]]]
    56         -            #puts "        AFTER: $tabledata\n"
    57         -            wtk::toclient "[$self jsobj].rows\[$rowidx\].cells\[$colidx\].appendChild(wtk.widgets\['[$w id]'\]);"
    58         -            return ""
           73  +          my variable rows columns tabledata master id slaves
           74  +          set w [namespace tail $w]
           75  +          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
           76  +          set slaves($w) $args
           77  +          set colnum [dict get $args -column]; set rownum [dict get $args -row]
           78  +          #puts "\n        BEFORE: $tabledata  -> col=$colnum row=$rownum w=$w"
           79  +          if {$colnum ni $columns} {
           80  +            my _insertColumn $colnum
           81  +          }
           82  +          if {$rownum ni $rows} {
           83  +            my _insertRow $rownum
           84  +          }
           85  +          
           86  +          set colidx [lsearch $columns $colnum]; set rowidx [lsearch $rows $rownum]
           87  +          set row [lindex $tabledata $rowidx]
           88  +          #puts "             row=$row, colidx=$colidx"
           89  +          set tabledata [lreplace $tabledata $rowidx $rowidx [lreplace $row $colidx $colidx [lreplace [lindex $row $colidx] 2 2 $w]]]
           90  +          #puts "        AFTER: $tabledata\n"
           91  +          ::wtk::toclient "[my jsobj].rows\[$rowidx\].cells\[$colidx\].appendChild(wtk.widgets\['[$w id]'\]);"
           92  +          return ""
    59     93           }
    60     94           method _insertColumn {colnum} {
           95  +          my variable rows columns tabledata master id slaves
           96  +          
    61     97               set columns [lsort -integer [concat $columns $colnum]]; set colidx [lsearch $columns $colnum]
    62     98               set new ""; set rowidx 0
    63     99               foreach i $tabledata {
    64    100                   lappend new [linsert $i $colidx [list $colidx 1 blank]]
    65         -                wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($colidx);"
          101  +                ::wtk::toclient "[my jsobj].rows\[$rowidx\].insertCell($colidx);"
    66    102                   incr rowidx
    67    103               }
    68    104               set tabledata $new
    69    105           }
    70    106           method _insertRow {rownum} {
    71         -            if {$tabledata==""} {wtk::toclient "wtk.newGrid('[$master id]','$id');"}
          107  +          my variable rows columns tabledata master id slaves
          108  +
          109  +            if {$tabledata==""} {::wtk::toclient "wtk.newGrid('[$master id]','$id');"}
    72    110               set rows [lsort -integer [concat $rows $rownum]]; set rowidx [lsearch $rows $rownum];
    73         -            wtk::toclient "[$self jsobj].insertRow($rowidx);"
          111  +            ::wtk::toclient "[my jsobj].insertRow($rowidx);"
    74    112               set row ""; for {set i 0} {$i<[llength $columns]} {incr i} {
    75    113                   lappend row [list $i 1 blank]
    76         -                wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($i);"
          114  +                ::wtk::toclient "[my jsobj].rows\[$rowidx\].insertCell($i);"
    77    115               }
    78    116               lappend tabledata $row
    79    117           }
    80    118       }
    81    119       
    82    120   }

Changes to lib/httpd.tcl.

   542    542   
   543    543   #	set url $data(url)
   544    544   	if {[catch {
   545    545   #	    set timer [time {
   546    546   		uplevel #0 $Httpd(responsehandler) handle $sock
   547    547   #	    }]; puts stderr "-->$timer $url"
   548    548   	} errmsg]!=0} {
          549  +          set einfo $::errorInfo
   549    550   	    Httpd_Log $sock Respond completed error $errmsg
   550    551   			if {$errmsg=="websocket"} {return}
   551    552   	    unset -nocomplain data(inprogress)
   552    553   	    if {$errmsg=="pending"} {
   553    554   		Httpd_Log $sock Respond pending
   554    555   		# we're waiting on something else to complete, so no sense having our
   555    556   		# own HttpdRead keep getting called asking us to do something with this
................................................................................
   558    559   	    } else {
   559    560   		upvar #0 Httpd$sock data
   560    561   		set url ""
   561    562   		if {[info exists data(url)]} {
   562    563   		    set url $data(url)
   563    564   		}
   564    565   		HttpdError $sock 500 "Error processing request"
   565         -		catch {bgerror "Error processing handler for $url:\n$::errorInfo"}
          566  +		catch {bgerror "Error processing handler for $url:\n$einfo"}
   566    567   	    }
   567    568   	} else {
   568    569   	    Httpd_Log $sock Respond completed ok
   569    570               if {[info exists data]  && (![info exists data(sendingfile)] || $data(sendingfile)!=1)} {
   570    571                   Httpd_Log $sock "Return had not been called during request processing; closing connection.  data=[array names data]"
   571    572                   HttpdSockDone $sock 1
   572    573               }

Changes to lib/wtk-base.tcl.

     1      1   # This code is loaded into each application instance interpreter.  It maintains state
     2      2   # for each widget, and then actually creates and manipulates widgets on the client side
     3      3   # by sending Javascript commands.  It also receives callbacks from the client side which
     4      4   # are interpreted and used to update internal widget state here, which often triggers
     5      5   # callbacks or other event bindings.
     6      6   #
     7      7   # Communication with the client is solely via the "fromclient" and "toclient" routines
     8         -# (the latter of which is setup in the wtk::init call).
            8  +# (the latter of which is setup in the ::wtk::init call).
     9      9   
    10         -package require snit
           10  +package require TclOO
    11     11   package require log
    12     12   
           13  +source odie/index.tcl
           14  +
           15  +###
           16  +# Add "option"
           17  +###
    13     18   namespace eval ::wtk {
    14     19       variable widgets
    15     20       variable wobj
    16     21       variable _nextid -1
    17     22       variable _sender ""
    18     23   
    19     24       # Initialization and communication
    20     25       proc init {sender} {
    21         -        set wtk::_sender $sender
    22         -        wtk::Widget "." ""
    23         -        return ""
           26  +      set ::wtk::_sender $sender
           27  +      ::wtk::Widget "."
           28  +      return ""
    24     29       }
    25     30   
    26     31       # for debugging
    27     32       proc _reset {} {
    28     33           variable wobj; variable widgets; variable _nextid; variable _sender
    29     34           foreach {id w} [array get wobj] {$w destroy}
    30     35           unset -nocomplain widgets
    31     36           unset -nocomplain wobj
    32     37           set _nextid -1
    33         -        GridState _reset
           38  +        ::wtk::GridState _reset
    34     39           init $_sender
    35     40           return ""
    36     41       }
    37     42   
    38         -    proc toclient {cmd} {uplevel #0 $wtk::_sender [list $cmd]}
           43  +    proc toclient {cmd} {uplevel #0 $::wtk::_sender [list $cmd]}
    39     44   
    40     45       proc fromclient {cmd} {
    41     46           switch -exact -- [lindex $cmd 0] {
    42     47               "EVENT" {
    43         -                [getwidget [lindex $cmd 1]] _event {*}[lrange $cmd 2 end]
           48  +                [getwidget [lindex $cmd 1]] wtk_event {*}[lrange $cmd 2 end]
    44     49               }
    45     50               "LOG" {
    46     51                   ::log::log [lindex $cmd 1] [lrange $cmd 2 end]
    47     52               }
    48     53           }
    49     54       }
    50     55   
    51         -
    52     56       # 'Generic' widget object, which handles routines common to all widgets like
    53     57       # assigning it an id, keeping track of whether or not its been created, etc.
    54     58       # Purely for convenience, we also include some code here that manages widgets
    55     59       # that use -text or -textvariable, though not every widget will do so.
    56     60   
    57         -    snit::type Widget {
    58         -        variable id; variable created; variable wobj; variable postcreatemsgs ""
           61  +    ::odie::class ::wtk::Widget {
           62  +        variable id
           63  +        variable tkpath
           64  +        variable created
           65  +        variable wobj
           66  +        variable postcreatemsgs
    59     67           variable propertiesDict
    60         -
    61         -        constructor {_wobj} {
    62         -            if {$_wobj==""} {
    63         -                # used for root window only
    64         -                set _wobj $self
    65         -                dict set propertiesDict class Toplevel
    66         -            }
    67         -            set wobj $_wobj
    68         -            set id obj[incr wtk::_nextid]
    69         -            dict set wtk::widgets([namespace tail $wobj]) id $id
    70         -            set wtk::wobj($id) [namespace tail $wobj]
    71         -            set created 0
    72         -        }
    73         -
    74         -        method _setProperty {propertyKey value} {
           68  +        variable options
           69  +
           70  +        constructor {new_tkpath args} {
           71  +          puts [list WIDGET [info object class [self]] $new_tkpath $args]
           72  +          my variable id tkpath postcreatemsgs created options
           73  +          set created 0
           74  +          set postcreatemsgs {}
           75  +          set tkpath $new_tkpath
           76  +          if { $tkpath eq "." } {
           77  +            # used for root window only
           78  +            dict set propertiesDict class Toplevel
           79  +          }
           80  +          set id obj[incr ::wtk::_nextid]
           81  +          set wobj [self]
           82  +          oo::objdefine [self] forward tkpath $tkpath
           83  +          #my graft tkpath $tkpath
           84  +
           85  +          dict set ::wtk::widgets($tkpath) id $id
           86  +          set ::wtk::wobj($id) [self]
           87  +          foreach {var info} [my property options] {
           88  +            set options(-$var) [dictGet $info -default]
           89  +          }
           90  +          
           91  +          my configurelist {*}$args
           92  +          return $new_tkpath
           93  +        }
           94  +        
           95  +
           96  +        class_method unknown {objname args} {
           97  +          if {[string index $objname 0] eq "."} {
           98  +            my create ::$objname $objname {*}$args
           99  +            return $objname
          100  +          }
          101  +          error "Unknown method $objname. Valid: [info class methods [info object class [self]]]"
          102  +        }
          103  +
          104  +        class_method option args {
          105  +          puts $args
          106  +        }
          107  +
          108  +        method property_set {propertyKey value} {
    75    109               dict set propertiesDict {*}$propertyKey value
    76    110               return $value;
    77    111           }
    78         -        method _hasProperty {args} {
          112  +        method property_has {args} {
    79    113               return [dict exists $propertiesDict {*}$propertyKey]
    80    114           }
    81         -        method _getProperty {args} {
          115  +        method property_get {args} {
    82    116               return [dict get $propertiesDict {*}$propertyKey]
    83    117           }
    84    118   
    85         -        method _created? {} {return $created}
    86         -        method _create {} {
    87         -            set js [$wobj _createjs]
    88         -            append js $postcreatemsgs; set postcreatemsgs ""
    89         -            wtk::toclient $js
          119  +        method was_created {} {
          120  +          my variable created
          121  +          return $created
          122  +        }
          123  +        method do_create {} {
          124  +            my variable postcreatemsgs
          125  +            set js [$wobj do_createjs]
          126  +            append js $postcreatemsgs
          127  +            set postcreatemsgs ""
          128  +            ::wtk::toclient $js
    90    129               set created 1
    91    130               return ""
    92    131           }
    93         -        method _sendWhenCreated {msg} {if {[$self _created?]} {wtk::toclient $msg} else {append postcreatemsgs $msg}}
          132  +        method action_sendWhenCreated {msg} {
          133  +          if {[my was_created]} {
          134  +            ::wtk::toclient $msg
          135  +          } else {
          136  +            my variable postcreatemsgs
          137  +            append postcreatemsgs $msg
          138  +          }
          139  +        }
          140  +        
          141  +        method configure args {
          142  +          if {[llength $args] == 1} {
          143  +            my cget [lindex $args 0]
          144  +          } else {
          145  +            my configurelist {*}$args
          146  +          }
          147  +        }
          148  +
          149  +        method configurelist args {
          150  +          my variable options
          151  +          set dat [my info options]
          152  +          
          153  +          foreach {var val} $args {
          154  +            set field  [string trimleft $var -]
          155  +            if {![dict exists $dat $field]} {
          156  +              error "Invalid option $var. Valid: [dict keys $dat]"
          157  +            }
          158  +            set info [dict get $dat $field]
          159  +            set options($var) $val
          160  +            if {[dict exists $info -configuremethod]} {
          161  +              my [dict get $info -configuremethod] $var $val
          162  +            }
          163  +          }
          164  +        }
          165  +
          166  +        method cget field {
          167  +          my variable options
          168  +          set field [string trimleft $field -]
          169  +
          170  +          if {![info exists options(-$field)]} {
          171  +            set dat [my info options]
          172  +            if {![dict exists $dat $field]} {
          173  +              error "Invalid option -$field. Valid: [dict keys $dat]"
          174  +            }
          175  +            set info [dict get $dat $field]
          176  +            set options(-$field) [dictGet $info -default]
          177  +          }
          178  +          return $options(-$field)
          179  +        }
    94    180   
    95    181   
    96    182           method id {} {return $id}
    97         -        method jqobj {} {return "\$('#[$self id]')"}
    98         -        method jsobj {} {return "wtk.widgets\['[$self id]'\]"}
    99         -        method _focus {} {toclient "[$self jsobj].focus();"}
          183  +        method jqobj {} {return "\$('#[my id]')"}
          184  +        method jsobj {} {return "wtk.widgets\['[my id]'\]"}
          185  +        method event_focus {} {toclient "[my jsobj].focus();"}
   100    186   
   101         -        # text variable handling; only relevant if the main types delegate these options to us
   102         -        option -text -configuremethod _textchanged
   103         -        option -textvariable -configuremethod _textvarset
   104         -        method _textchanged {opt txt {fromwidget 0}} {
   105         -            set options($opt) $txt;
   106         -            if {$created && !$fromwidget} {wtk::toclient [$wobj _textchangejs $txt]}
   107         -            if {$options(-textvariable)!=""} {uplevel #0 set $options(-textvariable) [list $txt]}
   108         -        }
   109         -        method _textvariablechanged {args} {
   110         -            if {$options(-text) ne [uplevel #0 set $options(-textvariable)]} {
   111         -                $self _textchanged -text [uplevel #0 set $options(-textvariable)]
   112         -            }
   113         -        }
   114         -        method _setuptextvar {} {
   115         -            if {$options(-textvariable)!=""} {
   116         -                if {![uplevel #0 info exists $options(-textvariable)]} {
   117         -                    uplevel #0 set $options(-textvariable) [list $options(-text)]
   118         -                } else {
   119         -                    set options(-text) [uplevel #0 set $options(-textvariable)]
   120         -                }
   121         -                uplevel #0 trace add variable $options(-textvariable) write [list [list $self _textvariablechanged]]
   122         -            }
   123         -        }
   124         -        method _textvarset {opt var} {
   125         -            set options($opt) $var
   126         -            $self _setuptextvar
   127         -        }
   128    187   
   129    188   
   130    189           # TODO - variable handling; only relevant if -variable option is delegated to us
   131    190   
   132    191   
   133    192           # bindings
   134    193           variable bindings
   135         -        method _bind {ev script} {set bindings($ev) $script}
   136         -        method _fireevent {ev subs} {if {[info exists bindings($ev)]} {uplevel #0 [string map $subs $bindings($ev)]}}
          194  +        method action_bind {ev script} {set bindings($ev) $script}
          195  +        method event_fire {ev subs} {if {[info exists bindings($ev)]} {uplevel #0 [string map $subs $bindings($ev)]}}
          196  +    }
          197  +
          198  +    ::odie::class ::wtk::LabelWidget {
          199  +      superclass ::wtk::Widget
          200  +      
          201  +      
          202  +      # text variable handling; only relevant if the main types delegate these options to us
          203  +      option -text -configuremethod event_textchanged
          204  +      option -textvariable -configuremethod event_textvarset
          205  +      
          206  +      method event_textchanged {opt txt {fromwidget 0}} {
          207  +        my variable created options
          208  +        set options($opt) $txt
          209  +        if {$created && !$fromwidget} {
          210  +          ::wtk::toclient [my _textchangejs $txt]
          211  +        }
          212  +        
          213  +        if {$options(-textvariable)!=""} {
          214  +          uplevel #0 set $options(-textvariable) [list $txt]
          215  +        }
          216  +      }
          217  +      method event_textvariablechanged {args} {
          218  +        my variable options
          219  +        if {$options(-text) ne [uplevel #0 set $options(-textvariable)]} {
          220  +            my event_textchanged -text [uplevel #0 set $options(-textvariable)]
          221  +        }
          222  +      }
          223  +      method event_setuptextvar {} {
          224  +        my variable options
          225  +        if {$options(-textvariable)!=""} {
          226  +            if {![uplevel #0 info exists $options(-textvariable)]} {
          227  +                uplevel #0 set $options(-textvariable) [list $options(-text)]
          228  +            } else {
          229  +                set options(-text) [uplevel #0 set $options(-textvariable)]
          230  +            }
          231  +            uplevel #0 trace add variable $options(-textvariable) write [list [list [self] event_textvariablechanged]]
          232  +        }
          233  +      }
          234  +      method event_textvarset {opt var} {
          235  +        my variable options
          236  +        set options($opt) $var
          237  +        my event_setuptextvar
          238  +      }
          239  +
   137    240       }
   138    241   
   139         -    proc getwidget {id} {return $wtk::wobj($id)}
          242  +    proc getwidget {id} {return $::wtk::wobj($id)}
   140    243   
   141    244       proc _VerifyWindowExists {window} {
   142    245           variable widgets
   143    246   
   144    247           if {![info exists ::wtk::widgets([string trimleft $window])]} {
   145    248               return \
   146    249                   -code error \
   147    250                   -level 2 \
   148    251                   [format {bad window path name "%1$s"} $window]
   149    252           }
   150    253           return;
   151    254       }
   152    255   
   153         -    proc focus {w} {$w _focus; return ""}
   154         -    proc bind {w ev script} {return [$w _bind $ev $script]}
          256  +    proc focus {w} {$w event_focus; return ""}
          257  +    proc bind {w ev script} {return [$w action_bind $ev $script]}
   155    258   
   156    259       # Macro that can be used to simplify the definition of any widget
   157         -    snit::macro _wtkwidget {args} {
          260  +    ::odie::macro _wtkwidget {args} {
   158    261           component W; delegate method * to W; set extrainits ""
   159         -        if {"-usetextvar" in $args} {delegate option -textvariable to W; delegate option -text to W; set extrainits {$W _setuptextvar}}
          262  +        if {"-usetextvar" in $args} {delegate option -textvariable to W; delegate option -text to W; set extrainits {$W event_setuptextvar}}
   160    263           constructor {args} "install W using Widget \$\{selfns\}::W \$self; \$self configurelist \$args; $extrainits"
   161    264       }
   162    265   
   163    266   
   164    267       # Macro used to define options which set their value and then send some Javascript command to the widget
   165         -    snit::macro _wtkoption {opt default msg} {
          268  +    ::odie::macro _wtkoption {opt default msg} {
   166    269           option $opt -default $default -configuremethod _wtkoption$opt
   167         -        method _wtkoption$opt {opt val} "set options(\$opt) \$val; set JS \[\$self jsobj\]; set V \$val; \$self _sendWhenCreated \[subst [list $msg]\]"
          270  +        method _wtkoption$opt {opt val} "
          271  +        my variable options
          272  +        set opt [string trimleft $opt -]
          273  +        set options(\$opt) \$val
          274  +        set JS \[my jsobj\]
          275  +        set V \$val
          276  +        my action_sendWhenCreated \[subst [list $msg]\]
          277  +        "
   168    278       }
   169    279   
   170    280   }
   171    281   
   172    282   
   173    283   foreach file [glob -- commands/*.tcl] {
   174    284       source $file
   175    285   }
   176    286   foreach file [glob -- geomanagers/*.tcl] {
   177    287       source $file
   178    288   }
   179    289   source widgets/wtk-widgets.tcl

Added odie/codebale.tcl.

            1  +###
            2  +# codebale.tcl
            3  +#
            4  +# This file defines routines used to bundle and manage Tcl and C
            5  +# code repositories
            6  +#
            7  +# Copyright (c) 2012 Sean Woods
            8  +#
            9  +# See the file "license.terms" for information on usage and redistribution of
           10  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           11  +###
           12  +
           13  +::namespace eval ::codebale {}
           14  +
           15  +::namespace eval ::codebale::parse {}
           16  +
           17  +###
           18  +# topic: a5992c7f-8340-ba02-d40e-386aac95b1b8
           19  +# description: Records an alias for a Tcl keyword
           20  +###
           21  +proc ::codebale::alias {alias cname} {
           22  +  variable cnames
           23  +  set cnames($alias) $cname
           24  +}
           25  +
           26  +###
           27  +# topic: 0e883f35-83c0-ccd3-eddc-6b297ac2ea77
           28  +###
           29  +proc ::codebale::buffer_append {varname args} {
           30  +  upvar 1 $varname result
           31  +  if {![info exists result]} {
           32  +    set result {}    
           33  +  }
           34  +  if {[string length $result]} {
           35  +    set result [string trimright $result \n]
           36  +    append result \n
           37  +  }
           38  +  set priorarg {}
           39  +  foreach arg $args {
           40  +    if {[string length [string trim $arg]]==0} continue
           41  +    #if {[string match $arg $priorarg]} continue
           42  +    set priorarg $arg
           43  +    append result \n [string trim $arg \n] \n
           44  +  }
           45  +  set result [string trim $result \n]
           46  +  append result \n
           47  +  return $result
           48  +}
           49  +
           50  +###
           51  +# topic: 926c564a-a678-8498-6f74-89f37da3fb32
           52  +###
           53  +proc ::codebale::buffer_merge args {
           54  +  set result {}
           55  +  set priorarg {}
           56  +  foreach arg $args {
           57  +    if {[string length [string trim $arg]]==0} continue
           58  +    if {[string match $arg $priorarg]} continue
           59  +    set priorarg $arg
           60  +    append result [string trim $arg \n] \n
           61  +  }
           62  +  set result [string trim $result \n]
           63  +  return $result
           64  +}
           65  +
           66  +###
           67  +# topic: c1e66f4a-20e3-97a5-d254-1714575c165f
           68  +###
           69  +proc ::codebale::buffer_puts {varname args} {
           70  +  upvar 1 $varname result
           71  +  if {![info exists result]} {
           72  +    set result {}    
           73  +  }
           74  +  set result [string trimright $result \n]
           75  +  #if {[string length $result]} {
           76  +  #  set result [string trimright $result \n]
           77  +  #}
           78  +  set priorarg {}
           79  +  foreach arg $args {
           80  +    #if {[string length [string trim $arg]]==0} continue
           81  +    #if {[string match $arg $priorarg]} continue
           82  +    #set priorarg $arg
           83  +    append result \n $arg
           84  +    #[string trim $arg \n]
           85  +  }
           86  +  #set result [string trim $result \n]
           87  +  #append result \n
           88  +  return $result
           89  +}
           90  +
           91  +###
           92  +# topic: 951f31f2-cb24-992f-34d9-7e3deb16b43f
           93  +# description: Reports back the canonical name of a tcl keyword
           94  +###
           95  +proc ::codebale::canonical alias {
           96  +  variable cnames
           97  +  if {[info exists cnames($alias)]} {
           98  +    return $cnames($alias)
           99  +  }
          100  +  return $alias
          101  +}
          102  +
          103  +###
          104  +# topic: b1e5e6ca-f0bf-9e78-695f-995a35af7c2f
          105  +# description: Provide a keyword handler to the autodoc parser
          106  +###
          107  +proc ::codebale::define {name info} {
          108  +  global cmdref
          109  +  foreach {var val} $info {
          110  +      dict set cmdref($name) $var $val
          111  +  }
          112  +}
          113  +
          114  +###
          115  +# topic: 9cca11ca-4447-43a3-21d3-ad5ac85538b1
          116  +# description:
          117  +#    A simpler implementation of digest_comment, this proc
          118  +#    takes in the raw buffer and returns a dict of the annotations
          119  +#    it found
          120  +###
          121  +proc ::codebale::digest_comment {buffer {properties {}}} {
          122  +  set result(description) {}
          123  +  set appendto description
          124  +  
          125  +  foreach line [split $buffer \n] {
          126  +    set line [string trimleft [string range $line [string first # $line] end] #]
          127  +    set line [string trimright [string trim $line] -]
          128  +    if [catch {lindex $line 0} token] {
          129  +      append result($appendto) $line \n
          130  +      #set result($appendto) [buffer_merge $result($appendto) $line]
          131  +      continue
          132  +    }
          133  +    if {[string index $token end] ne ":"} {
          134  +      append result($appendto) $line \n
          135  +      #buffer_puts result($appendto) $line
          136  +    } else {
          137  +      set field [string tolower [string trimright $token :]]
          138  +      switch $field {
          139  +        topic {
          140  +          set result(topic) [lrange $line 1 end]
          141  +          append result(description) \n
          142  +          set appendto description
          143  +        }
          144  +        comment -
          145  +        desc -
          146  +        description {
          147  +          #append result(description) [lrange $line 1 end] \n
          148  +          set result(description) [buffer_merge $result(description) [lrange $line 1 end]]
          149  +          append result(description) \n
          150  +          set appendto description
          151  +        }
          152  +        title -
          153  +        headline {
          154  +          set result(title) [lrange $line 1 end]
          155  +          append result(description) \n
          156  +          set appendto description          
          157  +        }
          158  +        ensemble_method {
          159  +          set result(type) proc
          160  +          append result(description) \n
          161  +          set appendto description
          162  +        }
          163  +        ensemble -
          164  +        nspace -
          165  +        namespace -
          166  +        class -
          167  +        agent_class -
          168  +        task -
          169  +        subtask -
          170  +        method -
          171  +        class_function -
          172  +        class_method -
          173  +        phase -
          174  +        function -
          175  +        action {
          176  +          set result(type) $field
          177  +          set result(arglist) [lrange $field 1 end]
          178  +          append result(description) \n
          179  +          set appendto description
          180  +         }
          181  +        default {
          182  +          set result($field) [lrange $line 1 end]
          183  +          append result($field) \n
          184  +          set appendto $field
          185  +        }
          186  +      }
          187  +    }
          188  +  }
          189  +  foreach {field} [array names result] {
          190  +    set result($field) [string trim $result($field)]
          191  +  }
          192  +  return [array get result]
          193  +}
          194  +
          195  +###
          196  +# topic: c0304a04-9be6-f312-06a0-2d15813720ce
          197  +###
          198  +proc ::codebale::meta_output outfile {
          199  +  set fout [open $outfile w]
          200  +  puts "SAVING TO $outfile"
          201  +  
          202  +  #puts $fout "array set filemd5 \x7b"
          203  +  #array set temp [array get ::filemd5]
          204  +  #foreach {file md5} [lsort -dictionary [array names temp]] {
          205  +  #  set md5 $temp($file)
          206  +  #  puts $fout "    [list $file $md5]"
          207  +  #}
          208  +  #array unset temp
          209  +  #puts $fout "\x7d"
          210  +  puts $fout "helpdoc eval {begin transaction}"
          211  +  helpdoc eval {
          212  +    select handle,localpath from repository
          213  +  } {
          214  +    puts $fout [list ::helpdoc repository_restore $handle [list localpath $localpath]]
          215  +  }
          216  +  helpdoc eval {
          217  +    select hash,fileid from file
          218  +  } {
          219  +    puts $fout [helpdoc file_serialize $fileid]
          220  +  }
          221  +  puts $fout [helpdoc node_serialize 0]
          222  +  helpdoc eval {
          223  +    select entryid from entry
          224  +    where class='section'
          225  +    order by name
          226  +  } {
          227  +    puts $fout [helpdoc node_serialize $entryid]
          228  +  }
          229  +  helpdoc eval {
          230  +    select entryid from entry
          231  +    where class!='section'
          232  +    order by parent,class,name
          233  +  } {
          234  +    puts $fout [helpdoc node_serialize $entryid]
          235  +  }
          236  +  puts $fout "helpdoc eval {commit}"
          237  +  close $fout
          238  +}
          239  +
          240  +###
          241  +# topic: cd6e815c-2e68-b751-656a-4c9bbe8918dd
          242  +# description: Filters extranous fields from meta data
          243  +###
          244  +proc ::codebale::meta_scrub {aliases info} {
          245  +  foreach {c alist} $aliases {
          246  +    foreach a $alist {
          247  +      set canonical($a) $c
          248  +    }
          249  +  }
          250  +
          251  +  set outfo {}
          252  +  foreach {field val} $info {
          253  +    if {[info exists canonical($field)]} {
          254  +      set cname $canonical($field)
          255  +    } else {
          256  +      set cname $field
          257  +    }
          258  +    if {$cname eq {}} continue
          259  +    if {[string length [string trim $val]]} {
          260  +      dict set outfo $cname $val
          261  +    }
          262  +  }
          263  +  return $outfo
          264  +}
          265  +
          266  +###
          267  +# topic: ead7e6fe-5660-70cc-79f0-eb2f5182465e
          268  +###
          269  +proc ::codebale::normalize_tabbing {rawblock {newspace 0}} {
          270  +  set result {}
          271  +  ###
          272  +  # clean up spaces
          273  +  ###
          274  +  set block [string map [list \t "    "] $rawblock]
          275  +  
          276  +  set spaces -1
          277  +  while {[string index $block [incr spaces]] eq " " } {}
          278  +  if { $spaces < 0} {
          279  +    return $rawblock
          280  +  }
          281  +  set count 0
          282  +  foreach line [split $block \n] {
          283  +    if {[string first " " $line] > 0} {
          284  +      set spaces -1
          285  +      break
          286  +    }
          287  +    incr count
          288  +    set i [string last " " $line]
          289  +    if { ($i+1) < $spaces } {
          290  +      set spaces [expr $i + 1]
          291  +    }
          292  +  }
          293  +  if {$spaces <= 0} {
          294  +    return $rawblock
          295  +  }
          296  +  set head [string repeat " " $newspace]
          297  +  foreach line [split $block \n] {
          298  +    append result $head [string range $line $spaces end] \n
          299  +  }
          300  +  return $result
          301  +}
          302  +
          303  +###
          304  +# topic: a6ee7ffd-7430-c9cc-d666-9addf08fd039
          305  +# description:
          306  +#    Parses a script, namespace body, or class
          307  +#    definition.
          308  +###
          309  +proc ::codebale::parse_body {meta body modvar} {
          310  +  
          311  +  upvar 1 $modvar match
          312  +  set match 0
          313  +  set patterns [parser_patterns [dictGet $meta scope]]
          314  +  foreach {pat info} $patterns {
          315  +    if {[regexp $pat $body]} {
          316  +      set match 1
          317  +      break
          318  +    }      
          319  +  }
          320  +
          321  +  ###
          322  +  # Pass through if we don't see any patterns to match
          323  +  ###
          324  +  if {!$match} {
          325  +    return [list body $body]
          326  +  }
          327  +  
          328  +  set thisline {}
          329  +  set thiscomment {}
          330  +  set incomment 0
          331  +  set linecount 0
          332  +  set inheader 1
          333  +
          334  +  array set result {
          335  +    namespace {}
          336  +    header    {}
          337  +    body      {}
          338  +    command   {}
          339  +    comment   {}
          340  +  }
          341  +  dict set meta comment {}
          342  +
          343  +  foreach line [split $body \n] {
          344  +    append thisline \n $line
          345  +    if {![info complete $thisline]} continue
          346  +    
          347  +    set parseline [string range $thisline 1 end]
          348  +    set thisline {}
          349  +
          350  +    if { $incomment } {
          351  +      if {[string index [string trimleft $parseline] 0] ne "#"} {
          352  +        set incomment 0
          353  +        set thiscomment [string trimright $thiscomment \n]
          354  +      } else {
          355  +        append thiscomment $parseline \n
          356  +        continue
          357  +      }
          358  +    } elseif {[string index [string trimleft $parseline] 0] eq "#"} {
          359  +      set incomment 1
          360  +      if {$inheader} {
          361  +        if {[string length $thiscomment]} {
          362  +          append result(header) $thiscomment \n
          363  +        }
          364  +      } else {
          365  +        if {[string length $thiscomment]} {
          366  +          append result(body) $thiscomment \n
          367  +        }
          368  +      }
          369  +      set thiscomment {}
          370  +      append thiscomment $parseline \n
          371  +      continue     
          372  +    }
          373  +    
          374  +    set cmd [pattern_match $patterns $parseline]
          375  +    if {$cmd eq {}} {
          376  +      set var body
          377  +      if {$inheader} {
          378  +        set var header
          379  +      } else {
          380  +        set var body
          381  +      }    
          382  +      if {[string length $thiscomment]} {
          383  +        append result($var) [string trimright $thiscomment \n] \n
          384  +        set thiscomment {}
          385  +      }
          386  +      append result($var) $parseline \n
          387  +    } else {
          388  +      set inheader 0
          389  +      set info $meta
          390  +      dict set info comment [string trim $thiscomment]
          391  +      if {[catch {{*}$cmd $info $parseline} lresult]} {
          392  +        puts "Error: [list {*}$cmd $info $parseline]"
          393  +        puts "$lresult"
          394  +        puts $::errorInfo
          395  +        exit
          396  +        error DIE
          397  +      }
          398  +      foreach {type info} $lresult {
          399  +        switch $type {
          400  +          header - body {
          401  +            #append result($type) $info \n
          402  +            buffer_append result($type) $info
          403  +          }
          404  +          command {
          405  +            foreach {pname pinfo} $info {
          406  +              dict set result($type) $pname $pinfo           
          407  +            }
          408  +          }
          409  +          namespace {
          410  +            logicset add result(namespace) {*}$info
          411  +          }
          412  +          default {
          413  +            append result($type) $info \n
          414  +          }
          415  +        }
          416  +      }
          417  +    }
          418  +    set thiscomment {}
          419  +  }
          420  +  return [array get result]
          421  +}
          422  +
          423  +###
          424  +# topic: a18c5371-2559-4150-a50c-0a21013ba712
          425  +# description:
          426  +#    Parses a namespace and redeclares any procs as
          427  +#    glob procs pointing to the current namespace
          428  +###
          429  +proc ::codebale::parse_namespace {meta def} {
          430  +  global cmdref base block fileinfo
          431  +  set nspace [lindex $def end-1]
          432  +  set body [lindex $def end]
          433  +
          434  +  set nspace [string trim $nspace :]
          435  +  if { $nspace eq {} } {
          436  +    set Nspace Global
          437  +  } else {
          438  +    set Nspace $nspace
          439  +  }
          440  +  set thisline {}
          441  +  array set result {
          442  +    command {}
          443  +    body    {}
          444  +    header  {}
          445  +  }
          446  +  
          447  +  dict set aliases {} [list topic subtopic proc namespace nspace class arglist method]
          448  +  set info [digest_comment [dict get $meta comment] $meta]
          449  +  set info [meta_scrub $aliases $info]
          450  +  dict set info type namespace
          451  +  
          452  +  helpdoc node_define namespace $Nspace $info nodeid
          453  +  set result(meta) [helpdoc node_properties $nodeid]
          454  +
          455  +  set comment         [rewrite_comment 0 $nodeid $result(meta)]
          456  +
          457  +  array set result [parse_body [list {*}$meta namespace $nspace parent $nodeid] $body mod]
          458  +  buffer_append newbody [get result(header)] [get result(body)]
          459  +  set result(header) {}
          460  +
          461  +  if {[string length [string trim $newbody]]} {
          462  +    set result(body) [buffer_merge $comment "[list namespace eval ::$nspace] \{\n$newbody\}"]
          463  +  } else {
          464  +    logicset add result(namespace) $nspace
          465  +    set result(body) {}
          466  +    #[dict get $meta comment]
          467  +  }
          468  +  set result(comment) $comment
          469  +  return [array get result]
          470  +}
          471  +
          472  +###
          473  +# topic: bab541dc-7ab2-5960-b7b3-75553ef388aa
          474  +###
          475  +proc ::codebale::parse_ooclass {meta def} {
          476  +  set nspace [lindex $def end-1]
          477  +  set body   [lindex $def end]
          478  +
          479  +  set nspace [string trim $nspace :]
          480  +  
          481  +  set thisline {}
          482  +  array set result {
          483  +    command {}
          484  +    body    {}
          485  +    header  {}
          486  +  }
          487  +  
          488  +  set info [digest_comment [dict get $meta comment] $meta]
          489  +  dict set aliases {} [list topic subtopic proc namespace nspace class arglist method]
          490  +  set info [meta_scrub $aliases $info]
          491  +  dict set info type class
          492  +  helpdoc node_define class $nspace $info nodeid
          493  +  set result(meta)    [helpdoc node_properties $nodeid]
          494  +  set comment         [rewrite_comment 0 $nodeid $result(meta)]
          495  +  
          496  +  ###
          497  +  # Write in the results
          498  +  ###
          499  +  array set result [parse_body [list {*}$meta class $nspace parent $nodeid scope ooclass] $body mod]
          500  +  buffer_append newbody [get result(header)] [get result(body)]
          501  +  set result(header) {}
          502  +  foreach {mname} [lsort -dictionary [dict keys $result(command)]] {
          503  +    buffer_append newbody [dict get $result(command) $mname]
          504  +  }
          505  +  unset result(command)
          506  +
          507  +  set result(body) [buffer_merge $comment "[list {*}[lrange $def 0 end-1]] \{\n$newbody\}"]
          508  +  set result(comment) $comment
          509  +  return [array get result]
          510  +}
          511  +
          512  +###
          513  +# topic: 16fbb45b-8e9a-a13b-0b89-2270fd7537ff
          514  +# description:
          515  +#    This procedure reads in the definition of a method,
          516  +#    marks it up in the help documentation, and seeds the
          517  +#    re-writer so that this method is creates in sorted order
          518  +###
          519  +proc ::codebale::parse_oomethod {meta def} {
          520  +  set token    [lindex $def 0]
          521  +  if {[string range $token 0 5]=="class_"} {
          522  +    set cmd "class_method"
          523  +    set class class_method
          524  +  } else {
          525  +    set cmd "method"
          526  +    set class method
          527  +  }
          528  +  set def "  [list $cmd {*}[lrange $def 1 end-1]] \{[lindex $def end]\}"
          529  +  set def [normalize_tabbing $def 2]
          530  +
          531  +  set token    [lindex $def 0]
          532  +  set procname [string trim [lindex $def 1] :]
          533  +  set fullname [string trimleft $class :]::$procname
          534  +  if {[llength $def] < 4} {
          535  +    set arglist dictargs
          536  +    set darglist dictargs
          537  +    set body [lindex $def 3]
          538  +  } else {
          539  +    set arglist [lindex $def 2]
          540  +    set body [lindex $def 4]
          541  +    ###
          542  +    # Clean up args
          543  +    ###
          544  +    set darglist {}
          545  +    foreach n $arglist {
          546  +      if [catch {
          547  +      if {[llength $n] > 1} {
          548  +        lappend darglist "?[lindex $n 0]?"
          549  +      } else {
          550  +        lappend darglist [lindex $n 0]
          551  +      }
          552  +      } err] {
          553  +        lappend darglist $n
          554  +      }
          555  +    }
          556  +  }
          557  +  
          558  +  ###
          559  +  # Document
          560  +  ###
          561  +  set info [digest_comment [dict get $meta comment] $meta]
          562  +  set type [dictGet $info type]
          563  +
          564  +  if {$type eq {}} {
          565  +    set type [string trim $token :]
          566  +    if { $type ne "method" } {
          567  +      dict set info type $type
          568  +    }
          569  +  }
          570  +  
          571  +  dict set aliases returns {return yields}
          572  +  dict set aliases {} [list topic subtopic proc namespace nspace class arglist method $type]
          573  +  set info [meta_scrub $aliases $info]
          574  +  dict set info type $type
          575  +  dict set info arglist $darglist
          576  +  helpdoc node_define_child [dictGet $meta parent] $class $procname $info nodeid
          577  +  set result(meta)    [helpdoc node_properties $nodeid]
          578  +  set result(comment) [rewrite_comment 2 $nodeid $result(meta)]
          579  +
          580  +  set result(command) $def
          581  +  return [list command [list ${class}::${procname} [buffer_merge $result(comment) $result(command)]]]
          582  +}
          583  +
          584  +###
          585  +# topic: 2e9b9100-a28c-1d6d-d421-95779706ad24
          586  +# description:
          587  +#    This procedure reads in the definition of a method,
          588  +#    marks it up the ancestors for this object
          589  +###
          590  +proc ::codebale::parse_oosuperclass {meta def} {
          591  +  set parentid [dictGet $meta parent]
          592  +  foreach class [lrange $def 1 end] {
          593  +    set ancestor [helpdoc node_id [list class $class] 1]
          594  +    helpdoc link_create $parentid $ancestor class_ancestor
          595  +  }
          596  +  return [list header $def]
          597  +}
          598  +
          599  +###
          600  +# topic: 0360b378-6857-5d30-2ab6-f15e88365266
          601  +###
          602  +proc ::codebale::parse_path {info base args} {
          603  +  set rewrite 0
          604  +  set repo    source
          605  +  dict with info {}
          606  +
          607  +  set pathlist $args
          608  +  if {[llength $pathlist]==0} {
          609  +    set pathlist $base
          610  +  }
          611  +  
          612  +  set stack {}
          613  +  foreach path $pathlist {
          614  +    stack push stack $path
          615  +  }
          616  +  set filelist {}
          617  +  while {[stack pop stack stackpath]} {
          618  +    lappend filelist {*}[sniffPath $stackpath stack]
          619  +  }
          620  +  set meta [list repo $repo rewrite $rewrite base $base]
          621  +  if {![helpdoc exists {select localpath from repository where handle=:repo}]} {
          622  +    helpdoc eval {insert into repository (handle,localpath) VALUES (:repo,:base);}
          623  +  } else {
          624  +    helpdoc eval {update repository set localpath=:base where handle=:repo;}
          625  +  }
          626  +  foreach {type file} $filelist {
          627  +    switch $type {
          628  +      parent_name -
          629  +      source {
          630  +        if { [file tail $file] in {version_info.tcl packages.tcl lutils.tcl}} continue
          631  +        if {[catch {
          632  +          parse_tclsourcefile $meta $file $rewrite
          633  +        } err]} {
          634  +          puts [list $file $err]
          635  +          puts $::errorInfo
          636  +          if {[file exists $file.new]} {
          637  +            puts "X $file.new"
          638  +            file delete $file.new
          639  +          }
          640  +        }
          641  +      }
          642  +      csource {
          643  +        if {[catch {
          644  +          read_csourcefile $file
          645  +        } err]} {
          646  +          puts [list $file $err]
          647  +        }
          648  +      }
          649  +      index {
          650  +        continue
          651  +      }
          652  +    }
          653  +  }
          654  +}
          655  +
          656  +###
          657  +# topic: 70a6c102-860a-d996-77f3-c4f2021a5308
          658  +# description:
          659  +#    This procedure reads in the definition of a procedures,
          660  +#    marks it up in the help documentation, and seeds the
          661  +#    re-writer so that this procedure is defined from the
          662  +#    global namespace
          663  +###
          664  +proc ::codebale::parse_procedure {meta def} {
          665  +  set def [normalize_tabbing $def]
          666  +
          667  +  foreach {token procname arglist body} $def break;
          668  +  set rawproc $procname
          669  +  set proc [namespace tail $procname]
          670  +  set nspace [string trimleft [proc_nspace $rawproc] :]
          671  +  if { $nspace eq {} } {
          672  +    set nspace [dictGet $meta namespace]
          673  +  }
          674  +  if {$nspace in {{} ::}} {
          675  +    set fullname [string trim $proc :]
          676  +  } else {
          677  +    set fullname ${nspace}::${proc}
          678  +  }
          679  +  set result(namespace) $nspace
          680  +  set result(command) [list $token ::$fullname $arglist]
          681  +  append result(command) " \{$body\}"
          682  +
          683  +  ###
          684  +  # Document
          685  +  ###
          686  +  set type [string trim $token :]
          687  +  dict set aliases yields return
          688  +  dict set aliases {} [list topic subtopic proc namespace nspace class arglist $type]
          689  +
          690  +  set info [digest_comment [dict get $meta comment] $meta]
          691  +  set info [meta_scrub $aliases $info]
          692  +  
          693  +  dict set info type $type
          694  +  ###
          695  +  # Clean up args
          696  +  ###
          697  +  set darglist {}
          698  +  foreach n $arglist {
          699  +    if {[llength $n] > 1} {
          700  +      lappend darglist "?[lindex $n 0]?"
          701  +    } else {
          702  +      lappend darglist [lindex $n 0]
          703  +    }
          704  +  }
          705  +  dict set info arglist $darglist
          706  +
          707  +  helpdoc node_define proc $fullname $info nodeid
          708  +  set result(meta) [helpdoc node_properties $nodeid]
          709  +  set result(comment) [rewrite_comment 0 $nodeid $result(meta)]
          710  +
          711  +  return [list command [list $fullname [buffer_merge $result(comment) $result(command)]] namespace $result(namespace)]
          712  +}
          713  +
          714  +###
          715  +# topic: 7c9f9cea-7829-7eef-903b-3f711033a993
          716  +###
          717  +proc ::codebale::parse_tclsourcefile {meta file {rewrite 0}} {
          718  +  global classes block filename fileinfo
          719  +  variable parser_patterns
          720  +  array unset filestore
          721  +  
          722  +  dict with meta {}
          723  +
          724  +  set i [string length $base]
          725  +
          726  +  set fname [file rootname [file tail $file]]
          727  +  set dir [string trimleft [string range [file dirname $file] $i end] /]
          728  +  set fpath $dir/[file tail $file]
          729  +  set filename $dir/[file tail $file]
          730  +
          731  +  set repomd5 [helpdoc file_hash [list $repo $fpath]]
          732  +  set md5 [::md5::md5 -hex -file $file]
          733  +  
          734  +  if {!$::force_check} {
          735  +    if { $md5 eq $repomd5} { return 0 }
          736  +  }
          737  +  
          738  +  set info {}
          739  +  dict set info mtime [file mtime $file]
          740  +  dict set info hash  $md5
          741  +  dict set info path  $fpath
          742  +  dict set info filename [file tail $file]
          743  +  dict set info repo  $repo
          744  +  helpdoc file_restore [list $repo $fpath] $info
          745  +  
          746  +  #set ::filemd5($fpath) $md5
          747  +  
          748  +  set fin [open $file r]
          749  +  set dat [read $fin]
          750  +  close $fin
          751  +  
          752  +  puts "<< $fpath"
          753  +  set fileinfo {}
          754  +  set result [parse_body [list namespace {} file $file] $dat patmatch]
          755  +  if {!$rewrite || !$patmatch} {
          756  +    return $patmatch
          757  +  }
          758  +  ###
          759  +  # Rewrite the tcl sourcefile
          760  +  ###
          761  +  set buffer {}
          762  +
          763  +  set ndefined {}
          764  +  set header {}
          765  +  set body {}
          766  +  set command {}
          767  +  set namespace {}
          768  +  set buffer {}
          769  +  dict with result {}
          770  +  buffer_append buffer $header
          771  +  foreach ns [lsort -dictionary $namespace] {
          772  +    if { $ns ne {} } {
          773  +      append buffer \n [list ::namespace eval ::$ns {}] \n
          774  +    }
          775  +  }  
          776  +  if {[llength $command]} {
          777  +    foreach {nsproc} [lsort -dictionary [dict keys $command]] {
          778  +      buffer_append buffer [dict get $command $nsproc]
          779  +    }
          780  +  }
          781  +  buffer_append buffer $body
          782  +
          783  +  set oldlines [split $dat \n]
          784  +  set newlines [split $buffer \n]
          785  +  set idx -1
          786  +  set identical 1
          787  +  foreach oldline $oldlines {
          788  +    set newline [lindex $newlines [incr idx]]
          789  +    if {[string trim $oldline] ne [string trim $newline]} {
          790  +      set identical 0
          791  +      break
          792  +    }
          793  +  }
          794  +  if {$identical} {
          795  +    if {[file exists $file.new]} {
          796  +      puts "~ $file.new"
          797  +      file delete $file.new
          798  +    }
          799  +    return $patmatch
          800  +  }
          801  +  puts ">> $fpath.new"
          802  +  set fout [open $file.new w]
          803  +  fconfigure $fout -translation crlf
          804  +  puts $fout $buffer
          805  +  close $fout
          806  +  return $patmatch
          807  +}
          808  +
          809  +###
          810  +# topic: 233756d1-a3b7-6fa9-3023-ccae156e0ec5
          811  +###
          812  +proc ::codebale::parser_addpattern args {
          813  +  variable parser_patterns
          814  +  dict set parser_patterns {*}$args
          815  +}
          816  +
          817  +###
          818  +# topic: d086f779-79bd-e4d7-f60d-41af050c529d
          819  +###
          820  +proc ::codebale::parser_patterns scope {
          821  +  variable parser_patterns
          822  +  set result {}
          823  +  foreach {pat info} [dictGet $parser_patterns $scope] {
          824  +    dict set result $pat $info
          825  +  }
          826  +  return $result
          827  +}
          828  +
          829  +###
          830  +# topic: 6fd968f4-2730-f701-c0fa-3ca32b8f7785
          831  +###
          832  +proc ::codebale::pattern_match {patterns parseline} {
          833  +  set parseline [string trimleft $parseline :]
          834  +  foreach {pat patinfo} $patterns {
          835  +    set idx -1
          836  +    set match 1
          837  +    foreach a $pat {
          838  +      incr idx
          839  +      if [catch {lindex $parseline $idx} token] {
          840  +        set match 0
          841  +        break
          842  +      }
          843  +      if {![string match $token $a] } {
          844  +        set match 0
          845  +        break
          846  +      }
          847  +    }
          848  +    if { $match } {
          849  +      return $patinfo
          850  +    }
          851  +  }
          852  +  return {}
          853  +}
          854  +
          855  +###
          856  +# topic: 929629f0-ebaa-5547-10f6-6410dfa51f8a
          857  +###
          858  +proc ::codebale::pkgindex_path {base stackvar} {
          859  +  upvar 1 $stackvar stack
          860  +
          861  +  set buffer {
          862  +set BASE [file dirname [file normalize [info script]]]
          863  +}
          864  +  set base [file normalize $base]
          865  +  set i    [string length  $base]
          866  +  
          867  +  set result {}
          868  +  while {[stack pop stack stackpath]} {
          869  +    foreach {type file} [::codebale::sniffPath $stackpath stack] {
          870  +      switch $type {
          871  +        parent_name {
          872  +          set file [file normalize $file]
          873  +          set fname [file rootname [file tail $file]]
          874  +          ###
          875  +          # Assume the package is correct in the filename
          876  +          ###
          877  +          set package [lindex [split $fname -] 0]
          878  +          set version [lindex [split $fname -] 1]
          879  +          set path [string trimleft [string range [file dirname $file] $i end] /]
          880  +          ###
          881  +          # Read the file, and override assumptions as needed
          882  +          ###
          883  +          set fin [open $file r]
          884  +          set dat [read $fin]
          885  +          close $fin
          886  +          foreach line [split $dat \n] {
          887  +            set line [string trim $line]
          888  +            if { [string range $line 0 9] != "# Package " } continue
          889  +            set package [lindex $line 2]
          890  +            set version [lindex $line 3]
          891  +            break
          892  +          }
          893  +          append buffer "package ifneeded $package $version \[list source \[file join \$BASE $path [file tail $file]\]\]"
          894  +          append buffer \n
          895  +        }
          896  +        source {
          897  +          set file [file normalize $file]
          898  +          if { $file == [file join $base packages.tcl] } continue
          899  +          if { $file == [file join $base main.tcl] } continue
          900  +          if { [file tail $file] == "version_info.tcl" } continue
          901  +          set fin [open $file r]
          902  +          set dat [read $fin]
          903  +          close $fin
          904  +          if {![regexp "package provide" $dat]} continue
          905  +          set fname [file rootname [file tail $file]]
          906  +          set dir [string trimleft [string range [file dirname $file] $i end] /]
          907  +          
          908  +          foreach line [split $dat \n] {
          909  +            set line [string trim $line]              
          910  +            if { [string range $line 0 14] != "package provide" } continue
          911  +            set package [lindex $line 2]
          912  +            set version [lindex $line 3]
          913  +            append buffer "package ifneeded $package $version \[list source \[file join \$BASE $dir [file tail $file]\]\]"
          914  +            append buffer \n
          915  +            break
          916  +          }
          917  +        }
          918  +        index {
          919  +          set dir [string trimleft [string range [file dirname $file] $i end] /]
          920  +          append buffer "set dir \[file join \$BASE $dir\] \; source \[file join \$BASE $dir pkgIndex.tcl\]"
          921  +          append buffer \n
          922  +        }
          923  +      }
          924  +    }
          925  +  }
          926  +  return $buffer
          927  +}
          928  +
          929  +###
          930  +# topic: f9b3ce3a-afc9-72b5-5e33-0ac9b62c31db
          931  +###
          932  +proc ::codebale::proc_nspace procname {
          933  +  set rawproc $procname
          934  +  set proc [namespace tail $procname]
          935  +  set n [string last $proc $rawproc]
          936  +  if { $n == 0 } {
          937  +    set nspace {}
          938  +  } else {
          939  +    set nspace [string range $rawproc 0 [expr {$n - 1}]]
          940  +    set nspace [string trimleft $nspace :]
          941  +    set nspace [string trimright $nspace :]
          942  +  }
          943  +  return $nspace
          944  +}
          945  +
          946  +###
          947  +# topic: 27a7f169-8a00-fb29-4f2c-700a8d8acb7e
          948  +###
          949  +proc ::codebale::read_csourcefile file {
          950  +  global classes base filename
          951  +  puts "Reading $file"
          952  +  ###
          953  +  # Skip the sqlite amalgamation file. It's huge and not marked
          954  +  # up the way we need anyway
          955  +  ###
          956  +  if {[file tail $file] eq "tclsqlite3.c"} {return 0}
          957  +  set i [string length $base]
          958  +
          959  +  set fname [file rootname [file tail $file]]
          960  +  set dir [string trimleft [string range [file dirname $file] $i end] /]
          961  +  set fpath $dir/[file tail $file]
          962  +  set filename $dir/[file tail $file]
          963  +  set fin [open $file r]
          964  +  set dat [read $fin]
          965  +  close $fin
          966  +  set found 0
          967  +
          968  +  set thisline {}
          969  +  set thiscomment {}
          970  +  set incomment 0
          971  +  set parentid tclcmd
          972  +  foreach line [split $dat \n] {
          973  +    set line [string trim $line]
          974  +    if {[string range $line 0 1] == "/*" } {
          975  +        set incomment 1
          976  +    }
          977  +    if { $incomment } {
          978  +      set pline [string trimleft $line "/"]
          979  +      set pline [string trimleft $pline "*"]
          980  +      set pline [string trimright $pline "/"]
          981  +      set pline [string trimright $pline "*"]
          982  +      append thiscomment $pline \n
          983  +
          984  +
          985  +      if {[string range $line end-1 end] eq "*/" } {
          986  +        set incomment 0
          987  +        #if {[file tail $filename] eq "wallset.c"} {
          988  +        #  puts "...COMMENT..."
          989  +        #  puts $thiscomment
          990  +        #}
          991  +        set info [digest_comment $thiscomment [list file $fpath]]
          992  +        set thiscomment {}
          993  +        set nodeid {}
          994  +        set found 0
          995  +        foreach {var val} $info {
          996  +          switch $var {
          997  +            topic {
          998  +              set nodeid $val
          999  +              dict unset info $var
         1000  +            }
         1001  +            tclcmd -
         1002  +            tclmod {
         1003  +              if { $nodeid eq {} } {
         1004  +                set nodeid   [helpdoc node_id [list tclcmd [lindex $val 0]] 1]
         1005  +              }
         1006  +              set parentid $nodeid
         1007  +              helpdoc node_property_set $nodeid usage $val
         1008  +              dict unset info $var
         1009  +            }
         1010  +            tclmethod -
         1011  +            tclsubcmd {
         1012  +              if { $nodeid eq {} } {
         1013  +                set nodeid [helpdoc node_id [list tclcmd [lindex $val 0] method [lindex $val 1]] 1]
         1014  +              }
         1015  +              dict unset info $var
         1016  +              helpdoc node_property_set $nodeid usage   $val              
         1017  +              helpdoc node_property_set $nodeid arglist [lrange $val 2 end]
         1018  +            }
         1019  +          }
         1020  +        }
         1021  +        if { $nodeid ne {} } {
         1022  +          #puts [list $nodeid $info]
         1023  +          helpdoc node_property_set $nodeid file $fpath
         1024  +
         1025  +          dict set info file $fpath
         1026  +          foreach {var val} $info {
         1027  +            switch $var {
         1028  +              topic -
         1029  +              tclcmd -
         1030  +              tclmod -
         1031  +              tclmethod -
         1032  +              tclsubcmd {}
         1033  +              default {
         1034  +                helpdoc node_property_set $nodeid $var $val
         1035  +              }
         1036  +            }
         1037  +          }
         1038  +        }
         1039  +      }
         1040  +    }
         1041  +  }
         1042  +  return 1
         1043  +}
         1044  +
         1045  +###
         1046  +# topic: 7958a706-b48a-9bc4-4cbb-ef73813e0fb2
         1047  +###
         1048  +proc ::codebale::rewrite_comment {spaces topic info} {
         1049  +  set result {}
         1050  +  set head [string repeat " " $spaces]
         1051  +  set class [helpdoc one {select class from entry where entryid=:topic}]
         1052  +  if { $class eq [dictGet $info type] } {
         1053  +    dict unset info type
         1054  +  }
         1055  +
         1056  +  set order [dict keys $info]
         1057  +  logicset remove order type description arguments returns yields title
         1058  +  set order [linsert order 0 title type]
         1059  +  lappend order description arguments returns yields
         1060  +  foreach {field} $order {
         1061  +    set val [dictGet $info $field]
         1062  +    ###
         1063  +    # Fields to drop for meta-data
         1064  +    ###
         1065  +    set dtext [split [string trim $val] \n]
         1066  +    if {![llength $dtext]} {
         1067  +      continue
         1068  +    }
         1069  +    if {[llength $dtext] == 1} {
         1070  +      append result \n "${head}# ${field}: [string trim [lindex $dtext 0]]"
         1071  +    } else {
         1072  +      append result \n "${head}# ${field}:"
         1073  +      foreach dline $dtext {
         1074  +        append result \n "${head}#    [string trim $dline]"
         1075  +      }
         1076  +    }
         1077  +  }
         1078  +
         1079  +  set result [buffer_merge "${head}###" "${head}# topic: $topic" $result "${head}###"]
         1080  +}
         1081  +
         1082  +###
         1083  +# topic: d8ef9620-b068-3a82-3761-1725abc83192
         1084  +# description:
         1085  +#    Descends into a directory structure, returning
         1086  +#    a list of items found in the form of:
         1087  +#    type object
         1088  +#    where type is one of: csource source parent_name
         1089  +#    and object is the full path to the file
         1090  +###
         1091  +proc ::codebale::sniffPath {spath stackvar} {
         1092  +  upvar 1 $stackvar stack    
         1093  +  set result {}
         1094  +
         1095  +  if { ![file isdirectory $spath] } {
         1096  +    switch [file extension $spath] {
         1097  +      .tm {
         1098  +        return [list parent_name $spath]
         1099  +      }
         1100  +      .tcl {
         1101  +        return [list source $spath]
         1102  +      }
         1103  +      .c {
         1104  +        return [list csource $spath]
         1105  +      }
         1106  +    }
         1107  +  }
         1108  +  if { [string toupper [file tail $spath]] == "CVS" } return
         1109  +  if {[file extension $spath] eq ".vfs"} return
         1110  +  if {[file exists [file join $spath pkgIndex.tcl]]} {
         1111  +    lappend result index [file join $spath pkgIndex.tcl]
         1112  +  } else {
         1113  +    foreach f [glob -nocomplain $spath/*.tcl] {
         1114  +      lappend result source $f
         1115  +    }
         1116  +  }
         1117  +  foreach f [glob -nocomplain $spath/*.tm] {
         1118  +    lappend result parent_name $f
         1119  +  }
         1120  +  foreach f [glob -nocomplain $spath/*.c] {
         1121  +    lappend result csource $f
         1122  +  }
         1123  +  foreach f [glob -nocomplain $spath/*] {
         1124  +    while {[file type $f]=="link"} {
         1125  +      set f [file readlink $f]
         1126  +    }
         1127  +    if [file isdirectory $f] {
         1128  +      stack push stack $f
         1129  +    }
         1130  +  }
         1131  +  return $result
         1132  +}
         1133  +
         1134  +set ::force_check 0
         1135  +
         1136  +###
         1137  +# topic: c790d2a5-043a-5f76-a476-143db91bd729
         1138  +###
         1139  +namespace eval ::codebale {
         1140  +  alias nspace namespace
         1141  +
         1142  +  parser_addpattern {}  {namespace eval}   ::codebale::parse_namespace
         1143  +  parser_addpattern {}  proc               ::codebale::parse_procedure
         1144  +  parser_addpattern {}  ensemble_method    ::codebale::parse_procedure
         1145  +  parser_addpattern {}  odie::class        ::codebale::parse_ooclass  
         1146  +  parser_addpattern {}  {oo::class create} ::codebale::parse_ooclass
         1147  +  parser_addpattern ooclass method         ::codebale::parse_oomethod
         1148  +  parser_addpattern ooclass proc           ::codebale::parse_oomethod
         1149  +  parser_addpattern ooclass class_method   ::codebale::parse_oomethod
         1150  +  parser_addpattern ooclass superclasses   ::codebale::parse_oosuperclass
         1151  +}
         1152  +

Added odie/global.tcl.

            1  +###
            2  +# global.tcl
            3  +#
            4  +# This file defines Global functions that are genuinely useful
            5  +#
            6  +# Copyright (c) 2012 Sean Woods
            7  +#
            8  +# See the file "license.terms" for information on usage and redistribution of
            9  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           10  +###
           11  +
           12  +
           13  +###
           14  +# topic: 4dffef8f-9697-b8e7-e868-c3ad6cae2f00
           15  +# description: Export a namespace as an ensemble command
           16  +###
           17  +proc ::ensemble_build namespace {
           18  +  #if {[info command $namespace] ne {}} {
           19  +  #  return
           20  +  #}
           21  +  namespace eval $namespace {
           22  +    namespace export *
           23  +    namespace ensemble create
           24  +  }
           25  +}
           26  +
           27  +###
           28  +# topic: 74aa80cd-d83e-751b-aa89-c413b6834b12
           29  +# description:
           30  +#    Provide an implementation in Tcl
           31  +#    for a function if none exists already in C
           32  +###
           33  +proc ::ensemble_method {name args body} {
           34  +  #puts [list ensemble_method $name [info script]]
           35  +  if {[info command $name] ne {}} return
           36  +  #proc $name $args "puts $name \n $body"
           37  +  proc $name $args $body
           38  +}
           39  +
           40  +###
           41  +# topic: 87bd2757-7441-255a-f6fb-8781aacdb50d
           42  +# type: ensemble_method
           43  +###
           44  +ensemble_method ::dictGet {dictvar args} {
           45  +  if {[dict exists $dictvar {*}$args]} {
           46  +    return [dict get $dictvar {*}$args]
           47  +  }
           48  +  return {}
           49  +}
           50  +
           51  +###
           52  +# topic: 58ef6deb-c315-edf9-c8ec-fe5ed710b07d
           53  +# type: ensemble_method
           54  +###
           55  +ensemble_method ::get varname {
           56  +  upvar 1 $varname var
           57  +  if {[info exists var]} {
           58  +    return [set var]
           59  +  }
           60  +  return {}
           61  +}
           62  +
           63  +###
           64  +# topic: 84ff222d-9f57-4a40-5804-0b99485cd6ff
           65  +# type: ensemble_method
           66  +###
           67  +ensemble_method ::ladd {varname args} {
           68  +  upvar 1 $varname var
           69  +  if ![info exists var] {
           70  +    set var {}
           71  +  }
           72  +  foreach item $args {
           73  +    if { $item ni $var} {
           74  +      lappend var $item
           75  +    }
           76  +  }
           77  +  return $var
           78  +}
           79  +
           80  +###
           81  +# topic: 9591fb2c-2d1d-be3e-b92d-6e993589a452
           82  +# type: ensemble_method
           83  +###
           84  +ensemble_method ::ladd_sorted {varname args} {
           85  +  upvar 1 $varname var
           86  +  if ![info exists var] {
           87  +    set var {}
           88  +  }
           89  +  foreach item $args {
           90  +    lappend var $item
           91  +  }
           92  +  set var [lsort -dictionary -unique $var]
           93  +  return $var
           94  +}
           95  +
           96  +###
           97  +# topic: f0367444-a3ae-9186-1ee8-31f757fc4621
           98  +# type: ensemble_method
           99  +###
          100  +ensemble_method ::ldelete {varname args} {
          101  +  upvar 1 $varname var
          102  +  if ![info exists var] {
          103  +      return
          104  +  }
          105  +  foreach item [lsort -unique $args] {
          106  +    while {[set i [lsearch $var $item]]>=0} {
          107  +      set var [lreplace $var $i $i {}]
          108  +    }
          109  +  }
          110  +}

Added odie/index.tcl.

            1  +###
            2  +# index.tcl
            3  +#
            4  +# This file loads the rest of the odie package
            5  +#
            6  +# Copyright (c) 2012 Sean Woods
            7  +#
            8  +# See the file "license.terms" for information on usage and redistribution of
            9  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           10  +###
           11  +
           12  +package provide odie 0.1
           13  +
           14  +###
           15  +# topic: 8b8d3c47-197b-0abe-5005-b2a644ebcb7d
           16  +###
           17  +proc ::load_path {path {ordered_files {}}} {
           18  +  lappend loaded index.tcl pkgIndex.tcl
           19  +  if {[file exists [file join $path baseclass.tcl]]} {
           20  +    lappend loaded baseclass.tcl
           21  +    uplevel #0 [list source [file join $path baseclass.tcl]]
           22  +  }
           23  +  foreach file $ordered_files {
           24  +    lappend loaded $file
           25  +    uplevel #0 [list source [file join $path $file]]
           26  +  }
           27  +  foreach file [glob -nocomplain [file join $path *.tcl]] {
           28  +    if {[file tail $file] in $loaded} continue
           29  +    lappend loaded [file tail $file]
           30  +    uplevel #0 [list source $file]
           31  +  }
           32  +}
           33  +
           34  +set loaded {pkgIndex.tcl index.tcl}
           35  +
           36  +set odie_path [file dirname [info script]]
           37  +
           38  +load_path $odie_path {
           39  +  global.tcl
           40  +  logicset.tcl
           41  +  stack.tcl
           42  +  ootools.tcl
           43  +  moac.tcl
           44  +}
           45  +

Added odie/license.terms.

            1  +This software is copyrighted by the Sean Woods.  The following terms apply
            2  +to all files associated with the software unless explicitly disclaimed in
            3  +individual files.
            4  +
            5  +The authors hereby grant permission to use, copy, modify, distribute,
            6  +and license this software and its documentation for any purpose, provided
            7  +that existing copyright notices are retained in all copies and that this
            8  +notice is included verbatim in any distributions. No written agreement,
            9  +license, or royalty fee is required for any of the authorized uses.
           10  +Modifications to this software may be copyrighted by their authors
           11  +and need not follow the licensing terms described here, provided that
           12  +the new terms are clearly indicated on the first page of each file where
           13  +they apply.
           14  +
           15  +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
           16  +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
           17  +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
           18  +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
           19  +POSSIBILITY OF SUCH DAMAGE.
           20  +
           21  +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
           22  +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
           23  +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
           24  +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
           25  +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
           26  +MODIFICATIONS.
           27  +
           28  +GOVERNMENT USE: If you are acquiring this software on behalf of the
           29  +U.S. government, the Government shall have only "Restricted Rights"
           30  +in the software and related documentation as defined in the Federal 
           31  +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
           32  +are acquiring the software on behalf of the Department of Defense, the
           33  +software shall be classified as "Commercial Computer Software" and the
           34  +Government shall have only "Restricted Rights" as defined in Clause
           35  +252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
           36  +authors grant the U.S. Government and others acting in its behalf
           37  +permission to use and distribute the software in accordance with the
           38  +terms specified in this license. 

Added odie/logicset.tcl.

            1  +###
            2  +# logicset.tcl
            3  +#
            4  +# This file defines the method needed for the tcl inplementation
            5  +# of logical sets
            6  +#
            7  +# Copyright (c) 2012 Sean Woods
            8  +#
            9  +# See the file "license.terms" for information on usage and redistribution of
           10  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           11  +###
           12  +
           13  +::namespace eval ::logicset {}
           14  +
           15  +###
           16  +# topic: 08efb87d-9c9b-36e8-64f5-0a05ff0811f5
           17  +# type: ensemble_method
           18  +###
           19  +ensemble_method ::logicset::add {setvar args} {
           20  +  upvar 1 $setvar result
           21  +  if {![info exists result]} {
           22  +    set result {}
           23  +  }
           24  +  foreach arg $args {
           25  +    if { $args ni $result } {
           26  +      lappend result $arg
           27  +    }
           28  +  }
           29  +  return $result
           30  +}
           31  +
           32  +###
           33  +# topic: bd1fdea7-e32f-113f-6b4b-b1fe7455d5fd
           34  +# type: ensemble_method
           35  +###
           36  +ensemble_method ::logicset::cartesian_product {A B} {
           37  +  set result {}
           38  +  foreach alement [sort $A] {
           39  +    foreach blement [sort $B] {
           40  +      lappend result $alement $blement
           41  +    }
           42  +  }
           43  +  return $result
           44  +}
           45  +
           46  +###
           47  +# topic: d3032d6a-b1d1-656e-afab-a99bb80e09a9
           48  +# type: ensemble_method
           49  +###
           50  +ensemble_method ::logicset::contains {setval args} {
           51  +  foreach arg $args {
           52  +    if { $arg ni $setval } {
           53  +      return 0
           54  +    }
           55  +  }
           56  +  return 1
           57  +}
           58  +
           59  +###
           60  +# topic: d642d345-9294-81a0-cd88-38b825966629
           61  +# type: ensemble_method
           62  +###
           63  +ensemble_method ::logicset::empty setval {
           64  +  if {[llength $setval] == 0} {
           65  +    return 1
           66  +  }
           67  +  return 0
           68  +}
           69  +
           70  +###
           71  +# topic: aaf46124-7085-3353-aba3-88d113cd0e78
           72  +# type: ensemble_method
           73  +###
           74  +ensemble_method ::logicset::intersection {A B} {
           75  +  set result {}
           76  +  foreach element $B {
           77  +    if { $element in $A } {
           78  +      add result $element
           79  +    }
           80  +  }
           81  +  return $result
           82  +}
           83  +
           84  +###
           85  +# topic: 5ff774e0-3ce3-fd96-38e0-3c83a0c7b1a4
           86  +# type: ensemble_method
           87  +###
           88  +ensemble_method ::logicset::remove {setvar args} {
           89  +  upvar 1 $setvar result
           90  +  if {![info exists result]} {
           91  +    set result {}
           92  +  }
           93  +  foreach arg $args {
           94  +    while { $arg in $result } {
           95  +      ldelete result $arg
           96  +    }
           97  +  }
           98  +  return $result
           99  +}
          100  +
          101  +###
          102  +# topic: ca1ffbc9-d3ff-fbc4-4a2e-d63ed823573d
          103  +# type: ensemble_method
          104  +###
          105  +ensemble_method ::logicset::set_difference {U A} {
          106  +  set result {}
          107  +  foreach element $A {
          108  +    if { $element ni $U } {
          109  +      add result $element
          110  +    }
          111  +  }
          112  +  return $result
          113  +}
          114  +
          115  +###
          116  +# topic: ddb93085-3ab4-a3b3-61e1-fc2133a7c79a
          117  +# type: ensemble_method
          118  +###
          119  +ensemble_method ::logicset::sort A {
          120  +  return [lsort -dictionary -unique $A]
          121  +}
          122  +
          123  +###
          124  +# topic: 13e4ecbf-7e85-e27f-c293-a4b42ad48c30
          125  +# type: ensemble_method
          126  +###
          127  +ensemble_method ::logicset::symmetric_difference {A B} {
          128  +  set result {}
          129  +  foreach element $A {
          130  +    if { $element ni $B } {
          131  +      add result $element
          132  +    }
          133  +  }
          134  +  foreach element $B {
          135  +    if { $element ni $A } {
          136  +      add result $element
          137  +    }
          138  +  }
          139  +  return $result
          140  +}
          141  +
          142  +###
          143  +# topic: 49074428-2a40-261f-0d63-192290657d9b
          144  +# type: ensemble_method
          145  +###
          146  +ensemble_method ::logicset::union {A B} {
          147  +  set result {}
          148  +  add result {*}$A
          149  +  add result {*}$B
          150  +  return $result
          151  +}
          152  +
          153  +ensemble_build ::logicset
          154  +

Added odie/moac.tcl.

            1  +###
            2  +# topic: 5539066c-3e90-2cbd-b008-77a2eb4e7acd
            3  +# title: Mother of all Classes
            4  +# description:
            5  +#    Base class used to define a global
            6  +#    template of expected behaviors
            7  +###
            8  +odie::class moac {
            9  +  variable objectInfo
           10  +  
           11  +
           12  +  ###
           13  +  # topic: 3c54cd52-e671-de60-2102-ebf9d5562a2d
           14  +  ###
           15  +  method debugOut string {}
           16  +
           17  +  ###
           18  +  # topic: dfd570ca-bd5e-28af-f080-8fc28d36b54d
           19  +  # description: Bind an object to an event
           20  +  ###
           21  +  method event:bind {
           22  +    my variable event_map
           23  +
           24  +    set event {}
           25  +    set script {}
           26  +    set idvar {}
           27  +    my event declare $dictargs
           28  +    dict with dictargs {}
           29  +    
           30  +    if { [string length $idvar] } { upvar $idvar id }
           31  +
           32  +    if { ![info exists event_map($event)] } {
           33  +      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
           34  +        [format "unknown event \"%s\"" $event]
           35  +    }
           36  +  
           37  +    set id [incr event_map($event)]
           38  +    set event_map($event:$id) $script
           39  +    lappend event_map($event:list) $id
           40  +    return $id
           41  +  }
           42  +
           43  +  ###
           44  +  # topic: 74d04ba1-8164-691a-91c9-e553c74f5cbe
           45  +  # description: Declares an oo event
           46  +  ###
           47  +  method event:declare {
           48  +    my variable event_map
           49  +    set event [dictGet $dictargs event]
           50  +    if { [string length $event] } {
           51  +      if {![info exists event_map($event)]} {
           52  +        set event_map($event)      -1
           53  +        set event_map($event:list) {}
           54  +        set event_map($event:subscribers) {}
           55  +      }
           56  +    } else {
           57  +      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
           58  +        "null event identifier"
           59  +    }
           60  +    return
           61  +  }
           62  +
           63  +  ###
           64  +  # topic: a037c835-6d4c-767d-5104-78770a4b63ae
           65  +  # description: Detach an event from an object
           66  +  ###
           67  +  method event:detach {
           68  +    my variable event_map
           69  +    
           70  +    set event {}
           71  +    set id    {}
           72  +    dict with dictargs {}
           73  +    
           74  +    if { ! [info exists event_map($event)] } {
           75  +      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
           76  +        [format "unknown event \"%s\"" $event]
           77  +    }
           78  +    if { ! [info exists event_map($event:$id)] } {
           79  +      return -code error -errorcode "LOGIC INVALID_ARGUMENT" \
           80  +        [format "unknown script identifier \"%s\" for event \"%s\"" \
           81  +        $id $event]
           82  +    }
           83  +    
           84  +    unset event_map($event:$id)
           85  +    set idx [lsearch -sorted $event_map($event:list) $id]
           86  +    set event_map($event:list) [lreplace $event_map($event:list) $idx $idx]
           87  +  }
           88  +
           89  +  ###
           90  +  # topic: 35db60ff-f0bb-e3df-3b41-126a38a49b2c
           91  +  # description: Forget an event
           92  +  ###
           93  +  method event:forget {
           94  +    my variable event_map
           95  +
           96  +    set event {}
           97  +    dict with dictargs {}
           98  +
           99  +    foreach key [array names event_map $event*] { unset event_map($key) }
          100  +    foreach event [lrange $args 1 end] {
          101  +      foreach key [array names event_map $event*] { unset event_map($key) }
          102  +    }
          103  +  }
          104  +
          105  +  ###
          106  +  # topic: 401fbdb2-1e5b-47b0-ecbb-78c3f3ceaa71
          107  +  # description:
          108  +  #    Generate an event
          109  +  #    Adds a subscription mechanism for objects
          110  +  #    to see who has recieved this event and prevent
          111  +  #    spamming or infinite recursion
          112  +  ###
          113  +  method event:generate {
          114  +    my variable event_map
          115  +
          116  +    set event {}
          117  +    set info $dictargs
          118  +    set strict 0
          119  +    set sender [self]
          120  +    dict with dictargs {}
          121  +
          122  +    set self [self]
          123  +
          124  +      dict set info id     event#[format %0.8x [incr ::odie::event_count]]
          125  +      dict set info origin $self
          126  +      dict set info event  $event
          127  +      dict set info sender $self
          128  +      dict set info rcpt   {}
          129  +    
          130  +    dict set info self $self
          131  +    set rcpt [dictGet $info rcpt]
          132  +    if {![info exists event_map($event)]} {
          133  +      if { $strict && $sender eq {} } {
          134  +        return -code error -errorcode "LOGIC INVALID_ARGUMENT" [format "unknown event \"%s\"" $event]
          135  +      }
          136  +      return
          137  +    }
          138  +    foreach pat [get event_map($event:subscribers)] {
          139  +      logicset add wholist {*}[info command $pat]
          140  +    }
          141  +    logicset remove wholist $self
          142  +    dict unset info self
          143  +    foreach who [lsort -dictionary -decreasing $wholist] {
          144  +      $who event notify $info
          145  +    }
          146  +    my event notify $info
          147  +  }
          148  +
          149  +  ###
          150  +  # topic: 6056849a-7b71-f512-4f45-bc5d71c62cdf
          151  +  # description: Pass a subscribed event to this object
          152  +  ###
          153  +  method event:notify {
          154  +    my variable event_map
          155  +    set sender [self]
          156  +    dict with dictargs {}
          157  +    if {![info exists event_map]} return
          158  +    foreach {field value} $dictargs {
          159  +      lappend valuemap %${field} $value
          160  +    }
          161  +    dict set valuemap %sender [dictGet $dictargs $sender]
          162  +    dict set valuemap %self   [self]
          163  +    
          164  +    foreach id [get event_map($event:list)] {
          165  +      eval [string map $valuemap [list {*}$event_map($event:$id)]]
          166  +    }
          167  +  }
          168  +
          169  +  ###
          170  +  # topic: 2955042c-8789-2c89-e4e1-eb55c1c35635
          171  +  # description:
          172  +  #    Subscribe calls for an ensemble to be
          173  +  #    passed on to another object
          174  +  ###
          175  +  method event:subscribe {
          176  +    my variable event_map
          177  +
          178  +    set event {}
          179  +    set who   {}
          180  +    dict with dictargs {}
          181  +    
          182  +    my event declare event $event
          183  +    ::logicset add event_map($event:subscribers) $who
          184  +  }
          185  +
          186  +  ###
          187  +  # topic: 1c0f43e0-e33d-bb2a-4923-4b7b79ea5252
          188  +  # description:
          189  +  #    Subscribe calls for an ensemble to be
          190  +  #    passed on to another object
          191  +  ###
          192  +  method event:unsubscribe {
          193  +    my variable event_map
          194  +
          195  +    set event {}
          196  +    set who   {}
          197  +    dict with dictargs {}
          198  +    
          199  +    my event declare event $event
          200  +    ::logicset remove event_map($event:subscribers) $who
          201  +  }
          202  +
          203  +  ###
          204  +  # topic: e04b7ac7-2d11-853d-e591-28469a01f1b8
          205  +  ###
          206  +  method forward {method args} {
          207  +    oo::objdefine [self] forward $method {*}$args
          208  +  }
          209  +
          210  +  ###
          211  +  # topic: 92971042-7138-47f7-88b0-7704312df200
          212  +  ###
          213  +  method get {{field {}}} {
          214  +    my variable objectInfo
          215  +    if { $field == {} } {
          216  +      set result {}
          217  +      foreach f [::info object vars [self]] {
          218  +        my variable $f
          219  +        if {[array exists $f]} {
          220  +          dict set result @$f [::array get $f]
          221  +        } else {
          222  +          dict set result $f [set $f]
          223  +        }
          224  +      }
          225  +      return $result
          226  +    }
          227  +    my variable $field
          228  +    if {[array exists $field]} {
          229  +      return [::array get $field]
          230  +    }
          231  +    if {[info exists $field]} {
          232  +      return [set $field]
          233  +    }
          234  +    return {}
          235  +  }
          236  +
          237  +  ###
          238  +  # topic: 7be7adbd-32da-8c19-909a-eab4d140fce4
          239  +  ###
          240  +  method getVarname field {
          241  +    return [my varname $field]
          242  +  }
          243  +
          244  +  ###
          245  +  # topic: e1c1cccb-5201-997d-e0c5-4e04394b61e2
          246  +  ###
          247  +  method graft args {
          248  +    my variable organs
          249  +    foreach {stub object} $args {
          250  +      set stub [string trimleft $stub /]
          251  +      logicset add organs $stub
          252  +      my put [list $stub $object]
          253  +      my forward ${stub} $object
          254  +      # Provide a more standard "/->object" stub
          255  +      #my forward /${stub} $object
          256  +    }
          257  +  }
          258  +
          259  +  ###
          260  +  # topic: df00845e-dcbf-6f93-65b9-ee824513102a
          261  +  ###
          262  +  method morph newclass {
          263  +    set class [string trimleft [info object class [self]]]
          264  +    set newclass [string trimleft $newclass :]
          265  +    if {[info command $newclass] eq {}} {
          266  +      error "Class $newclass does not exist"
          267  +    }
          268  +    if { $class ne $newclass } {
          269  +      oo::objdefine [self] class ::${newclass}
          270  +    }
          271  +  }
          272  +
          273  +  ###
          274  +  # topic: 3826d482-8446-2b39-4590-1d02d1ba67e2
          275  +  ###
          276  +  method organsExport {} {
          277  +    my variable organs
          278  +    set result {}
          279  +    if {![info exists organs]} return
          280  +    foreach organ $organs {
          281  +      lappend result $organ [my get $organ]
          282  +    }
          283  +    return $result
          284  +  }
          285  +
          286  +  ###
          287  +  # topic: 886b734b-f9a9-8aa7-82e8-f77b9a42c344
          288  +  ###
          289  +  method put args {
          290  +    if { [llength $args] == 1 } {
          291  +      set args [lindex $args 0]
          292  +    }
          293  +    foreach {key val} $args {
          294  +      string trimleft $key -
          295  +      my variable $key
          296  +      set $key $val
          297  +    }
          298  +  }
          299  +
          300  +  ###
          301  +  # topic: 5b9a51d5-e327-84f0-8cb7-973e8f4115f0
          302  +  ###
          303  +  method sensai object {
          304  +    foreach {stub obj} [$object organsExport] {
          305  +      my graft $stub $obj
          306  +    }
          307  +  }
          308  +}
          309  +

Added odie/oosqlite.tcl.

            1  +###
            2  +# topic: cceceb5d-a991-e07b-6eeb-21375178fa46
            3  +###
            4  +odie::class moac.sqliteDb {
            5  +  superclass moac
            6  +  property docentry {}
            7  +
            8  +  ###
            9  +  # topic: 6e0d9dea-cbb3-7b09-98b4-d1b3f2fcc1e3
           10  +  ###
           11  +  method attach {alias filename} {
           12  +    set exists [file exists $filename]
           13  +    sqlite3 [self]::${alias} $filename
           14  +    my database_functions [self]::${alias}
           15  +    my graft $alias [self]::${alias}
           16  +    my attach_sqlite_methods [self]::${alias}
           17  +    if {!$exists} {
           18  +      my database_create $alias
           19  +    }
           20  +  }
           21  +
           22  +  ###
           23  +  # topic: 080a0a01-e018-a81c-9f3d-7a696a0698c9
           24  +  ###
           25  +  method attach_sqlite_methods sqlchan {
           26  +    my graft db $sqlchan
           27  +foreach func {
           28  +authorizer
           29  +backup
           30  +busy
           31  +cache
           32  +changes
           33  +close
           34  +collate
           35  +collation_needed
           36  +commit_hook
           37  +complete
           38  +copy
           39  +enable_load_extension
           40  +errorcode
           41  +eval
           42  +exists
           43  +function
           44  +incrblob
           45  +last_insert
           46  +last_insert_rowid
           47  +nullvalue
           48  +one
           49  +onecolumn
           50  +profile
           51  +progress
           52  +restore
           53  +rollback_hook
           54  +status
           55  +timeout
           56  +total_changes
           57  +trace
           58  +transaction
           59  +unlock_notify
           60  +update_hook
           61  +version
           62  +    } {
           63  +        my forward $func $sqlchan $func
           64  +    }
           65  +  }
           66  +
           67  +  ###
           68  +  # topic: d4ac9357-de80-79b0-24a8-a48c07ceac06
           69  +  # title: Default implementation of change
           70  +  # description: Just a simple passthrough to eval
           71  +  ###
           72  +  method change args {
           73  +    uplevel 1 [list [self] eval {*}$args]
           74  +  }
           75  +
           76  +  ###
           77  +  # topic: a8f26a9d-1cbd-4992-dfe3-3a4a25a065b0
           78  +  ###
           79  +  method database_create alias {
           80  +    
           81  +  }
           82  +
           83  +  ###
           84  +  # topic: 76de1589-de3f-78c3-b38c-83502c65cc30
           85  +  ###
           86  +  method database_functions sqlchan {
           87  +  }
           88  +
           89  +  ###
           90  +  # topic: af76cd3e-8d30-4841-95d5-99d44e4a00b3
           91  +  ###
           92  +  method native_tableget table {
           93  +    set info {}
           94  +    my one {select type,sql from sqlite_master where tbl_name=$table} {
           95  +      foreach {type field value} [::schema::createsql_to_dict $sql] {
           96  +        dict set info $type $field $value
           97  +      }
           98  +    }
           99  +    return $info
          100  +  }
          101  +
          102  +  ###
          103  +  # topic: e1811960-ced8-4756-76b4-64def58a2a1c
          104  +  ###
          105  +  method native_tablelist {} {
          106  +      return [my eval {SELECT name FROM sqlite_master WHERE type ='table'}]
          107  +  }
          108  +
          109  +  ###
          110  +  # topic: cac2e473-a72e-f1d2-180a-fdd417117b0d
          111  +  ###
          112  +  method schema_dump {} {
          113  +    set result {}
          114  +    foreach table [my schema_tablelist] {
          115  +      dict set result $table [my schema_get $table]
          116  +    }
          117  +    return $result
          118  +  }
          119  +
          120  +  ###
          121  +  # topic: 60cc2296-f2e2-4a12-24b7-4dd459d8b49b
          122  +  ###
          123  +  method schema_fields table {
          124  +    set dentry [my property docentry]
          125  +    if {![::helpdoc node_exists [list schema $dentry sqltable $table] entryid]} {
          126  +      return {}
          127  +    }
          128  +    set result {}
          129  +    helpdoc eval {select name,entryid as fieldid from entry where parent=:entryid and class='field' order by name} {
          130  +      dict set result $name [helpdoc node_get $fieldid]
          131  +    }
          132  +    return $result
          133  +  }
          134  +
          135  +  ###
          136  +  # topic: a601c2ea-28ad-4dc6-40b6-b6be22cd590e
          137  +  ###
          138  +  method schema_get table {
          139  +    set dentry [my property docentry]
          140  +    if {![::helpdoc node_exists [list schema $dentry sqltable $table] entryid]} {
          141  +      return {}
          142  +    }
          143  +    set info [::helpdoc node_get $entryid]
          144  +    dict set info fields [my schema_fields $table]
          145  +    return $info
          146  +  }
          147  +
          148  +  ###
          149  +  # topic: ba74ec88-9d25-c62c-fcd0-a50d61c36a99
          150  +  ###
          151  +  method schema_sql {} {
          152  +    set result {}
          153  +    foreach table [my schema_tablelist] {
          154  +      set info [my schema_get $table]
          155  +      append result "-- BEGIN $table" \n
          156  +      append result [dict get $info create_sql] \n
          157  +      append result "-- END $table" \n
          158  +    }
          159  +    return $result
          160  +  }
          161  +
          162  +  ###
          163  +  # topic: f8feb545-51d7-1c81-3ed8-1fb468cb0f6a
          164  +  ###
          165  +  method schema_tablelist {} {
          166  +    set dentry [my property docentry]
          167  +    if {![::helpdoc node_exists [list schema $dentry] did]} {
          168  +      return {}
          169  +    }
          170  +    return [helpdoc eval {select name from entry where parent=:did order by name}]
          171  +  }
          172  +}
          173  +

Added odie/ootools.tcl.

            1  +package require TclOO
            2  +
            3  +::namespace eval ::classDefine {}
            4  +
            5  +::namespace eval ::odie {}
            6  +
            7  +::namespace eval ::viewobj {}
            8  +
            9  +
           10  +###
           11  +# topic: 14474616-1674-47d6-673c-5059adc6bbb0
           12  +###
           13  +proc ::classDefine::class_method {name arglist body} {  
           14  +  method $name $arglist $body
           15  +  dict set ::class_property([peek]) class_methods $name [list arglist $arglist body $body]
           16  +}
           17  +
           18  +proc ::classDefine::component args {
           19  +  
           20  +}
           21  +
           22  +proc ::classDefine::delegate {keyword object args} {
           23  +  switch $keyword {
           24  +    method {}
           25  +    option {}
           26  +    typemethod -
           27  +    class_method {} 
           28  +  }
           29  +}
           30  +
           31  +###
           32  +# topic: 0bde8c29-3e7d-a6b5-193b-a3c856f0ed0a
           33  +# title: Define an ensemble method for this agent
           34  +###
           35  +::proc ::classDefine::ensemble {ensemble ebody} {
           36  +  set class [peek]
           37  +  foreach {method body} $ebody {
           38  +    dict set ::class_ensemble($class) $ensemble:$method $body
           39  +  }
           40  +}
           41  +
           42  +###
           43  +# topic: e4bf9a80-4e2e-49c9-5547-a1d17af9dfcc
           44  +# title: Define an ensemble method for this agent
           45  +###
           46  +::proc ::classDefine::ensemble_method {ensemble method body} {
           47  +  set class [peek]
           48  +  dict set ::class_ensemble($class) $ensemble:$method $body
           49  +}
           50  +
           51  +###
           52  +# topic: 13591268-7a5e-0459-1d8a-467d4875b753
           53  +# title: Define an ensemble method for this agent
           54  +###
           55  +::proc ::classDefine::method {rawmethod args} {
           56  +  set class [peek]
           57  +  if {[string first : $rawmethod] < 0} {
           58  +    ::oo::define $class method $rawmethod {*}$args
           59  +    return
           60  +  }
           61  +  dict set ::class_ensemble($class) $rawmethod [lindex $args end]
           62  +}
           63  +
           64  +proc ::classDefine::option {name args} {
           65  +  ::global class_property
           66  +  set class [peek]
           67  +  dict set class_property($class) [string trimleft $name -] [list option $args]
           68  +}
           69  +
           70  +###
           71  +# topic: b6fb7bbf-f61b-cecb-d5a6-608bd3c59db9
           72  +###
           73  +proc ::classDefine::peek args {
           74  +  if {[llength $args] == 2} {
           75  +    upvar 1 [lindex $args 0] class
           76  +  }
           77  +  ::variable classStack
           78  +  set class   [lindex $classStack end]
           79  +  return ${class}
           80  +}
           81  +
           82  +###
           83  +# topic: 0e4e2742-3217-5838-bd78-43374d6daf13
           84  +###
           85  +proc ::classDefine::pop {} {
           86  +  ::variable classStack
           87  +  set class      [lindex $classStack end]
           88  +  set classStack [lrange $classStack 0 end-1]
           89  +  return $class
           90  +}
           91  +
           92  +###
           93  +# topic: 0968eef3-84f2-c6db-1d59-0abcd79680d4
           94  +# title: Define the properties for this agent
           95  +###
           96  +proc ::classDefine::properties info {
           97  +  ::global class_property
           98  +  set class [peek]
           99  +  foreach {var val} $info {
          100  +    dict set class_property($class) $var [list const $val]
          101  +  }
          102  +}
          103  +
          104  +###
          105  +# topic: 8316d501-0155-f0e9-2d71-fb1d13f38b09
          106  +# title: Define the properties for this agent
          107  +###
          108  +proc ::classDefine::property {property type {value {}}} {
          109  +  ::global class_property
          110  +  set class [peek]
          111  +  if { $value eq {} } {
          112  +    dict set class_property($class) $property [list const $type]
          113  +    return
          114  +  }
          115  +  switch $type {
          116  +    {} - eval {
          117  +      dict set class_property($class) $property [list eval $value]
          118  +    }
          119  +    option {
          120  +      dict set class_property($class) $property [list option $value]      
          121  +    }
          122  +    subst {
          123  +      dict set class_property($class) $property [list subst $value]
          124  +    }
          125  +    const {
          126  +      dict set class_property($class) $property [list const $value]      
          127  +    }
          128  +  }
          129  +}
          130  +
          131  +###
          132  +# topic: b89c6b36-37ef-4c22-8ee5-26a4b1723bba
          133  +# description:
          134  +#    Here is the guts of our machine
          135  +#    In a seperate namespace so a developer can't accidentally
          136  +#    overwrite an important function
          137  +###
          138  +proc ::classDefine::push type {
          139  +  ::variable classStack
          140  +  lappend classStack $type
          141  +}
          142  +
          143  +###
          144  +# topic: e710754b-3fe2-f0f1-fd52-58e24bc0e5dc
          145  +# title: Closes all floating windows
          146  +###
          147  +proc ::closeAllWindows {} {
          148  +  namespace delete ::viewobj
          149  +  namespace eval ::viewobj {}
          150  +}
          151  +
          152  +###
          153  +# topic: 9242436a-9453-4827-14ee-766ed8ae9b20
          154  +###
          155  +proc ::odie::class {name body} {
          156  +  set class ::[string trimleft $name :]
          157  +  logicset add ::odie::class_list $class
          158  +  if { [::info command $class] == {} } {
          159  +    oo::class create $class
          160  +  }
          161  +  ::classDefine::push $class
          162  +  namespace eval ::classDefine $body
          163  +  ::classDefine::pop
          164  +  ::odie::class_properties $class
          165  +}
          166  +
          167  +###
          168  +# topic: 80b8b5f1-ec02-3ee6-cd3e-34be71d2ffa4
          169  +###
          170  +proc ::odie::class_ancestors {class {stackvar {}}} {
          171  +  if { $stackvar ne {} } {
          172  +    upvar 1 $stackvar stack
          173  +  } else {
          174  +    set stack {}
          175  +  }
          176  +  if { $class in $stack } {
          177  +    return {}
          178  +  }
          179  +  stack push stack $class
          180  +  if {![catch {::info class superclasses $class} ancestors]} {
          181  +    foreach ancestor $ancestors {
          182  +      class_ancestors $ancestor stack
          183  +    }
          184  +  }
          185  +  if {![catch {::info class mixins $class} ancestors]} {
          186  +    foreach ancestor $ancestors {
          187  +      class_ancestors $ancestor stack
          188  +    }
          189  +  }
          190  +  return $stack
          191  +}
          192  +
          193  +###
          194  +# topic: 1c1ea49e-6292-f4e3-e530-9f8af9374810
          195  +###
          196  +proc ::odie::class_build_ensembles class {
          197  +  set info {}
          198  +  set ancestors [::odie::class_ancestors $class]
          199  +  foreach ancestor $ancestors {
          200  +    foreach {path body} [get ::class_ensemble($ancestor)] {
          201  +      set ensemble [lindex [split $path :] 0]
          202  +      set method   [join [lrange [split $path :] 1 end] :]
          203  +      if {![dict exists $info $ensemble $method]} {
          204  +        dict set info $ensemble $method $body
          205  +      }
          206  +    }
          207  +  }
          208  +  return $info
          209  +}
          210  +
          211  +###
          212  +# topic: 5fa9aec3-7717-5ab6-413d-0e24ec6f008e
          213  +###
          214  +proc ::odie::class_build_properties class {
          215  +  set info {}
          216  +  set ancestors [::odie::class_ancestors $class]
          217  +  foreach ancestor $ancestors {
          218  +    foreach {var val} [get ::class_property($ancestor)] {
          219  +      if {![dict exists $info $var]} {
          220  +        dict set info $var $val
          221  +      }
          222  +    }
          223  +  }
          224  +  dict set info class [list const $class]
          225  +  dict set info ancestors [list const $ancestors]
          226  +  return $info
          227  +}
          228  +
          229  +###
          230  +# topic: 6d31677b-47b0-d566-8d91-a86902573335
          231  +# description: Return a list of IRM classes
          232  +###
          233  +proc ::odie::class_choices {} {
          234  +  return [lsort -dictionary -unique $::odie::class_list]
          235  +}
          236  +
          237  +###
          238  +# topic: 9364ad08-92de-9b3d-df4f-48cc4b31e711
          239  +###
          240  +proc ::odie::class_properties class {
          241  +  foreach {ensemble einfo} [class_build_ensembles $class] {
          242  +    set eswitch {}
          243  +    foreach {method} [lsort -dictionary [dict keys $einfo]] {
          244  +      append eswitch [list $method [dict get $einfo $method]] \n
          245  +    }
          246  +    if {![dict exists $eswitch default]} {
          247  +      set msg "error \"unknown method \[subst \$method\]. Valid: [dict keys $eswitch]\""
          248  +      append eswitch [list default $msg] \n
          249  +    }
          250  +    set body {
          251  +if {[llength $args] > 1} {
          252  +  set dictargs $args
          253  +} else {
          254  +  set dictargs [lindex $args 0]
          255  +}
          256  +  }
          257  +    append body \n "set code \[catch {switch \$method [list $eswitch]} result opts\]"
          258  +    
          259  +    #if { $ensemble == "action" } {
          260  +    #  append body \n {  if {$code == 0} { my event generate event $method {*}$dictargs}}
          261  +    #}
          262  +    append body \n {return -options $opts $result}
          263  +    oo::define $class method $ensemble {method args} $body
          264  +  }
          265  +  ###
          266  +  # Apply properties
          267  +  ###
          268  +  set info [class_build_properties $class]
          269  +  set body "my variable options
          270  +switch \$field \{"
          271  +  append body \n " [list list [list return [lsort -dictionary [dict keys $info]]]]"
          272  +  set optiondict {}
          273  +  foreach {var val} $info {
          274  +    if { $var eq "class_methods" } {
          275  +      append body \n " [list $var [dict keys $val]]"
          276  +    }
          277  +    switch [lindex $val 0] {
          278  +      eval {
          279  +        append body \n " [list $var [lindex $val 1]]"
          280  +      }
          281  +      subst {
          282  +        append body \n " [list $var [list return [subst [lindex $val 1]]]]"
          283  +      }
          284  +      const {
          285  +        append body \n " [list $var [list return [lindex $val 1]]]"        
          286  +      }
          287  +      option {
          288  +        dict set optiondict $var [lindex $val 1]
          289  +        append body \n " [list $var [list return [lindex $val 1]]]"
          290  +      }
          291  +      default {
          292  +        append body \n " [list $var [list return $val]]"
          293  +      }
          294  +    }
          295  +  }
          296  +  ###
          297  +  # Build options
          298  +  ###
          299  +  append body \n "  [list options [list return $optiondict]]"
          300  +  append body \n "\}"
          301  +  append body \n {return [my get $field]}
          302  +  oo::define $class method info field $body
          303  +  oo::define $class method property field $body
          304  +
          305  +  set cmethods {}
          306  +  foreach {method methodinfo} [dictGet $info class_methods] {
          307  +    dict with methodinfo {
          308  +      logicset add cmethods $method
          309  +      ::oo::objdefine $class method $method [get arglist] [get body]
          310  +    }
          311  +  }
          312  +  foreach anc [class_ancestors $class] {
          313  +    set ainfo [class_build_properties $anc]
          314  +
          315  +    foreach {method methodinfo} [dictGet $ainfo class_methods] {
          316  +      if {$method in $cmethods} continue
          317  +      dict with methodinfo {
          318  +        logicset add cmethods $method
          319  +        ::oo::objdefine $class method $method [get arglist] [get body]
          320  +      }
          321  +    }
          322  +  }
          323  +}
          324  +
          325  +proc ::odie::macro {name arglist body} {
          326  +  proc ::classDefine::$name $arglist $body
          327  +}
          328  +
          329  +###
          330  +# topic: bcb549b7-ddbc-16e1-aafe-14cf30ed039a
          331  +# description: Work space for the IRM class parser
          332  +###
          333  +namespace eval ::classDefine {
          334  +foreach keyword {
          335  +    constructor deletemethod destructor export filter forward  renamemethod
          336  +    self superclass unexport unknown variable
          337  +  } {
          338  +    proc $keyword args "::oo::define \[peek\] $keyword {*}\$args"
          339  +  }
          340  +  namespace export *
          341  +}
          342  +
          343  +###
          344  +# topic: ffd7dfab-3eb2-649f-4f78-349603275682
          345  +###
          346  +namespace eval ::odie {
          347  +  namespace export *
          348  +}
          349  +

Added odie/queue.tcl.

            1  +###
            2  +# queue.tcl
            3  +#
            4  +# This file defines the method needed for the tcl inplementation
            5  +# of queues
            6  +#
            7  +# Copyright (c) 2012 Sean Woods
            8  +#
            9  +# See the file "license.terms" for information on usage and redistribution of
           10  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           11  +###
           12  +
           13  +::namespace eval ::queue {}
           14  +
           15  +###
           16  +# topic: faf2fff4-8cce-65a9-1aa9-aebbd88abb93
           17  +# type: ensemble_method
           18  +###
           19  +ensemble_method ::queue::add {queuevar value} {
           20  +  upvar 1 $queuevar queue
           21  +  lappend queue $value
           22  +}
           23  +
           24  +###
           25  +# topic: efe3829e-7435-57ee-356a-2e454a035da1
           26  +# type: ensemble_method
           27  +###
           28  +ensemble_method ::queue::head_insert {queuevar value} {
           29  +  upvar 1 $queuevar queue
           30  +  set queue [linsert $queue 0 $value]
           31  +}
           32  +
           33  +###
           34  +# topic: 19078eef-4bc4-b494-9b90-eabf7e88ac1d
           35  +# type: ensemble_method
           36  +###
           37  +ensemble_method ::queue::next {queuevar resultvar} {
           38  +  upvar 1 $queuevar queue 
           39  +  upvar 1 $resultvar result
           40  +  if { [set len [llength $queue]] == 0 } { 
           41  +       set result {}
           42  +       return 0
           43  +  }
           44  +  set result [lindex $queue 0]
           45  +  if { $len == 1 } { 
           46  +       set queue {}
           47  +  } else {
           48  +    set queue [lrange $queue 1 end]
           49  +  }
           50  +  return 1 
           51  +}
           52  +
           53  +ensemble_build ::queue
           54  +

Added odie/stack.tcl.

            1  +###
            2  +# queue.tcl
            3  +#
            4  +# This file defines the method needed for the tcl inplementation
            5  +# of stacks
            6  +#
            7  +# Copyright (c) 2012 Sean Woods
            8  +#
            9  +# See the file "license.terms" for information on usage and redistribution of
           10  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           11  +###
           12  +
           13  +::namespace eval ::stack {}
           14  +
           15  +###
           16  +# topic: 31fdcfe6-70eb-f454-2963-201fa6d15d70
           17  +# type: ensemble_method
           18  +###
           19  +ensemble_method ::stack::head_insert {stackvar value} {
           20  +  upvar 1 $stackvar stack
           21  +  set stack [linsert $stack 0 $value]
           22  +}
           23  +
           24  +###
           25  +# topic: dc304faa-b514-d4ba-c7a5-f14287c4a710
           26  +# type: ensemble_method
           27  +###
           28  +ensemble_method ::stack::peek stackvar {
           29  +  upvar 1 $stackvar stack
           30  +  if {[info exists stack]} {
           31  +    return [lindex $stack end]
           32  +  }
           33  +  return {}
           34  +}
           35  +
           36  +###
           37  +# topic: 79827956-1a8b-edda-397c-f9d076b9d8a9
           38  +# type: ensemble_method
           39  +###
           40  +ensemble_method ::stack::pop {stackvar resultvar} {
           41  +  upvar 1 $stackvar stack 
           42  +  upvar 1 $resultvar result
           43  +  if { [set len [llength $stack]] == 0 } { 
           44  +       set result {}
           45  +       return 0
           46  +  }
           47  +  set result [lindex $stack end]
           48  +  if { $len == 1 } { 
           49  +       set stack {}
           50  +  } else {
           51  +    set stack [lrange $stack 0 end-1]
           52  +  }
           53  +  return 1 
           54  +}
           55  +
           56  +###
           57  +# topic: de540806-071f-5e11-d270-34e040a4b46c
           58  +# type: ensemble_method
           59  +###
           60  +ensemble_method ::stack::push {stackvar args} {
           61  +  upvar 1 $stackvar stack
           62  +  lappend stack {*}$args
           63  +}
           64  +
           65  +ensemble_build ::stack
           66  +

Added odie/yggdrasil.tcl.

            1  +###
            2  +# Structure that manages an interactive help system
            3  +###
            4  +package provide ::odie::helpdoc 0.1
            5  +
            6  +###
            7  +# topic: 57343680-c66e-0427-ac2c-217bff50a365
            8  +###
            9  +odie::class odie.yggdrasil {
           10  +  superclass moac.sqliteDb
           11  +  property create_sql {
           12  +    create table if not exists entry (
           13  +      entryid string default (uuid_generate()),
           14  +      indexed integer default 0,
           15  +      parent integer references entry (entryid),
           16  +      class string,
           17  +      name string,
           18  +      mtime integer,
           19  +      primary key (entryid)
           20  +    );
           21  +    create table if not exists property (
           22  +      entryid    string references entry (entryid),
           23  +      field      string,
           24  +      value      string,
           25  +      primary key (entryid,field)
           26  +    );
           27  +    create table if not exists link (
           28  +      linktype string,
           29  +      entry integer references entry (entryid),
           30  +      refentry integer references entry (entryid)
           31  +    );
           32  +    create table if not exists idset (
           33  +      class string,
           34  +      id    integer,
           35  +      name  string,
           36  +      primary key (class,id)
           37  +    );
           38  +    create table if not exists aliases (
           39  +      class string,
           40  +      alias string,
           41  +      cname string references entry (name),
           42  +      primary key (class,alias)
           43  +    );
           44  +    create table if not exists repository (
           45  +      handle string,
           46  +      localpath string,
           47  +      primary key (handle)
           48  +    );
           49  +    create table if not exists file (
           50  +      fileid         string default (uuid_generate()),
           51  +      repo           string references repository (handle),
           52  +      path           string,  --path relative to repo
           53  +      localpath      string,  --cached path to local file
           54  +      filename       string,  --filename
           55  +      content_type   string,  --Content/Type of file
           56  +      package        string,  --Name of any packages provided,
           57  +      size           integer, --File size in bytes
           58  +      mtime          integer, --mtime in unix time
           59  +      hash           string,   --md5 hash of file
           60  +      primary key (fileid)
           61  +    );
           62  +    create table if not exists filelink (
           63  +      linktype string,
           64  +      entryid integer references entry (entryid),
           65  +      fileid integer references file   (fileid)
           66  +    )
           67  +  }
           68  +  property create_index_sql {
           69  +    create index if not exists nameidx on entry (entryid,name);
           70  +    create index if not exists parentidx on entry (parent,entryid);
           71  +  }
           72  +  constructor filename {
           73  +    package require sqlite3
           74  +    my variable tcllib_md5
           75  +
           76  +    if {[info command ::md5] eq {} } {
           77  +      set tcllib_md5 1
           78  +      package require md5
           79  +    } else {
           80  +      set tcllib_md5 0
           81  +    }
           82  +
           83  +    catch {rename [self].db [self].db.old}
           84  +    if [catch {
           85  +      my attach db $filename
           86  +      ###
           87  +      # Allow up to 2 seconds of
           88  +      # slack time for another process to
           89  +      # write to the database
           90  +      ###
           91  +      my db timeout 2000
           92  +  
           93  +      my put [list filename $filename]
           94  +      my put [list initdir [file dir $filename]]
           95  +    }] {
           96  +      puts "Falling back to temporary storage"
           97  +      my attach db {}
           98  +      my put [list filename {}]
           99  +      my put [list initdir ~]
          100  +    }
          101  +    
          102  +    catch {rename [self].db.old {}}
          103  +    return 0
          104  +  }
          105  +
          106  +  ###
          107  +  # topic: bf756514-f69b-697b-eb91-22dd9b9bf699
          108  +  ###
          109  +  method alias_list class {
          110  +    return [my db eval {select alias,cname from aliases where class=:class order by cname,alias}]
          111  +  }
          112  +
          113  +  ###
          114  +  # topic: bd5398c9-a66d-c9f4-e692-4eb220fec800
          115  +  ###
          116  +  method canonical {class name} {
          117  +    set name [string tolower $name]
          118  +    if { $class in {{} * any}} {
          119  +      return [my db eval {select distinct class from aliases order by class}]
          120  +    }
          121  +    if { $name in {{} * any}} {
          122  +      return [my db eval {select alias,cname from aliases where class=:class order by cname,alias}]
          123  +    }
          124  +    set rows [my db eval {select entryid from entry where class=:class and name=:name}]
          125  +    if {[llength $rows] == 1} {
          126  +      return $name
          127  +    }
          128  +    if {[my db exists {select cname from aliases where class=:class and (alias=:name or cname=:name)}]} {
          129  +      return [my db one {select cname from aliases where class=:class and (alias=:name or cname=:name) limit 1}]
          130  +    }
          131  +  }
          132  +
          133  +  ###
          134  +  # topic: 093a6db9-b548-c37f-eb65-8c6f4d465dcd
          135  +  ###
          136  +  method canonical_aliases {class name} {
          137  +    set name [string tolower $name]
          138  +    return [my db eval {select distinct alias from aliases where class=:class and cname=:name and alias!=:name}]
          139  +  }
          140  +
          141  +  ###
          142  +  # topic: d6ac748e-6dff-ce69-fbd6-6cea74252a02
          143  +  ###
          144  +  method canonical_id {class name} {
          145  +    return [my db eval {select id from idset where class=:class and name=:name}]
          146  +  }
          147  +
          148  +  ###
          149  +  # topic: 7150f504-e786-fa88-0bfa-7771b344c442
          150  +  ###
          151  +  method canonical_set {type name cname} {
          152  +    set class [string tolower $type]
          153  +    set name [string tolower $name]
          154  +    set cname [string tolower $cname] 
          155  +    variable canonical_name
          156  +    dict set canonical_name $class $name $cname
          157  +    set address $type/$name
          158  +    my db eval {replace into aliases (class,alias,cname) VALUES ($class,$name,$cname)}
          159  +  }
          160  +
          161  +  ###
          162  +  # topic: c4c5d5bf-0980-7644-9f1f-8b8ac2a42f4c
          163  +  ###
          164  +  method class_list class {
          165  +    return [lsort -dictionary [my db eval {select name from entry where class=:class}]]
          166  +  }
          167  +
          168  +  ###
          169  +  # topic: c521688b-4ca8-9bf0-d46e-a724c1b7ae4f
          170  +  ###
          171  +  method class_nodes class {
          172  +    set result {}
          173  +    foreach {entryid name} [my db eval {select entryid,name from entry where class=:class order by name}] {
          174  +      lappend result $name [my node_properties $entryid]
          175  +    }
          176  +    return $result
          177  +  }
          178  +
          179  +  ###
          180  +  # topic: 10518da5-9ca8-ea62-c047-6ed05a6dbc96
          181  +  ###
          182  +  method database_create alias {
          183  +    my $alias eval [my property create_sql]
          184  +  }
          185  +
          186  +  ###
          187  +  # topic: 5adf83a8-668b-157b-e6fa-72716a3998de
          188  +  ###
          189  +  method database_functions alias {
          190  +    package require uuid
          191  +    $alias function uuid_generate [list [self] uuid_generate]
          192  +  }
          193  +
          194  +  ###
          195  +  # topic: 4c04478b-06d5-9bd5-8ae1-a6df2170d2e9
          196  +  ###
          197  +  method enum_dump class {
          198  +    return [my eval {select id,name from idset where class=:class order by id}]
          199  +  }
          200  +
          201  +  ###
          202  +  # topic: a1250c93-e5cd-53c1-93df-d7832c47357c
          203  +  ###
          204  +  method enum_id {class name} {
          205  +    set arr ::irm::${class}_name_to_idx
          206  +    if {![info exists $arr]} {
          207  +      my db eval {select name as aname,id as aid from idset where class=:class} {
          208  +        set ${arr}($aname) $aid
          209  +      }
          210  +    }
          211  +    set cname [my canonical $class $name]
          212  +    if {![info exists ${arr}($cname)]} {
          213  +      error "Invalid $class $name"
          214  +    }
          215  +    return [set ${arr}($cname)]
          216  +  }
          217  +
          218  +  ###
          219  +  # topic: ded135de-4cb9-003c-7bb4-70b7943052b1
          220  +  ###
          221  +  method enum_name {class id} {
          222  +    return [my db one {select name from idset where class=:class and id=:id}]
          223  +  }
          224  +
          225  +  ###
          226  +  # topic: 76cfb43e-2bfd-986c-3316-d3706061dba6
          227  +  ###
          228  +  method enum_set {class name id} {
          229  +    set class [string tolower $class]
          230  +    set name [string tolower $name]
          231  +    set ::irm::${class}_name_to_idx($name) $id
          232  +    set ::irm::${class}_idx_to_name($id) $name
          233  +    my db eval {insert or replace into idset (class,id,name) VALUES ($class,$id,$name)}
          234  +  }
          235  +
          236  +  ###
          237  +  # topic: 1c6106a6-8bf6-9dcc-021d-b31cbb561d4d
          238  +  ###
          239  +  method file_hash {fileid {newhash {}}} {
          240  +    set fileid [my file_id $fileid]
          241  +    if {$fileid ne {}} {
          242  +      return [my db one {select hash from file where fileid=:fileid}]
          243  +    }
          244  +    return {}
          245  +  }
          246  +
          247  +  ###
          248  +  # topic: 9a2b2f20-ada2-155c-8a72-5917435ac127
          249  +  ###
          250  +  method file_id {addr {create 0}} {
          251  +    if {[string is integer $addr]} {
          252  +      return $addr
          253  +    }
          254  +    if {[my db exists {select fileid from file where hash=:addr}]} {
          255  +      return [my db one {select fileid from file where hash=:addr}]
          256  +    }
          257  +    if {[llength $addr]==2} {
          258  +      set repo [lindex $addr 0]
          259  +      set path [lindex $addr 1]
          260  +      if {[my db exists {select fileid from file where repo=:repo and path=:path}]} {
          261  +        return [my db one {select fileid from file where repo=:repo and path=:path}]
          262  +      }
          263  +    }
          264  +    if {[my db exists {select fileid from file where path=:addr}]} {
          265  +      return [my db one {select fileid from file where path=:addr}]
          266  +    }
          267  +    if {[my db exists {select fileid from file where localpath=:addr}]} {
          268  +      return [my db one {select fileid from file where localpath=:addr}]
          269  +    }
          270  +    return {}
          271  +  }
          272  +
          273  +  ###
          274  +  # topic: 78c6fca8-3198-1b80-cc69-3b3ed59334b0
          275  +  ###
          276  +  method file_restore {nodeid info} {
          277  +    set stmtl {}
          278  +    dict with info {}
          279  +    if {[string is integer $nodeid]} {
          280  +      set _fileid $nodeid
          281  +    } else {
          282  +      set _fileid [my file_id $nodeid]
          283  +      if {$_fileid eq {}} {
          284  +        set _fileid {}
          285  +      }
          286  +    }
          287  +    if {$_fileid ne {}} {
          288  +      set fields fileid
          289  +      set values "\$_fileid"
          290  +    } else {
          291  +      set fields {}
          292  +      set values {}
          293  +    }
          294  +    foreach {field value} $info {
          295  +      switch $field {
          296  +        repo -
          297  +        path -
          298  +        localpath -
          299  +        filename -
          300  +        content_type -
          301  +        package -
          302  +        size -
          303  +        mtime -
          304  +        hash {
          305  +          if { $value ne {} } {
          306  +            lappend fields $field
          307  +            lappend values :_$field
          308  +            set _$field $value
          309  +          }
          310  +        }
          311  +      }
          312  +    }
          313  +    my db eval "insert or replace into file ([join $fields ,]) VALUES ([join $values ,]);"
          314  +  }
          315  +
          316  +  ###
          317  +  # topic: 2d990f66-5ca7-6ad2-e5ef-05e364399b49
          318  +  ###
          319  +  method file_serialize nodeid {
          320  +    set result {}
          321  +    my db eval {
          322  +      select * from file
          323  +      where fileid=$nodeid
          324  +    } record {
          325  +      set fileid $record(fileid)
          326  +      append result "[list [self] file_restore [list $record(repo) $record(path)]] \{" \n
          327  +      
          328  +      foreach {field value} [array get record] {
          329  +        if { $field in {* fileid indexed export} } continue
          330  +        append result "  [list $field $value]" \n
          331  +      }
          332  +      append result "\}"
          333  +    }
          334  +    return $result
          335  +  }
          336  +
          337  +  ###
          338  +  # topic: 2514ca1a-6e9c-1af1-275c-1ea253706daa
          339  +  ###
          340  +  method link_create {entryid to {type {}}} {
          341  +    if { $type eq {} } {
          342  +      set exists [my one {select count(entry) from link where entry=$entryid and refentry=$to}]
          343  +      if {!$exists} {
          344  +        my db eval {insert or replace into link (entry,refentry) VALUES ($entryid,$to)}
          345  +      }
          346  +    } else {
          347  +      set exists [my one {select count(entry) from link where entry=$entryid and refentry=$to and linktype=$type}]
          348  +      if {!$exists} {
          349  +        my db eval {insert or replace into link (entry,refentry,linktype) VALUES ($entryid,$to,$type)}
          350  +      } 
          351  +    }
          352  +  }
          353  +
          354  +  ###
          355  +  # topic: f9685bcf-fb03-9e78-3938-4898c01a59c5
          356  +  ###
          357  +  method link_detect_address args {
          358  +    if {[my node_exists $args entryid]} {
          359  +      return [my eval {select entryid from entry where entryid=$entryid}]
          360  +    }
          361  +    ###
          362  +    # If the link contains a / we know it is a hard
          363  +    # path
          364  +    ###
          365  +    if {[my node_exists $args entryid]} {
          366  +      return $entryid
          367  +    }
          368  +    if {[llength $args] > 1} {
          369  +      set rootentries [my eval {select name from entry where class='section'}]
          370  +      
          371  +      if {[lindex $args 0] in $rootentries} {
          372  +        set type [lindex $args 0]
          373  +        set name [my canonical $type [lindex $args 1]]
          374  +        if {[my node_exists [list $type $name] entryid]} {
          375  +          return $entryid
          376  +        }
          377  +      }
          378  +      if {[lindex $args 1] in $rootentries} {
          379  +        set type [lindex $args 1]
          380  +        set name [my canonical $type [lindex $args 0]]
          381  +        if {[my node_exists [list $type $name] entryid]} {
          382  +          return $entryid
          383  +        }
          384  +      }
          385  +    }
          386  +    set addr [lindex $args 0]
          387  +    set cnames [my eval {select class,cname from aliases where alias=$addr}]
          388  +  
          389  +    if {[llength $cnames] == 2} {
          390  +      if {[my node_exists $cnames entryid]} {
          391  +        return $entryid
          392  +      }
          393  +    }
          394  +    #if {[string first / $addr] > 0 } {
          395  +    #  return $addr
          396  +    #}
          397  +    set candidates [my eval {select entryid,name from entry where name like '%$addr%'}]
          398  +    foreach address $candidates {
          399  +      if {[regexp simnode $address]} {
          400  +        return $address
          401  +      }
          402  +    }
          403  +    #puts [list CAN'T RESOLVE $args]
          404  +    return $args
          405  +  }
          406  +
          407  +  ###
          408  +  # topic: 612a2335-0b20-ae08-c159-97a025d11390
          409  +  ###
          410  +  method node_alloc_child {parent entry {class {}}} {
          411  +    if { $parent eq $class } {
          412  +      set row [my one {select entryid from entry where parent is null and class=$class and name=$entry}]
          413  +    } elseif { $class ne {} } {
          414  +      set row [my one {select entryid from entry where parent=$parent and class=$class and name=$entry}]    
          415  +    } else {
          416  +      set row [my one {select entryid from entry where parent=$parent and name=$entry}]    
          417  +    }
          418  +    if { [llength $row] && $row != $parent } {
          419  +      return $row
          420  +    }
          421  +    set row [my uuid_generate $parent $class $entry]
          422  +    if { $class eq $parent } {
          423  +      set row $parent/$entry
          424  +      my db eval {insert into entry (entryid,class,name) VALUES ($row,$parent,$entry)}
          425  +    } elseif { $class ne {} } {
          426  +      my db eval {insert into entry (entryid,parent,class,name) VALUES ($row,$parent,$class,$entry)}
          427  +    } else {
          428  +      my db eval {insert into entry (entryid,parent,name) VALUES ($row,$parent,$entry)}
          429  +    }
          430  +    return $row
          431  +  }
          432  +
          433  +  ###
          434  +  # topic: 522463d0-c361-0c5e-1e00-06469359750b
          435  +  # description:
          436  +  #    Return a list of all children of node,
          437  +  #    Filter is a key/value list that understands
          438  +  #    the following:
          439  +  #    type - Limit children to type
          440  +  #    dump - Output the contents of the child node, not their id
          441  +  ###
          442  +  method node_children {nodeid class} {
          443  +    set dump 1
          444  +    set entryid [my node_id $nodeid]
          445  +    if { $class eq {} } {
          446  +      set nodes [my eval {select name,entryid from entry where parent=$entryid}]
          447  +    } else {
          448  +      set nodes [my eval {select name,entryid from entry where parent=$entryid and class=$class}]
          449  +    }
          450  +    if {!$dump} {
          451  +      return $nodes
          452  +    }
          453  +    set result {}
          454  +    foreach {cname cid} $nodes {
          455  +      dict set result $cname [my eval {select field,value from property where entryid=$cid order by field}]
          456  +    }
          457  +    return $result
          458  +  }
          459  +
          460  +  ###
          461  +  # topic: b4954836-f396-6f2c-92cc-4c8251572bd8
          462  +  ###
          463  +  method node_define {class name info {nodeidvar {}}} {
          464  +    if {$nodeidvar ne {}} {
          465  +      upvar 1 $nodeidvar nodeid
          466  +    }
          467  +    
          468  +    if { $class eq {} || $class eq "section" } {
          469  +      set nodeid $name
          470  +    } else {
          471  +      set nodeid {}
          472  +      if {[dict exists $info topic]} {
          473  +        set nodeid [dict get $info topic]
          474  +        dict unset info topic
          475  +      }
          476  +    }    
          477  +    if { $nodeid eq {} } {
          478  +      if {![my node_exists [list $class $name] nodeid]} {
          479  +        set nodeid [helpdoc node_id [list $class $name] 1]
          480  +        foreach {var val} [my node_empty $class] {
          481  +          my node_property_set $nodeid $var $val        
          482  +        }
          483  +      }
          484  +    } elseif {![my node_exists $nodeid]} {
          485  +      my canonical_set $class $name $name
          486  +      my eval {insert into entry (entryid,class,name) VALUES (:nodeid,:class,:name)}
          487  +      foreach {var val} [my node_empty $class] {
          488  +        my node_property_set $nodeid $var $val        
          489  +      }
          490  +    }
          491  +  
          492  +    foreach {var val} $info {
          493  +      my node_property_set $nodeid $var $val
          494  +    }
          495  +  }
          496  +
          497  +  ###
          498  +  # topic: 07210b77-287a-e0a4-b5e5-d877a5aadb15
          499  +  ###
          500  +  method node_define_child {parent class name info {nodeidvar {}}} {
          501  +    if {$nodeidvar ne {}} {
          502  +      upvar 1 $nodeidvar nodeid
          503  +    }
          504  +    ###
          505  +    # Return an already registered node with this address
          506  +    ###
          507  +    if {[my db exists {select entryid from entry where parent=:parent and class=:class and name=:name}]} {
          508  +      set nodeid [my db one {select entryid from entry where parent=:parent and class=:class and name=:name}]
          509  +    } else {
          510  +      set nodeid {}
          511  +  
          512  +      if {[dict exists $info topic]} {
          513  +        set topicid [dict get $info topic]
          514  +        dict unset info topic
          515  +        if {![my db exists {select entryid from entry where entryid=:topicid}]} {
          516  +          # If we are recycling an unused UUID re-create the entry in the table
          517  +          my eval {insert into entry (entryid,parent,class,name) VALUES (:topicid,:parent,:class,:name)}
          518  +          set nodeid $topicid
          519  +        }
          520  +      }
          521  +      if { $nodeid eq {} } {
          522  +        set nodeid [my uuid_generate $parent $class $name]
          523  +      }
          524  +      if {[my db exists {select entryid from entry where entryid=:nodeid and class=:class and name=:name}]} {
          525  +        ###
          526  +        # Correct a misfiled node
          527  +        ###
          528  +        my db eval {update entry set parent=:parent where entryid=:nodeid}
          529  +      } else {
          530  +        my eval {insert into entry (entryid,parent,class,name) VALUES (:nodeid,:parent,:class,:name)}
          531  +      }
          532  +      foreach {var val} [my node_empty $class] {
          533  +        if {![dict exists $info $var]} {
          534  +          dict set info $var $val
          535  +        }
          536  +      }
          537  +    }
          538  +    foreach {var val} $info {
          539  +      my node_property_set $nodeid $var $val        
          540  +    }
          541  +    return $nodeid
          542  +  }
          543  +
          544  +  ###
          545  +  # topic: ea04bf60-c884-5477-a841-87bb3d571e16
          546  +  ###
          547  +  method node_empty class {
          548  +    set id [my db one {select entryid from entry where name=:class and class='section'}]
          549  +    return [my db one {select value from property where entryid=:id and field='template'}]
          550  +  }
          551  +
          552  +  ###
          553  +  # topic: c7b902b4-c9de-98dc-8230-c099b75a2067
          554  +  ###
          555  +  method node_exists {node {resultvar {}}} {
          556  +    set parent 0
          557  +    if { $resultvar != {} } {
          558  +      upvar 1 $resultvar row
          559  +    }
          560  +    if {[llength $node]==1} {
          561  +      set name [lindex $node 0]
          562  +      if {[my db exists {select entryid from entry where name=:name or entryid=:name}]} {
          563  +        set row [my db one {select entryid from entry where name=:name or entryid=:name}]
          564  +        return 1
          565  +      }
          566  +    } elseif {[llength $node]==2} {
          567  +      set class [lindex $node 0]
          568  +      set name [lindex $node 1]
          569  +      if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
          570  +        set row [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
          571  +        return 1
          572  +      }
          573  +    }
          574  +    set class [lindex $node 0]
          575  +    set name [lindex $node 1]
          576  +    if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
          577  +      set parent [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
          578  +    } else {
          579  +      return 0
          580  +    }
          581  +    foreach {eclass ename} [lrange $node 2 end] {
          582  +      set row {}
          583  +      if {$eclass eq {}} {
          584  +        if {[my db exists {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]} {
          585  +          set row [my db one {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]
          586  +        }
          587  +      } else {
          588  +        if {[my db exists {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]} {
          589  +          set row [my db one {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]
          590  +        }
          591  +      }
          592  +      if { $row eq {} } {
          593  +        return 0
          594  +      }
          595  +      set parent $row
          596  +    }
          597  +    return 1
          598  +  }
          599  +
          600  +  ###
          601  +  # topic: 7f77641d-fbdf-50bc-acfe-1513f2d0a267
          602  +  ###
          603  +  method node_get {nodeid {field {}}} {
          604  +    set result {}
          605  +    if {[my node_exists $nodeid entryid]} {
          606  +      set result [helpdoc node_properties $entryid]
          607  +    } else {
          608  +      if {[llength $nodeid] > 1} {
          609  +        set type [lindex $nodeid 0]
          610  +        set result [my node_empty $type]
          611  +      }
          612  +    }
          613  +    if { $field eq {} } {
          614  +      return $result    
          615  +    }
          616  +    return [dictGet $result $field]
          617  +  }
          618  +
          619  +  ###
          620  +  # topic: b2ab54e8-34d9-7dbe-cfa9-21066fc20d4e
          621  +  ###
          622  +  method node_id {node {create 0}} {
          623  +    if {[my db exists {select entryid from entry where entryid=:node;}]} {
          624  +      return [my db one {select entryid from entry where entryid=:node;}]
          625  +    }
          626  +    if {[llength $node]==1} {
          627  +      set name [lindex $node 0]
          628  +      if {[my db exists {select entryid from entry where name=:name or entryid=:name}]} {
          629  +        return [my db one {select entryid from entry where name=:name or entryid=:name}]
          630  +      }
          631  +      if { $create } {
          632  +        my db eval {insert into entry (class,name) VALUES ('section',:name)}
          633  +        return $name
          634  +      } else {
          635  +        error "Node $node does not exist"
          636  +      }
          637  +    } elseif {[llength $node]==2} {
          638  +      set class [lindex $node 0]
          639  +      set name [lindex $node 1]
          640  +
          641  +      if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
          642  +        set row [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
          643  +        return $row
          644  +      }
          645  +    }
          646  +    set class [lindex $node 0]
          647  +    set name [lindex $node 1]
          648  +    if {[my db exists {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]} {
          649  +      set parent [my db one {select entryid from entry where (class=:class or parent=:class) and (name=:name or entryid=:name)}]
          650  +    } else {
          651  +      if {!$create} {
          652  +        error "Node $node does not exist"
          653  +      }
          654  +
          655  +      ###
          656  +      # If the name contains no spaces, dots, slashes, or ::
          657  +      ###
          658  +      set row [my uuid_generate $class $name]
          659  +      my db eval {insert into entry (entryid,class,name) VALUES (:row,:class,:name)}
          660  +      set parent $row
          661  +    }
          662  +    if { $create } {
          663  +      set classes [my db eval {select distinct class from entry}]
          664  +    }
          665  +    set eclass {}
          666  +    foreach token [lrange $node 2 end] {
          667  +      set ename $token
          668  +      set row {}
          669  +      if {$eclass eq {}} {
          670  +        if {[my db exists {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]} {
          671  +          set row [my db one {select entryid from entry where parent=:parent and (entryid=:ename or name=:ename)}]
          672  +        }
          673  +      } else {
          674  +        if {[my db exists {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]} {
          675  +          set row [my db one {select entryid from entry where parent=:parent and class=:eclass and (entryid=:ename or name=:ename)}]
          676  +        }
          677  +      }
          678  +      if { $row eq {} } {
          679  +        if { $create } {
          680  +          if { $ename in $classes } {
          681  +            set eclass $token
          682  +            continue            
          683  +          } else {
          684  +            set eclass {}
          685  +            set row [my node_alloc_child $parent $ename $eclass]
          686  +          }          
          687  +        } else {
          688  +          error "Node $node does not exist"
          689  +        }
          690  +      }
          691  +      set parent $row
          692  +    }
          693  +    return $row
          694  +  }
          695  +
          696  +  ###
          697  +  # topic: eb137c42-eacd-7016-7a91-7056ba96ed70
          698  +  ###
          699  +  method node_properties entryid {
          700  +    return [my eval {select field,value from property where entryid=$entryid}]
          701  +  }
          702  +
          703  +  ###
          704  +  # topic: 8d72229b-f33b-acd0-cd41-b4584fa240eb
          705  +  ###
          706  +  method node_property_append {nodeid field text} {
          707  +    set buffer [my one {select value from property where entryid=:nodeid and field=:field}]
          708  +    append buffer " " [string trim $text]
          709  +    my db eval {insert or replace into property (entryid,field,value) VALUES (:nodeid,:field,:buffer)}
          710  +  }
          711  +
          712  +  ###
          713  +  # topic: e1a3da3c-7005-1c92-0aed-5bde26228ee1
          714  +  ###
          715  +  method node_property_get {nodeid field} {
          716  +    return [my db one {select value from property where entryid=:nodeid and field=:field}]
          717  +  }
          718  +
          719  +  ###
          720  +  # topic: c4e91fb2-44d0-aee6-8454-1effc7012081
          721  +  # description: nodeid is any value acceptable to {[my node_alloc]}
          722  +  ###
          723  +  method node_property_lappend {entryid field args} {
          724  +    if {![llength $args]} return
          725  +    set dbvalue [my eval {select value from property where entryid=$entryid and field=$field}]
          726  +    foreach value $args {
          727  +      if { $value eq {} } continue
          728  +      logicset add dbvalue $value
          729  +    }
          730  +    my db eval {update property set value=$dbvalue where entryid=$entryid and field=$field}
          731  +  }
          732  +
          733  +  ###
          734  +  # topic: 89d208ff-7b88-3985-1167-8c025f82d4d6
          735  +  ###
          736  +  method node_property_set {entryid args} {
          737  +    my variable property_info property_cname
          738  +    if {[llength $args]==1} {
          739  +      set arglist [lindex $args 0]
          740  +    } else {
          741  +      set arglist $args
          742  +    }
          743  +    foreach {field value} $arglist {
          744  +      if {[info exists property_cname($field)]} {
          745  +        set cname $property_cname($field)
          746  +        set rawvalue $value
          747  +        eval [dictGet $property_info $cname script]
          748  +      } else {
          749  +        set cname $field
          750  +      }
          751  +      if {![my db exists {select value from property where entryid=:entryid and field=:cname and value=:value}]} {
          752  +        my db eval {insert or replace into property (entryid,field,value) VALUES (:entryid,:cname,:value)}
          753  +      }
          754  +    }
          755  +  }
          756  +
          757  +  ###
          758  +  # topic: f7de1b2d-7c51-6c15-abfa-5a2a2f4d4b22
          759  +  ###
          760  +  method node_restore {nodeid info} {
          761  +    set stmtl {}
          762  +    dict with info {}
          763  +    set fields entryid
          764  +    set _entryid $nodeid
          765  +    set values "\$_entryid"
          766  +    
          767  +    foreach {field value} $info {
          768  +      switch $field {
          769  +        properties {
          770  +          foreach {var val} $value {
          771  +            my node_property_set $_entryid $var $val
          772  +          }
          773  +        }
          774  +        references {
          775  +          foreach {refid reftype} $references {
          776  +            my link_create $_entryid $refid $reftype
          777  +          }
          778  +        }
          779  +        enumid {
          780  +          my enum_set [lindex $value 0] [dict get $info name] [lindex $value 1]
          781  +        }
          782  +        aliases {
          783  +          foreach a $value {
          784  +            my canonical_set $_class $a $_name
          785  +          }
          786  +        }
          787  +        parent {
          788  +          if {![string is integer $value]} {
          789  +            set value [my node_id $value 1]
          790  +          }
          791  +          lappend fields $field
          792  +          lappend values "\$_$field"
          793  +          set _$field $value            
          794  +        }
          795  +        class -
          796  +        address -
          797  +        name {
          798  +          if { $value ne {} } {
          799  +            lappend fields $field
          800  +            lappend values "\$_$field"
          801  +            set _$field $value
          802  +          }
          803  +        }
          804  +      }
          805  +    }
          806  +    my db eval "insert or replace into entry ([join $fields ,]) VALUES ([join $values ,]);"
          807  +  }
          808  +
          809  +  ###
          810  +  # topic: 478123c9-d7df-a4ed-e50f-4b6ae0778ae0
          811  +  ###
          812  +  method node_serialize nodeid {
          813  +    set result {}
          814  +    my db eval {
          815  +      select * from entry
          816  +      where entryid=$nodeid
          817  +    } record {
          818  +      set entryid $record(entryid)
          819  +      append result "[list [self] node_restore $entryid] \{" \n
          820  +      
          821  +      foreach {field value} [array get record] {
          822  +        if { $field in {* entryid indexed export} } continue
          823  +        append result "  [list $field $value]" \n
          824  +      }
          825  +      set class $record(class)
          826  +  
          827  +      set id [my canonical_id $class $record(name)]
          828  +      if { $id ne {} } {
          829  +          append result "  [list enumid [list $class $id]]" \n
          830  +      }
          831  +      
          832  +      append result "  properties \{" \n
          833  +      set info [my node_empty $record(class)]
          834  +      foreach {var val} [my node_properties $entryid] {
          835  +        dict set info $var $val
          836  +      }
          837  +
          838  +      foreach {var} [lsort -dictionary [dict keys $info]] {
          839  +        if { $var in {aliases field method fields methods references id} } continue
          840  +        append result "    [list $var [string trim [dict get $info $var]]]" \n
          841  +      }
          842  +      
          843  +      append result "  \}" \n
          844  +      set references [my db eval {select refentry,linktype from link where entry=$entryid}]
          845  +      if {[llength $references]} {
          846  +        append result "  [list references $references]" \n
          847  +      }
          848  +      set aliases [my canonical_aliases $record(class) $record(name)]
          849  +      if {[llength $aliases]} {
          850  +        append result "  [list aliases $aliases]" \n
          851  +      }
          852  +      set attachments [my db eval {select file.hash,filelink.linktype from file,filelink where filelink.entryid=$entryid and filelink.fileid=file.fileid}]
          853  +      if {[llength $attachments]} {
          854  +        append result "  [list attachments $attachments]" \n
          855  +      }
          856  +      append result "\}"
          857  +    }
          858  +    return $result
          859  +  }
          860  +
          861  +  ###
          862  +  # topic: e2cc4f04-58df-6611-55d2-1e0861a67299
          863  +  ###
          864  +  method property_define {property info} {
          865  +    my variable property_info property_cname
          866  +    foreach {f v} $info {
          867  +      dict set property_info $property $f $v
          868  +    }
          869  +    foreach alias [dictGet $property_info $property aliases] {
          870  +      set property_cname($alias) $property
          871  +    }
          872  +    set property_cname($property) $property
          873  +  }
          874  +
          875  +  ###
          876  +  # topic: 540bbeb4-3def-889d-5c48-72bebf9ace6a
          877  +  ###
          878  +  method reindex {} {
          879  +    my variable canonical_name
          880  +    my db eval {select class,alias,cname from aliases order by class,cname,alias} {
          881  +      dict set canonical_name $class $alias $cname
          882  +    }
          883  +  }
          884  +
          885  +  ###
          886  +  # topic: 0301bbb1-0f67-8314-b81d-f4a3d30b3123
          887  +  ###
          888  +  method repository_restore {handle info} {
          889  +    set stmtl {}
          890  +    dict with info {}
          891  +    set fields handle
          892  +    set _handle $handle
          893  +    set values "\$_handle"
          894  +    foreach {field value} $info {
          895  +      switch $field {
          896  +        localpath {
          897  +          if { $value ne {} } {
          898  +            lappend fields $field
          899  +            lappend values "\$_$field"
          900  +            set _$field $value
          901  +          }
          902  +        }
          903  +      }
          904  +    }
          905  +    my db eval "insert or replace into repository ([join $fields ,]) VALUES ([join $values ,]);"
          906  +  }
          907  +
          908  +  ###
          909  +  # topic: e89c52fc-d941-f3a3-f2ef-9957ddbb63f2
          910  +  # description:
          911  +  #    Because the tcllib version of uuid generate requires
          912  +  #    network port access (which can be slow), here's a fast
          913  +  #    and dirty rendition
          914  +  ###
          915  +  method uuid_generate args {
          916  +    my variable tcllib_md5
          917  +    if {![llength $args]} {
          918  +      set block [list [info hostname] [get env(USER)] [get env(user)] [clock seconds] [clock microseconds]]
          919  +    } else {
          920  +      set block $args
          921  +    }
          922  +    if {$tcllib_md5} {
          923  +      set tok [md5::MD5Init]  
          924  +      foreach item $block {
          925  +        md5::MD5Update $tok $item
          926  +      }
          927  +      set uuid [md5::MD5Final $tok]
          928  +    } else {
          929  +      set uuid [md5 [join $block ""]]
          930  +    }
          931  +    binary scan $uuid H* s
          932  +    foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
          933  +        append r [string range $s $a $b] -
          934  +    }
          935  +    return [string tolower [string trimright $r -]]
          936  +
          937  +  }
          938  +}
          939  +

Changes to server.tcl.

    91     91   
    92     92   		#$handler message $sock $msg
    93     93   		#puts "ws receive $sock $msg"
    94     94   		set sessionid [dict get $::sock($sock) sessionid]
    95     95   
    96     96   		set cmd $msg
    97     97   		if {$::events_on_stdout} {puts "WSCLIENT: $cmd"}
    98         -		[dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]
           98  +		[dict get $::session($sessionid) interp] eval ::wtk::fromclient [list $cmd]
    99     99   	}
   100    100   }
   101    101   
   102    102   
   103    103   proc ws_upgrade {sock data} {
   104    104   	fileevent $sock readable {}
   105    105   
................................................................................
   210    210   	if {$isnewsess} {
   211    211   		set interp [interp create]
   212    212   		dict set ::session($sessionid) interp $interp
   213    213   		dict set ::session($sessionid) sock $sock
   214    214   		dict set ::session($sessionid) wsock 0
   215    215   		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
   216    216   		$interp alias sendto toclient $sessionid
   217         -		$interp eval wtk::init sendto
          217  +		$interp eval ::wtk::init sendto
   218    218   	} else {
   219    219   		dict set ::session($sessionid) wsock 0
   220    220   		set interp [dict get $::session($sessionid) interp]
   221    221   		$interp eval namespace delete ::wtk
   222    222   		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
   223         -		$interp eval wtk::init sendto
          223  +		$interp eval ::wtk::init sendto
   224    224   	}
   225    225   
   226    226   	#update the clients cookie, todo: should do this periodically
   227    227   	set msgq "(function () { document.cookie= 'wtksess=${sessionid};expires=0;path=/;' })();"
   228    228   	dict set ::session($sessionid) msgq $msgq
   229    229   
   230    230   	#pass in the server header vars first
................................................................................
   242    242   }
   243    243   
   244    244   
   245    245   # fromclient -- Receive a message from a web client and route it to the correct app instance
   246    246   #
   247    247   # This is called when the client wants to send its application instance a message (via
   248    248   # the /wtkcb.html callback in this case), typically an event like a button press.
   249         -# We invoke the 'wtk::fromclient' routine in the instance's interpreter to process it.
   250         -proc fromclient {sessionid cmd} {puts "CLIENT: $cmd"; [dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]}
          249  +# We invoke the '::wtk::fromclient' routine in the instance's interpreter to process it.
          250  +proc fromclient {sessionid cmd} {puts "CLIENT: $cmd"; [dict get $::session($sessionid) interp] eval ::wtk::fromclient [list $cmd]}
   251    251   
   252    252   
   253    253   # toclient -- Send Javascript commands from an app instance to the web client
   254    254   #
   255    255   # This is called when the application instance wants to send its client a message,
   256    256   # in the form of a Javascript command.  The message is queued and the actual
   257    257   # sending is taken care of by the next routine.

Changes to sketch.tcl.

     1      1   set color black
     2         -wtk::grid [wtk::canvas .c -width 400 -height 400 -background #eeeeee] -column 0 -row 0
     3         -wtk::bind .c <1> "set x %x; set y %y"
     4         -wtk::bind .c <B1-Motion> { 
            2  +::wtk::grid [::wtk::canvas .c -width 400 -height 400 -background #eeeeee] -column 0 -row 0
            3  +::wtk::bind .c <1> "set x %x; set y %y"
            4  +::wtk::bind .c <B1-Motion> { 
     5      5      .c create line $x $y %x %y -fill $color
     6      6      set x %x; set y %y
     7      7   }
     8      8   
     9      9   set colors "black blue red green yellow orange brown"
    10         -wtk::grid [wtk::canvas .palette -background #cccccc -width 400 -height 30] -column 0 -row 2
           10  +::wtk::grid [::wtk::canvas .palette -background #cccccc -width 400 -height 30] -column 0 -row 2
    11     11   set x 25
    12     12   foreach i $colors {
    13     13       .palette bind [.palette create rectangle $x 5 [expr {$x+25}] 25 -fill $i] <1> "set color $i"
    14     14       incr x 28
    15     15   }

Changes to widgets/button.tcl.

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

Changes to widgets/canvas.tcl.

     1      1   
     2      2   # Canvas
     3         -snit::type canvas {
     4         -    typevariable itemtypes "line rectangle"
     5         -    typevariable opts.line {-fill strokeStyle -width lineWidth}
     6         -    typevariable opts.rectangle {-fill fillStyle -width lineWidth -outline strokeStyle}
     7         -    _wtkwidget
     8         -    _wtkoption -width 100 {$JS.width=$V;$JS.style.width='${V}px';}
     9         -    _wtkoption -height 100 {$JS.height=$V;$JS.style.height='${V}px';}
    10         -    _wtkoption -background "#ffffff" {$JS.style.background='$V';}
            3  +odie::class ::wtk::canvas {
            4  +  superclass wtk::Widget
            5  +
            6  +  property itemtypes "line rectangle"
            7  +  property opts.line {-fill strokeStyle -width lineWidth}
            8  +  property opts.rectangle {-fill fillStyle -width lineWidth -outline strokeStyle}
            9  +
           10  +  _wtkoption -width 100 {$JS.width=$V;$JS.style.width='${V}px';}
           11  +  _wtkoption -height 100 {$JS.height=$V;$JS.style.height='${V}px';}
           12  +  _wtkoption -background "#ffffff" {$JS.style.background='$V';}
    11     13   
    12         -    variable mousedown 0
    13         -    variable nextid 1
    14         -    variable items
    15         -    method _createjs {} {return "wtk.createCanvas('[$self id]');"}
    16         -    method create {itemtype args} {
    17         -        if {$itemtype ni $itemtypes} {error "bad item type"}
    18         -        lassign [_parseCoordsAndOptions $args [set opts.$itemtype]] coords opts
    19         -        set cid $nextid; incr nextid
    20         -        set items($cid) [list type $itemtype coords $coords]
    21         -        wtk::toclient "wtk.objs\['[$self id]'\].createItem($cid,'$itemtype',\[[join $coords ,]\],$opts);"
    22         -        return $cid
    23         -    }
    24         -    method _event {which args} {; # todo - make generic
    25         -        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}}
    26         -        if {$which=="mousemove"} {if {$mousedown} {set ev "<B1-Motion>"} else {set ev "<Motion>"}; $W _fireevent $ev [list %x [lindex $args 0] %y [lindex $args 1]]}
    27         -        if {$which=="mouseup"} {set mousedown 0; $W _fireevent "<B1-Release>" [list %x [lindex $args 0] %y [lindex $args 1]]}
    28         -    }
    29         -    proc _parseCoordsAndOptions {s optmap} {
    30         -        set coords ""; set inopts 0; set opts ""
    31         -        foreach {x y} [split $s] {
    32         -            if {!$inopts && [string is integer $x]} {
    33         -                if {![string is integer $y]} {error "odd number of coordinates"}
    34         -                lappend coords $x $y
    35         -            } else {
    36         -                set inopts 1
    37         -                if {![dict exists $optmap $x]} {error "bad option"}
    38         -                lappend opts "[dict get $optmap $x]:\"$y\""
    39         -            }
    40         -        }
    41         -        return [list $coords "\{[join $opts ,]\}"]
    42         -    }
           14  +  variable mousedown 0
           15  +  variable nextid 1
           16  +  variable items
           17  +  
           18  +  method do_createjs {} {return "wtk.createCanvas('[my id]');"}
           19  +  
           20  +  method create {itemtype args} {
           21  +      if {$itemtype ni [my property itemtypes]} {error "bad item type"}
           22  +      lassign [_parseCoordsAndOptions $args [my property opts.$itemtype]] coords opts
           23  +      set cid $nextid; incr nextid
           24  +      set items($cid) [list type $itemtype coords $coords]
           25  +      ::wtk::toclient "wtk.objs\['[my id]'\].createItem($cid,'$itemtype',\[[join $coords ,]\],$opts);"
           26  +      return $cid
           27  +  }
           28  +  
           29  +  method wtk_event {which args} {; # todo - make generic
           30  +      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}}
           31  +      if {$which=="mousemove"} {if {$mousedown} {set ev "<B1-Motion>"} else {set ev "<Motion>"}; $W event_fire $ev [list %x [lindex $args 0] %y [lindex $args 1]]}
           32  +      if {$which=="mouseup"} {set mousedown 0; $W event_fire "<B1-Release>" [list %x [lindex $args 0] %y [lindex $args 1]]}
           33  +  }
           34  +  
           35  +  method _parseCoordsAndOptions {s optmap} {
           36  +      set coords ""; set inopts 0; set opts ""
           37  +      foreach {x y} [split $s] {
           38  +          if {!$inopts && [string is integer $x]} {
           39  +              if {![string is integer $y]} {error "odd number of coordinates"}
           40  +              lappend coords $x $y
           41  +          } else {
           42  +              set inopts 1
           43  +              if {![dict exists $optmap $x]} {error "bad option"}
           44  +              lappend opts "[dict get $optmap $x]:\"$y\""
           45  +          }
           46  +      }
           47  +      return [list $coords "\{[join $opts ,]\}"]
           48  +  }
    43     49   
    44         -    variable bindings
    45         -    method bind {id ev script} {set bindings(${id},$ev) $script}
    46         -    method _fireevent {id ev subs} {if {[info exists bindings(${id},$ev)]} {uplevel #0 [string map $subs $bindings(${id},$ev)]}}
           50  +  variable bindings
           51  +  
           52  +  method bind {id ev script} {set bindings(${id},$ev) $script}
           53  +  
           54  +  method event_fire {id ev subs} {
           55  +    if {[info exists bindings(${id},$ev)]} {
           56  +      uplevel #0 [string map $subs $bindings(${id},$ev)]
           57  +    }
           58  +  }
    47     59   }
    48     60   

Changes to widgets/checkbutton.tcl.

     1      1   
     2      2   # Checkbutton
     3         -snit::type checkbutton {
     4         -    _wtkwidget -usetextvar
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    variable currentvalue 0
     8         -    option -command
     9         -    option -onvalue -default 1 -configuremethod _onoffchanged
    10         -    option -offvalue -default 0 -configuremethod _onoffchanged
    11         -    option -variable -configuremethod _varnameset
            3  +::odie::class ::wtk::checkbutton {
            4  +  superclass wtk::LabelWidget
            5  +
            6  +  _wtkoption -bg "" {$JS.style.background='$V';}
            7  +  _wtkoption -fg "" {$JS.style.color='$V';}
            8  +  variable currentvalue 0
            9  +  option -command
           10  +  option -onvalue -default 1 -configuremethod _onoffchanged
           11  +  option -offvalue -default 0 -configuremethod _onoffchanged
           12  +  option -variable -configuremethod _varnameset
    12     13   
    13         -    # TODO : move -variable handling into generic widget base
    14         -    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}
    15         -    method _textchangejs {txt} {return "[$self jqobj].children(':last').html('$txt');"}
    16         -    method _event {which} {
    17         -        if {$which in "checked unchecked"} {
    18         -            if {$which=="checked"} {set val $options(-onvalue)} else {set val $options(-offvalue)}
    19         -            $self _changevalue $val 1; uplevel #0 $options(-command)
    20         -        }
           14  +  # TODO : move -variable handling into generic widget base
           15  +  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}
           16  +  method _textchangejs {txt} {return "[my jqobj].children(':last').html('$txt');"}
           17  +  method wtk_event {which} {
           18  +    if {$which in "checked unchecked"} {
           19  +      variable options
           20  +      if {$which=="checked"} {
           21  +        set val $options(-onvalue)
           22  +      } else {
           23  +        set val $options(-offvalue)
           24  +      }
           25  +      my _changevalue $val 1; uplevel #0 $options(-command)
           26  +    }
           27  +  }
           28  +  method _varnameset {opt var} {
           29  +    my variable options
           30  +    set options($opt) $var;
           31  +    if {$var!=""} {
           32  +      if {![uplevel #0 info exists $var]} {
           33  +        uplevel #0 set $var $currentvalue
           34  +      } else {
           35  +        set currentvalue [uplevel #0 set $var]
           36  +      }
           37  +      uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    21     38       }
    22         -    method _varnameset {opt var} {set options($opt) $var;
    23         -        if {$var!=""} {
    24         -            if {![uplevel #0 info exists $var]} {uplevel #0 set $var $currentvalue} else {set currentvalue [uplevel #0 set $var]}
    25         -            uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    26         -        }
           39  +  }
           40  +  method _onoffchanged {opt val} {if {$currentvalue==$options($opt)} {set options($opt) $val; $self _changevalue $val} else {set options($opt) $val}}
           41  +  method _varchanged {args} {if {$currentvalue ne [uplevel #0 set $options(-variable)]} {$self _changevalue [uplevel #0 set $options(-variable)]}}; # trace callback
           42  +  method _changevalue {newval {fromwidget 0}} {
           43  +    if {[my was_created] && !$fromwidget} {
           44  +      if {$newval eq $options(-onvalue) && $options(-onvalue) ne $currentvalue} {
           45  +        ::wtk::toclient "[my jsobj].childNodes\[0\].checked=true;"
           46  +      } elseif {$newval ne $options(-onvalue) && $options(-onvalue) eq $currentvalue} {
           47  +        ::wtk::toclient "[my jsobj].childNodes\[0\].checked=false;"
           48  +      }
    27     49       }
    28         -    method _onoffchanged {opt val} {if {$currentvalue==$options($opt)} {set options($opt) $val; $self _changevalue $val} else {set options($opt) $val}}
    29         -    method _varchanged {args} {if {$currentvalue ne [uplevel #0 set $options(-variable)]} {$self _changevalue [uplevel #0 set $options(-variable)]}}; # trace callback
    30         -    method _changevalue {newval {fromwidget 0}} {
    31         -        if {[$self _created?] && !$fromwidget} {
    32         -            if {$newval eq $options(-onvalue) && $options(-onvalue) ne $currentvalue} {
    33         -                wtk::toclient "[$self jsobj].childNodes\[0\].checked=true;"
    34         -            } elseif {$newval ne $options(-onvalue) && $options(-onvalue) eq $currentvalue} {
    35         -                wtk::toclient "[$self jsobj].childNodes\[0\].checked=false;"
    36         -            }
    37         -        }
    38         -        set currentvalue $newval
    39         -        if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
    40         -    }
           50  +    set currentvalue $newval
           51  +    if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
           52  +  }
    41     53   
    42     54   }

Changes to widgets/combobox.tcl.

     1      1   
     2      2   # Combobox widgets
     3         -snit::type combobox {
     4         -    _wtkwidget -usetextvar
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    _wtkoption -width "" {$JS.style.width=$V;}
     8         -    _wtkoption -height "" {$JS.style.height=$V;}
     9         -    _wtkoption -radius "" {$JS.style.borderRadius=$V;}
    10         -    variable optionsvalue ""
    11         -    variable currentvalue ""
    12         -    option -options  -configuremethod _setoptions 
    13         -    option -variable -configuremethod _varnameset
    14         -    option -command
    15         -    method _createjs {} {
    16         -    	 set r "wtk.createCombobox('[$self id]','[$self cget -text]');"
    17         -    	 foreach e $optionsvalue {
    18         -	    	 	 append r "[$self jsobj].innerHTML+='<option>$e</option>';"
    19         -	    	 }
    20         -	    return $r
            3  +::odie::class ::wtk::combobox {
            4  +  superclass wtk::Widget
            5  +  
            6  +  _wtkoption -bg "" {$JS.style.background='$V';}
            7  +  _wtkoption -fg "" {$JS.style.color='$V';}
            8  +  _wtkoption -width "" {$JS.style.width=$V;}
            9  +  _wtkoption -height "" {$JS.style.height=$V;}
           10  +  _wtkoption -radius "" {$JS.style.borderRadius=$V;}
           11  +  variable optionsvalue ""
           12  +  variable currentvalue ""
           13  +  
           14  +  option -text -configuremethod event_textchanged
           15  +  option -options  -configuremethod _setoptions 
           16  +  option -variable -configuremethod _varnameset
           17  +  option -command
           18  +  
           19  +  method do_createjs {} {
           20  +    my variable optionsvalue
           21  +    set r "wtk.createCombobox('[my id]','[my cget -text]');"
           22  +    foreach e [get optionsvalue] {
           23  +      append r "[my jsobj].innerHTML+='<option>$e</option>';"
           24  +    }
           25  +    return $r
           26  +  }
           27  +  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}
           28  +  method wtk_event {which value} {
           29  +              if {$which eq "value"} {
           30  +                       $self _changevalue $value 1;
           31  +                       uplevel #0 $options(-command)
           32  +              }
           33  +  }    
           34  +  method _varnameset {opt var} {set options($opt) $var;
           35  +      if {$var!=""} {
           36  +          if {![uplevel #0 info exists $var]} {uplevel #0 set $var $currentvalue} else {set currentvalue [uplevel #0 set $var]}
           37  +          uplevel #0 trace add variable $var write [list [list $self _varchanged]]
           38  +      }
           39  +  }
           40  +  method _varchanged {args} {
           41  +    if {$currentvalue ne [uplevel #0 set $options(-variable)]} {
           42  +      my _changevalue [uplevel #0 set $options(-variable)]
           43  +    }
           44  +  }
           45  +  
           46  +  method _changevalue {newval {fromwidget 0}} {
           47  +    if {[my was_created] } {
           48  +      if {$newval ne $currentvalue} {
           49  +        ::wtk::toclient "[my jsobj].value = '$newval';"
           50  +      }
    21     51       }
    22         -    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}
    23         -    method _event {which value} {
    24         -	    	if {$which eq "value"} {
    25         -	    		 $self _changevalue $value 1;
    26         -	    		 uplevel #0 $options(-command)
    27         -	    	}
    28         -    }    
    29         -    method _varnameset {opt var} {set options($opt) $var;
    30         -        if {$var!=""} {
    31         -            if {![uplevel #0 info exists $var]} {uplevel #0 set $var $currentvalue} else {set currentvalue [uplevel #0 set $var]}
    32         -            uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    33         -        }
           52  +    set currentvalue $newval
           53  +    if {$options(-variable) ne ""} {
           54  +      uplevel #0 set $options(-variable) [list $newval]
    34     55       }
    35         -    method _varchanged {args} {if {$currentvalue ne [uplevel #0 set $options(-variable)]} {$self _changevalue [uplevel #0 set $options(-variable)]}}; # trace callback
    36         -		method _changevalue {newval {fromwidget 0}} {
    37         -        if {[$self _created?] } {
    38         -            if {$newval ne $currentvalue} {
    39         -                wtk::toclient "[$self jsobj].value = '$newval';"
    40         -            }
    41         -        }
    42         -        set currentvalue $newval
    43         -        if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
    44         -    }
           56  +  }
    45     57   
    46         -    method _setoptions {op values} {
    47         -    	set optionsvalue $values
    48         -    	if {$options(-options) ne ""} {uplevel #0 set $options(-options) [list $values]}
    49         -    	if {[$self _created?]} {
    50         -	    	 foreach e $values {
    51         -	    	 	 wtk::toclient "[$self jsobj].innerHTML+='<option>$e</option>';"
    52         -	    	 }
    53         -	    	}
           58  +  method _setoptions {op values} {
           59  +    my variable optionsvalue
           60  +    set optionsvalue $values
           61  +    if {$options(-options) ne ""} {uplevel #0 set $options(-options) [list $values]}
           62  +    if {[my was_created]} {
           63  +      foreach e $values {
           64  +        ::wtk::toclient "[my jsobj].innerHTML+='<option>$e</option>';"
           65  +      }
    54     66       }
           67  +  }
    55     68   }

Changes to widgets/entry.tcl.

     1      1   
     2      2   # Entry widgets
     3         -snit::type entry {
     4         -    _wtkwidget -usetextvar
     5         -    _wtkoption -width "" {$JS.size=$V;}
     6         -    _wtkoption -bg "" {$JS.style.background='$V';}
     7         -    _wtkoption -fg "" {$JS.style.color='$V';}
     8         -    method _createjs {} {return "wtk.createEntry('[$self id]','[$self cget -text]');"}
     9         -    method _textchangejs {txt} {return "[$self jqobj].val('$txt');"}
    10         -    method _event {which args} {if {$which eq "value"} {$self _textchanged -text $args 1}}
            3  +::odie::class ::wtk::entry {
            4  +  superclass wtk::LabelWidget
            5  +  
            6  +  _wtkoption -width "" {$JS.size=$V;}
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createEntry('[my id]','[my cget -text]');"}
           11  +  method _textchangejs {txt} {return "[my jqobj].val('$txt');"}
           12  +  method wtk_event {which args} {
           13  +    if {$which eq "value"} {
           14  +      my event_textchanged -text $args 1
           15  +    }
           16  +  }
    11     17   }

Changes to widgets/frame.tcl.

     1      1   
     2      2   # Frame
     3         -snit::type frame {
     4         -    _wtkwidget
     5         -    option -padding
     6         -    method _createjs {} {return "wtk.createFrame('[$self id]');"}
            3  +::odie::class ::wtk::frame {
            4  +  superclass wtk::Widget
            5  +
            6  +  option -padding
            7  +  method do_createjs {} {return "wtk.createFrame('[my id]');"}
     7      8   }
     8      9   

Changes to widgets/label.tcl.

     1      1   
     2      2   # Label widgets
     3         -snit::type label {
     4         -    _wtkwidget -usetextvar
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','[$self cget -text]');"}
     8         -    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}
            3  +::odie::class ::wtk::label {
            4  +  superclass wtk::LabelWidget
            5  +
            6  +  _wtkoption -bg "" {$JS.style.background='$V';}
            7  +  _wtkoption -fg "" {$JS.style.color='$V';}
            8  +  
            9  +  method do_createjs {} {return "wtk.createLabel('[my id]','[my cget -text]');"}
           10  +  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}
     9     11   }

Changes to widgets/labelframe.tcl.

     1      1   
     2      2   
     3      3   # labelframe widgets
     4         -snit::type Labelframe {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','labelframe');"}
            4  +odie::class Labelframe {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','labelframe');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/listbox.tcl.

     1      1   
     2      2   
     3      3   # listbox widgets
     4         -snit::type Listbox {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','listbox');"}
            4  +::odie::class ::wtk::Listbox {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','listbox');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/menu.tcl.

     1      1   
     2      2   
     3      3   # menu widgets
     4         -snit::type Menu {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','menu');"}
            4  +::odie::class ::wtk::Menu {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','menu');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/menubutton.tcl.

     1      1   
     2      2   
     3      3   # menubutton widgets
     4         -snit::type Menubutton {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','menubutton');"}
            4  +::odie::class ::wtk::Menubutton {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','menubutton');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/message.tcl.

     1      1   
     2      2   
     3      3   # message widgets
     4         -snit::type Message {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','message');"}
            4  +::odie::class ::wtk::Message {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','message');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/misc.tcl.

     1      1   
     2      2   # Label widgets
     3         -snit::type misc {
     4         -    _wtkwidget -usetextvar
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    variable typevalue ""
     8         -    variable attrvalue ""
     9         -    variable currentvalue ""
    10         -    option -type  -configuremethod _setoption
    11         -    option -attr  -configuremethod _setoption
    12         -    option -variable -configuremethod _varnameset
    13         -    option -command
            3  +::odie::class ::wtk::misc {
            4  +  superclass wtk::LabelWidget
            5  +  
            6  +  _wtkoption -bg "" {$JS.style.background='$V';}
            7  +  _wtkoption -fg "" {$JS.style.color='$V';}
            8  +  variable typevalue ""
            9  +  variable attrvalue ""
           10  +  variable currentvalue ""
    14     11   
    15         -		method _createjs {} {
    16         -				set r "wtk.createMisc('[$self id]','[$self cget -type]','[$self cget -text]','[$self cget -attr]');"
    17         -				return $r
           12  +  option -type  -configuremethod _setoption
           13  +  option -attr  -configuremethod _setoption
           14  +  option -variable -configuremethod _varnameset
           15  +  option -command
           16  +  
           17  +  method do_createjs {} {
           18  +      set r "wtk.createMisc('[my id]','[my cget -type]','[my cget -text]','[my cget -attr]');"
           19  +      return $r
           20  +  }
           21  +  method _textchangejs {txt} {return "[my jqobj].html('$txt');"}   
           22  +  
           23  +  method _setoption {opt var} {
           24  +    set options($opt) $var
           25  +    if {$var!=""} {
           26  +      if {![uplevel #0 info exists $options($opt)]} {
           27  +        uplevel #0 set $options($opt) [list $var]
           28  +      } else {
           29  +        set typevalue [uplevel #0 set $options($opt)]
           30  +      }
           31  +      #uplevel #0 trace add variable $options($opt) write [list [list $self _varchanged]]
           32  +    }
           33  +  }
           34  +  
           35  +  method wtk_event {which args} {
           36  +    uplevel #0 $options(-command) $args
           37  +  }
           38  +  
           39  +  method _varnameset {opt var} {
           40  +    set options($opt) $var
           41  +    if {$var!=""} {
           42  +      if {![uplevel #0 info exists $var]} {
           43  +        uplevel #0 set $var $currentvalue
           44  +      } else {
           45  +        set currentvalue [uplevel #0 set $var]
           46  +      }
           47  +      uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    18     48       }
    19         -    method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}   
    20         - 
    21         -		method _setoption {opt var} {
    22         -				set options($opt) $var
    23         -        if {$var!=""} {
    24         -            if {![uplevel #0 info exists $options($opt)]} {
    25         -							uplevel #0 set $options($opt) [list $var]
    26         -            } else {
    27         -							set typevalue [uplevel #0 set $options($opt)]
    28         -						}
    29         -            #uplevel #0 trace add variable $options($opt) write [list [list $self _varchanged]]
    30         -        }
    31         -    }  
           49  +  }
    32     50     
    33         -		method _event {which args} {
    34         -	    		 uplevel #0 $options(-command) $args
    35         -    }   
    36         -    method _varnameset {opt var} {
    37         -				set options($opt) $var
    38         -        if {$var!=""} {
    39         -            if {![uplevel #0 info exists $var]} {
    40         -							uplevel #0 set $var $currentvalue
    41         -            } else {
    42         -							set currentvalue [uplevel #0 set $var]
    43         -						}
    44         -            uplevel #0 trace add variable $var write [list [list $self _varchanged]]
    45         -        }
           51  +  method _varchanged {args} {
           52  +    if {$currentvalue ne [uplevel #0 set $options(-variable)]} {
           53  +            $self _changevalue [uplevel #0 set $options(-variable)]
           54  +    }
           55  +  }
           56  +              
           57  +  method _changevalue {newval {fromwidget 0}} {
           58  +    if {[my was_created] } {
           59  +      if {$newval ne $currentvalue} {
           60  +          ::wtk::toclient "[my jsobj].value = '$newval';"
           61  +      }
    46     62       }
    47         -		method _varchanged {args} {
    48         -			if {$currentvalue ne [uplevel #0 set $options(-variable)]} {
    49         -				$self _changevalue [uplevel #0 set $options(-variable)]
    50         -      }
    51         -    };
    52         -		method _changevalue {newval {fromwidget 0}} {
    53         -        if {[$self _created?] } {
    54         -            if {$newval ne $currentvalue} {
    55         -                wtk::toclient "[$self jsobj].value = '$newval';"
    56         -            }
    57         -        }
    58         -        set currentvalue $newval
    59         -        if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
    60         -    }
    61         -	
    62         -
           63  +    set currentvalue $newval
           64  +    if {$options(-variable) ne ""} {uplevel #0 set $options(-variable) [list $newval]}
           65  +  }
    63     66   
    64     67   }

Changes to widgets/panedwindow.tcl.

     1      1   
     2      2   
     3      3   # panedwindow widgets
     4         -snit::type Panedwindow {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','panedwindow');"}
            4  +::odie::class ::wtk::Panedwindow {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','panedwindow');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/radiobutton.tcl.

     1      1   
     2      2   
     3      3   # radiobutton widgets
     4         -snit::type Radiobutton {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','radiobutton');"}
            4  +::odie::class ::wtk::Radiobutton {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','radiobutton');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/scale.tcl.

     1      1   
     2      2   
     3      3   # scale widgets
     4         -snit::type Scale {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','scale');"}
            4  +::odie::class ::wtk::Scale {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','scale');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/scrollbar.tcl.

     1      1   
     2      2   
     3      3   # scrollbar widgets
     4         -snit::type Scrollbar {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','scrollbar');"}
            4  +::odie::class ::wtk::Scrollbar {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','scrollbar');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/spinbox.tcl.

     1      1   
     2      2   
     3      3   # spinbox widgets
     4         -snit::type Spinbox {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','spinbox');"}
            4  +::odie::class ::wtk::Spinbox {
            5  +  superclass wtk::Widget
            6  +
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','spinbox');"}
     8     11   }
     9     12   
    10     13   

Changes to widgets/text.tcl.

     1      1   
     2      2   # TextArea widgets
     3         -snit::type text {
     4         -    _wtkwidget -usetextvar
     5         -    _wtkoption -cols "" {$JS.cols=$V;}
     6         -    _wtkoption -rows "" {$JS.rows=$V;}
     7         -    _wtkoption -bg "" {$JS.style.background='$V';}
     8         -    _wtkoption -fg "" {$JS.style.color='$V';}
     9         -    method _createjs {} {return "wtk.createText('[$self id]','[$self cget -text]');"}
    10         -    method _textchangejs {txt} {return "[$self jqobj].val('$txt');"}
    11         -    method _event {which args} {if {$which eq "value"} {$self _textchanged -text $args 1}}
            3  +::odie::class ::wtk::text {
            4  +  superclass wtk::LabelWidget
            5  +    
            6  +  #_wtkwidget -usetextvar
            7  +  _wtkoption -cols "" {$JS.cols=$V;}
            8  +  _wtkoption -rows "" {$JS.rows=$V;}
            9  +  _wtkoption -bg "" {$JS.style.background='$V';}
           10  +  _wtkoption -fg "" {$JS.style.color='$V';}
           11  +  method do_createjs {} {return "wtk.createText('[my id]','[my cget -text]');"}
           12  +  method _textchangejs {txt} {return "[my jqobj].val('$txt');"}
           13  +  method wtk_event {which args} {
           14  +    if {$which eq "value"} {
           15  +      my event_textchanged -text $args 1
           16  +    }
           17  +  }
    12     18   }

Changes to widgets/tk_optionmenu.tcl.

     1      1   
     2      2   
     3      3   # tk_optionmenu widgets
     4         -snit::type Tk_optionmenu {
     5         -    _wtkoption -bg "" {$JS.style.background='$V';}
     6         -    _wtkoption -fg "" {$JS.style.color='$V';}
     7         -    method _createjs {} {return "wtk.createLabel('[$self id]','tk_optionmenu');"}
            4  +::odie::class ::wtk::Tk_optionmenu {
            5  +  superclass wtk::Widget
            6  +  
            7  +  _wtkoption -bg "" {$JS.style.background='$V';}
            8  +  _wtkoption -fg "" {$JS.style.color='$V';}
            9  +  
           10  +  method do_createjs {} {return "wtk.createLabel('[my id]','tk_optionmenu');"}
     8     11   }
     9     12   
    10     13