added test suite, first cut of grid (just column/row for now), and ca…

…lculator demo from tkdocs

demo2.tcl

@@ -0,0 +1,28 @@
+
+wtk::wm title . "Feet to Meters"
+wtk::grid [wtk::frame .c -padding "3 3 12 12"] -column 0 -row 0 -sticky nwes
+wtk::grid columnconfigure . 0 -weight 1; wtk::grid rowconfigure . 0 -weight 1
+
+wtk::grid [wtk::entry .c.feet -width 7 -textvariable feet] -column 2 -row 1 -sticky we
+#wtk::grid [wtk::entry .c.feet -textvariable feet] -column 2 -row 1 -sticky we
+#.c.feet configure -width 7
+wtk::grid [wtk::label .c.meters -textvariable meters] -column 2 -row 2 -sticky we
+wtk::grid [wtk::button .c.calc -text "Calculate" -command calculate] -column 3 -row 3 -sticky w
+
+wtk::grid [wtk::label .c.flbl -text "feet"] -column 3 -row 1 -sticky w
+wtk::grid [wtk::label .c.islbl -text "is equivalent to"] -column 1 -row 2 -sticky e
+wtk::grid [wtk::label .c.mlbl -text "meters"] -column 3 -row 2 -sticky w
+
+foreach w [wtk::winfo children .c] {wtk::grid configure $w -padx 5 -pady 5}
+wtk::focus .c.feet
+wtk::bind . <Return> {calculate}
+
+proc calculate {} {  
+   if {[catch {
+       set ::meters [expr {round($::feet*0.3048*10000.0)/10000.0}]
+   }]!=0} {
+       set ::meters ""
+   }
+}
+
+

index.html

@@ -11,6 +11,7 @@ <h1>wtk (web Tk) demo</h1>
 <h2>Demo wtk applications</h2>
 <ul>
   <li><a href="demo1.html">demo1.html</a> (follow link to run)
+  <li><a href="demo2.html">demo2.html</a> (feet to meters calculator from tkdocs)
 </ul>			
 
 <h2>Code overview</h2>
@@ -22,6 +23,7 @@ <h2>Code overview</h2>
 	wtk interpreter for this client on the server and waits for further instructions.</td></tr>
 <tr><td><a href="src.html?f=wtk.js">wtk.js</a></td><td>Javascript library for the client side of wtk.</td></tr>
 <tr><td><a href="src.html?f=demo1.tcl">demo1.tcl</a></td><td>wtk code for the specific demo application, run in a separate interpreter on the server for each client.</td></tr>
+<tr><td><a href="src.html?f=demo2.tcl">demo2.tcl</a></td><td>feet to meters calculator from tkdocs site</td></tr>
 <tr><td><a href="src.html?f=wtk.tcl">wtk.tcl</a></td><td>Application (server) side of wtk, which implements the Tk-like API, sending to and receiving messages
 	from the Javascript code on the web side.</td></tr>
 <tr><td><a href="src.html?f=httpd.tcl">httpd.tcl</a></td><td>Generic minihttpd.tcl-based webserver (nothing wtk specific).</td></tr>

server.tcl

@@ -38,6 +38,8 @@ proc webhandler {op sock} {
         switch -exact -- $url {
             "/"             {httpd return $sock [filecontents index.html]}
             "/demo1.html"   {httpd return $sock [newSession demo1.tcl demo1.html]}
+            "/demo2.html"   {httpd return $sock [newSession demo2.tcl demo1.html]}
+            "/demox.html"   {httpd return $sock [newSession demox.tcl demo1.html]}
             "/wtk.js"       {httpd return $sock [filecontents wtk.js] -mimetype "text/javascript"}
             "/wtkpoll.html" {if !{[sendany $sock $query(sessionid)]} {error "pending"}}
             "/wtkcb.html"   {fromclient $query(sessionid) $query(cmd)}
@@ -67,7 +69,7 @@ proc newSession {script webpage} {
     $interp eval source wtk.tcl
     $interp alias sendto toclient $sessionid
     $interp eval wtk::init sendto
-    $interp eval source $script
+    if {[catch {$interp eval source $script}]!=0} {puts $::errorInfo}
     return [string map "%%%SESSIONID%%% $sessionid" [filecontents $webpage]]
 }
 
@@ -77,15 +79,15 @@ proc newSession {script webpage} {
 # This is called when the client wants to send its application instance a message (via 
 # the /wtkcb.html callback in this case), typically an event like a button press. 
 # We invoke the 'wtk::fromclient' routine in the instance's interpreter to process it.
-proc fromclient {sessionid cmd} {[dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]}
+proc fromclient {sessionid cmd} {puts "CLIENT: $cmd"; [dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]}
 
 
 # toclient -- Send Javascript commands from an app instance to the web client
 #
 # This is called when the application instance wants to send its client a message,
 # in the form of a Javascript command.  The message is queued and the actual 
 # sending is taken care of by the next routine. 
-proc toclient {sessionid cmd} {dict append ::session($sessionid) msgq $cmd}
+proc toclient {sessionid cmd} {puts "SERVER: $cmd"; dict append ::session($sessionid) msgq $cmd}
 
 
 # sendany -- Deliver messages to the client queued by 'toclient'

wtk.js

@@ -41,9 +41,17 @@ var wtk = {
     createEntry   : function(id, txt) { wtk.CreateWidget(id, 'input', txt,'value').onkeyup = function() {wtk.entryChanged(id);}; },
     entryChanged  : function(id) { wtk.sendto('EVENT '+id+' value '+wtk.widgets[id].value); },
 
+    createFrame   : function(id) { wtk.CreateWidget(id, 'div', '', '');},
+
     /*
-     * Grid placeholder; for now we simply add a slave as the last child of its master.
+     * Grid .
      */
-    griditup      : function(master,slave) { wtk.widgets[master].appendChild(wtk.widgets[slave]); }
+
+    newGrid : function(parent,id) {
+        var w = document.createElement('table');
+        w.id = id;
+        wtk.widgets[parent].appendChild(w);
+    },
+
 };
 

wtk.tcl

@@ -22,6 +22,18 @@ namespace eval ::wtk {
         wtk::Widget "." ""
         return ""
     }
+
+    # for debugging
+    proc _reset {} {
+        variable wobj; variable widgets; variable _nextid; variable _sender
+        foreach {id w} [array get wobj] {$w destroy}
+        unset -nocomplain widgets
+        unset -nocomplain wobj
+        set _nextid -1
+        GridState _reset
+        init $_sender
+        return ""
+    }
 
     proc toclient {cmd} {uplevel #0 $wtk::_sender [list $cmd]}
 
@@ -51,11 +63,12 @@ namespace eval ::wtk {
             return ""
         }
         method id {} {return $id}
-        method jsobj {} {return "\$('#[$self id]')"}
+        method jqobj {} {return "\$('#[$self id]')"}
+        method jsobj {} {return "wtk.widgets\['[$self id]'\]"}
 
         # text variable handling; only relevant if the main types delegate these options to us
         option -text -configuremethod _textchanged
-        option -textvariable
+        option -textvariable -configuremethod _textvarset
         method _textchanged {opt txt {fromwidget 0}} {
             set options($opt) $txt; 
             if {$created && !$fromwidget} {wtk::toclient [$wobj _textchangejs $txt]}
@@ -76,10 +89,18 @@ namespace eval ::wtk {
                 uplevel #0 trace add variable $options(-textvariable) write [list [list $self _textvariablechanged]]
             }
         }
+        method _textvarset {opt var} {
+            set options($opt) $var
+            $self _setuptextvar
+        }
     }
 
     proc getwidget {id} {return $wtk::wobj($id)}
 
+    proc wm {args} {# placeholder}
+    proc winfo {args} {# placeholder}
+    proc focus {args} {# placeholder}
+    proc bind {args} {# placeholder}
 
     # Stuff for defining different widget types here
     #
@@ -112,34 +133,112 @@ namespace eval ::wtk {
         _textvarwidget
         option -command
         method _createjs {} {return "wtk.createButton('[$self id]','[$self cget -text]');"}
-        method _textchangejs {txt} {return "[$self jsobj].html('$txt');"}
+        method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}
         method _event {which} {if {$which eq "pressed"} {uplevel #0 $options(-command)}}
     }
 
     # Label widgets
     snit::type label {
         _textvarwidget
         method _createjs {} {return "wtk.createLabel('[$self id]','[$self cget -text]');"}
-        method _textchangejs {txt} {return "[$self jsobj].html('$txt');"}
+        method _textchangejs {txt} {return "[$self jqobj].html('$txt');"}
     }
 
     # Entry widgets
     snit::type entry {
         _textvarwidget
-        method _createjs {} {return "wtk.createEntry('[$self id]','[$self cget -text]');"}
-        method _textchangejs {txt} {return "[$self jsobj].val('$txt');"}
+        option -width -configuremethod _widthchanged
+        method _createjs {} {set r "wtk.createEntry('[$self id]','[$self cget -text]');"; if {$options(-width)!=""} {append r "[$self jsobj].size=$options(-width);"};return $r}
+        method _textchangejs {txt} {return "[$self jqobj].val('$txt');"}
         method _event {which args} {if {$which eq "value"} {$self _textchanged -text $args 1}}
+        method _widthchanged {opt val} {set options($opt) $val; if {[$self _created?]} {wtk::toclient "[$self jsobj].size=$val;"}}
+    }
+
+    # Frame
+    snit::type frame {
+        _stdwidget
+        option -padding
+        method _createjs {} {return "wtk.createFrame('[$self id]');"}    
     }
 
     # Place a slave inside its master.  Right now this doesn't process any actual grid options.
     proc grid {w args} {
         variable widgets
-        set w [namespace tail $w]
-        set parent [join [lrange [split $w .] 0 end-1] .]
-        if {$parent eq ""} {set parent "."}
-        if {![info exists widgets($parent)]} {error "no parent widget found"}
-        if {![$w _created?]} {$w _create}
-        wtk::toclient "wtk.griditup('[$parent id]', '[$w id]');"
+        switch -exact -- $w {
+            "columnconfigure" {}        
+            "rowconfigure" {}
+            default {
+                set w [namespace tail $w]
+                set parent [join [lrange [split $w .] 0 end-1] .]
+                if {$parent eq ""} {set parent "."}
+                if {![info exists widgets($parent)]} {error "no parent widget found"}
+                if {![$w _created?]} {$w _create}
+                if {[dict keys $args -column]==""} {dict set args -column 0}
+                if {[dict keys $args -row]==""} {dict set args -row 0}
+                ###wtk::toclient "wtk.griditup('[$parent id]','[$w id]');"     
+                [GridState for $parent] addSlave $w {*}$args
+                return ""   
+            }
+        }
+    }
+
+    # internal state kept for each master
+    snit::type GridState {
+        typevariable states
+        typemethod for {w} {
+            if {![info exists states($w)]} {set states($w) [GridState %AUTO% $w]}
+            return $states($w)
+        }
+        typemethod _reset {} {foreach i [$type info instances] {$i destroy}; unset states}
+
+        variable rows {}
+        variable columns {}
+        variable slaves ; # array
+        variable tabledata {}
+        variable master
+        variable id
+        constructor {w} {set master $w; set id [string map "obj grid" [$w id]] }
+        method jqobj {} {return "\$('#$id')"}
+        method jsobj {} {return "\$('#$id')\[0\]"}
+        method _debug {} {return [list master $master rows $rows columns $columns slaves [array get slaves] tabledata $tabledata]}
+        method addSlave {w args} {
+            # TODO - verify slave is a descendant of us, handle -in, etc.
+            # NOTE: caller ensures we have a column and row
+            if {[dict keys $args -column] eq "" || [dict keys $args -row] eq ""} {error "need to supply -column and -row"}
+            set slaves($w) $args
+            set colnum [dict get $args -column]; set rownum [dict get $args -row]
+            #puts "\n        BEFORE: $tabledata  -> col=$colnum row=$rownum w=$w"
+            if {$colnum ni $columns} {$self _insertColumn $colnum}
+            if {$rownum ni $rows} {$self _insertRow $rownum}
+
+            set colidx [lsearch $columns $colnum]; set rowidx [lsearch $rows $rownum]
+            set row [lindex $tabledata $rowidx]
+            #puts "             row=$row, colidx=$colidx"
+            set tabledata [lreplace $tabledata $rowidx $rowidx [lreplace $row $colidx $colidx [lreplace [lindex $row $colidx] 2 2 $w]]]
+            #puts "        AFTER: $tabledata\n"
+            wtk::toclient "[$self jsobj].rows\[$rowidx\].cells\[$colidx\].appendChild(wtk.widgets\['[$w id]'\]);"
+            return ""
+        }
+        method _insertColumn {colnum} {
+            set columns [lsort -integer [concat $columns $colnum]]; set colidx [lsearch $columns $colnum]
+            set new ""; set rowidx 0
+            foreach i $tabledata {
+                lappend new [linsert $i $colidx [list $colidx 1 blank]]
+                wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($colidx);"
+                incr rowidx
+            }
+            set tabledata $new
+        }
+        method _insertRow {rownum} {
+            if {$tabledata==""} {wtk::toclient "wtk.newGrid('[$master id]','$id');"}
+            set rows [lsort -integer [concat $rows $rownum]]; set rowidx [lsearch $rows $rownum];
+            wtk::toclient "[$self jsobj].insertRow($rowidx);"
+            set row ""; for {set i 0} {$i<[llength $columns]} {incr i} {
+                lappend row [list $i 1 blank]
+                wtk::toclient "[$self jsobj].rows\[$rowidx\].insertCell($i);"
+            }
+            lappend tabledata $row
+        }
     }
 
 }

wtk.test

@@ -0,0 +1,73 @@
+package require tcltest
+namespace import tcltest::*
+
+package require control
+control::control assert enabled 1
+namespace import control::assert
+proc assert_equal {expected actual} {if {[string equal $expected $actual]} {return ""} else {error "expected \"$expected\", got \"$actual\""}}
+proc assert_match {matchexpr actual} {if {[regexp $matchexpr $actual]==1} {return ""} else {error "string did not match \"$matchexpr\""}}
+proc assert_no_match {matchexpr actual} {if {[regexp $matchexpr $actual]!=1} {return ""} else {error "string did match \"$matchexpr\""}}
+
+
+source wtk.tcl
+
+set ::msgs ""
+proc sendmsg {msg} {append ::msgs $msg}
+proc jsmsgs {} {set r $::msgs; set ::msgs ""; return $r}
+wtk::init sendmsg
+
+test wtk-1.1 {button} {
+    assert_equal "::.b" [wtk::button .b -text "Hello World"]
+    assert_equal "" [jsmsgs]
+    assert_equal "" [wtk::grid .b]
+    assert_equal "wtk.createButton('obj1','Hello World')" [lindex [split [jsmsgs] ";"] 0]
+    assert_equal "" [.b configure -text "Goodbye"]
+    assert_equal {$('#obj1').html('Goodbye');} [jsmsgs]
+} {}
+
+test wtk-1.2 {label} {
+    assert_equal "::.l" [wtk::label .l -text "Blah"]
+    assert_equal "" [jsmsgs]
+    assert_equal "" [wtk::grid .l]
+    assert_equal "wtk.createLabel('obj2','Blah')" [lindex [split [jsmsgs] ";"] 0]
+    assert_equal "" [.l configure -text "New Text"]
+    assert_equal {$('#obj2').html('New Text');} [jsmsgs]
+} {}
+
+test wtk-1.3 {entry} {
+    assert_equal "::.e" [wtk::entry .e -text ""]
+    assert_equal "" [jsmsgs]
+    assert_equal "" [wtk::grid .e]
+    assert_equal "wtk.createEntry('obj3','')" [lindex [split [jsmsgs] ";"] 0]
+    assert_equal "" [.e configure -text "New Value"]
+    assert_equal {$('#obj3').val('New Value');} [jsmsgs]
+} {}
+
+test wtk-1.4 {entry w/ textvariable} {
+    assert {![info exists ::foo]}
+    assert_equal "" [.e configure -textvariable foo]
+    assert_equal "New Value" $::foo
+    set ::foo "Testing"
+    assert_equal "Testing" [.e cget -text]
+    assert_equal {$('#obj3').val('Testing');} [jsmsgs]
+    wtk::fromclient "EVENT obj3 value Even Newer Value"
+    assert_equal "Even Newer Value" $::foo
+    assert_equal "Even Newer Value" [.e cget -text]
+} {}
+
+
+wtk::_reset
+
+test wtk-2.1 {grid debugging, start state} {
+    set ::GS [wtk::GridState for .]
+    $::GS _debug
+} {master . rows {} columns {} slaves {} tabledata {}}
+
+test wtk-2.2 {add a single widget at 0,0} {
+    wtk::button .b
+    assert_equal "" [$::GS addSlave .b -column 0 -row 0]
+    assert_equal {wtk.newGrid('obj0','grid0');$('#grid0')[0].insertRow(0);$('#grid0')[0].rows[0].insertCell(0);$('#grid0')[0].rows[0].cells[0].appendChild(wtk.widgets['obj1']);} [jsmsgs]
+    $::GS _debug
+} {master . rows 0 columns 0 slaves {.b {-column 0 -row 0}} tabledata {{{0 1 .b}}}}
+
+tcltest::cleanupTests