Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1013,10 +1013,15 @@ * generic/tclTest.c: * test/error.test: * test/info.test: * test/scan.test: * unix/tclUnixThrd.h: Remove this unused header file. + +2011-04-04 Alexandre Ferrieux + + * nacl/...: New branch ferrieux-nacl : a port of Tcl to + Google's Nacl (Native Client) 2011-04-03 Donal K. Fellows * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: * generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c: ADDED nacl/Makefile.patch Index: nacl/Makefile.patch ================================================================== --- /dev/null +++ nacl/Makefile.patch @@ -0,0 +1,130 @@ +--- Makefile 2011-04-10 13:21:12.773175132 +0200 ++++ tweaked.Makefile 2011-04-10 12:34:27.256426620 +0200 +@@ -102,12 +102,17 @@ + #CFLAGS = $(CFLAGS_DEBUG) + #CFLAGS = $(CFLAGS_OPTIMIZE) + #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) +-CFLAGS = $(CFLAGS_OPTIMIZE) -Wno-long-long -pthread -DNACL -pipe ++CFLAGS = $(CFLAGS_OPTIMIZE) -pipe -fvisibility=hidden ++ ++ ++CFLAGS += -Wno-long-long -pthread -DNACL + + # Flags to pass to the linker + LDFLAGS_DEBUG = + LDFLAGS_OPTIMIZE = +-LDFLAGS = $(LDFLAGS_OPTIMIZE) -Wl,--export-dynamic ++LDFLAGS = $(LDFLAGS_OPTIMIZE) -Wl,--export-dynamic -lm \ ++ -lppapi \ ++ -lpthread + + # To disable ANSI-C procedure prototypes reverse the comment characters on the + # following lines: +@@ -176,7 +184,7 @@ + + STLIB_LD = ${AR} cr + SHLIB_LD = ${CC} -shared ${CFLAGS} ${LDFLAGS} +-SHLIB_CFLAGS = -fPIC -DBUILD_tcl ++SHLIB_CFLAGS = -DBUILD_tcl + SHLIB_LD_LIBS = ${LIBS} + TCL_SHLIB_LD_EXTRAS = + +@@ -216,7 +224,8 @@ + # by hand. + #-------------------------------------------------------------------------- + +-COMPAT_OBJS = waitpid.o fake-rfc2553.o memcmp.o strstr.o strtoul.o strtod.o fixstrtod.o ++#COMPAT_OBJS = waitpid.o fake-rfc2553.o memcmp.o strstr.o strtoul.o strtod.o fixstrtod.o ++IGNORE_COMPAT_OBJS = waitpid.o fake-rfc2553.o memcmp.o strstr.o strtoul.o strtod.o fixstrtod.o + + AC_FLAGS = -DPACKAGE_NAME=\"tcl\" -DPACKAGE_TARNAME=\"tcl\" -DPACKAGE_VERSION=\"8.6\" -DPACKAGE_STRING=\"tcl\ 8.6\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DHAVE_SYS_TYPES_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_UNISTD_H=1 -DNO_VALUES_H=1 -DHAVE_LIMITS_H=1 -DNO_DLFCN_H=1 -DHAVE_SYS_PARAM_H=1 -DTCL_CFGVAL_ENCODING=\"iso8859-1\" -DSTATIC_BUILD=1 -DHAVE_ZLIB=1 -DMODULE_SCOPE=extern -DTCL_SHLIB_EXT=\".so\" -DTCL_CFG_OPTIMIZED=1 -DTCL_CFG_DEBUG=1 -DTCL_TOMMATH=1 -DMP_PREC=4 -DTCL_WIDE_INT_TYPE=long\ long -DUSEGETWD=1 -DHAVE_MKSTEMP=1 -DHAVE_OPENDIR=1 -DHAVE_STRTOL=1 -DNO_GETWD=1 -DNO_WAIT3=1 -DNO_UNAME=1 -DNO_REALPATH=1 -DNEED_FAKE_RFC2553=1 -DHAVE_SYS_TIME_H=1 -DTIME_WITH_SYS_TIME=1 -DHAVE_GMTIME_R=1 -DHAVE_LOCALTIME_R=1 -DHAVE_MKTIME=1 -DHAVE_TIMEZONE_VAR=1 -DHAVE_STRUCT_STAT_ST_BLOCKS=1 -DHAVE_STRUCT_STAT_ST_BLKSIZE=1 -DHAVE_BLKCNT_T=1 -DNO_FSTATFS=1 -Dstrtod=fixstrtod -Dsocklen_t=int -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DNO_UNION_WAIT=1 -DHAVE_SIGNED_CHAR=1 -DHAVE_LANGINFO=1 -DHAVE_MKSTEMPS=1 -DTCL_UNLOAD_DLLS=1 + AR = nacl-ar +@@ -335,12 +346,13 @@ + + STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} + +-UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ ++UNIX_OBJS = naclMissing.o tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ + tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ + tclUnixTime.o tclUnixInit.o tclUnixThrd.o \ + tclUnixCompat.o + + NOTIFY_OBJS = tclUnixNotfy.o ++IGN = + + MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o + +@@ -600,7 +612,7 @@ + + all: binaries libraries doc packages + +-binaries: ${LIB_FILE} $(STUB_LIB_FILE) ${TCL_EXE} ++binaries: ${LIB_FILE} $(STUB_LIB_FILE) tcl$(arch).nexe + + libraries: + +@@ -634,14 +646,36 @@ + # Must be empty so it doesn't conflict with rule for ${TCL_EXE} above + ${NATIVE_TCLSH}: + +-Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in +- $(SHELL) config.status ++init.tcl.c: ../library/init.tcl init.natcl ++ cat $^ | tools/tocstr > $@ ++ ++tclUnixPort.h: ../unix/tclUnixPort.h tclUnixPort.h.patch ++ cat ../unix/tclUnixPort.h > tclUnixPort.h ++ patch -p0 < tclUnixPort.h.patch ++ ++naclMain.o: naclMain.c init.tcl.c ++ $(CC) -c $(CC_SWITCHES) naclMain.c ++ ++tcl$(arch).nexe: naclMain.o libtcl8.6.a ++ $(CCPLUS) $^ $(LDFLAGS) -o $@ ++ ++$(TCL_OBJS) $(STUB_LIB_OBJS) $(TCLSH_OBJS) $(TCLTEST_OBJS): tclUnixPort.h ++ ++server: ++ tclsh trivhttpd.tcl 5103 & ++ ++balls: ++ google-chrome http://localhost:5103/demo/balls.html ++ ++#Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in ++# $(SHELL) config.status + #tclConfig.h: $(UNIX_DIR)/tclConfig.h.in + # $(SHELL) config.status + + clean: clean-packages + rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \ +- errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl ++ errors ${TCL_EXE} ${TCLTEST_EXE} lib.exp Tcl \ ++ init.tcl.c tclUnixPort.h + cd dltest ; $(MAKE) clean + + distclean: distclean-packages clean +@@ -794,7 +826,6 @@ + echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ + $(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)"/$(STUB_LIB_FILE) ; (cd "$(LIB_INSTALL_DIR)" ; $(RANLIB) $(STUB_LIB_FILE)) ; \ + fi +- + @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" + @$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig + @$(INSTALL_DATA) tcl.pc $(LIB_INSTALL_DIR)/pkgconfig/tcl.pc +@@ -2031,13 +2062,13 @@ + + html: ${NATIVE_TCLSH} + $(BUILD_HTML) +- ++ + html-tcl: ${NATIVE_TCLSH} + $(BUILD_HTML) --tcl +- ++ + html-tk: ${NATIVE_TCLSH} + $(BUILD_HTML) --tk +- ++ + + BUILD_HTML = \ + @${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \ ADDED nacl/README Index: nacl/README ================================================================== --- /dev/null +++ nacl/README @@ -0,0 +1,167 @@ + + NaTcl : Tcl in Nacl + + +Overview +-------- + +NaCl == Native Client is Google's neat sandboxing technology, allowing +to run untrusted code compiled natively, in the context of a +browser. See http://code.google.com/p/nativeclient/. + +The idea is that with Tcl running in this context, and a supporting +browser (currently, Chrome only; in the future, other browsers too), +one could develop client-side code mainly in Tcl, with a very thin +layer of JS in the page; so, basically, Tcl to control the HTML5 DOM ! + +Building Tcl for Nacl +--------------------- + + - install the NaCl SDK at http://code.google.com/chrome/nativeclient/docs/download.html + + - for now, only use the pepper_14 bundle + + - add (Nacl-SDK-top-dir)/pepper_14/native_client_sdk_0_5_1052/toolchain/linux_x86/bin to your PATH + + - cd (Tcl-source-tree)/nacl + + - run './configure' (which calls ../unix/configure with proper flags, + and patches the generated Makefile) + + - run 'make binaries'. This creates tcl.nmf and tcl32.nexe or + tcl64.nexe, depending on the kind of x86 you're currently on. You + can also simply type 'make' but the libraries are not usable by + NaCl yet (no dynamic linking). + + - (optional) to also build the other kind, do 'make distclean', then + './configure -m32 (or -m64)', then 'make binaries'. The provided + manifest file (tcl.nmf) points to both, to be compatible with both + builds of Chrome. + + - run 'make sever'. This starts (on port 5103) a tiny, trivial httpd + written in Tcl, whose sole purpose is to server the few demo + files. Note that NaCl is explicitly disabled on file:// urls. + + - (once) open about:flags in Chrome and enable Native Client (note + this will be saved in your per-user Chrome preferences and will + even survive a Chrome upgrade) + + - run 'make balls' + +Overview of the porting method +------------------------------ + +Nacl comes with a very incomplete libc and set of headers. The +strategy, then, is to simply "plug" missing syscalls or library +functions with either explicitly failing stubs (returning -1 or NULL, +and setting errno) or emulators, and to build a big include file +(naclcompat.h) with all the necessary type and macro definitions to +compile. + +Of course, when one of the failing stubs is called at runtime, an +error is raised. But one cannot hope much more, it's a sandbox for a +reason. + +This approach allows to compile Tcl for Nacl without changing a single +line of the original source distribution; all new things are in the +nacl subdir. Also, much is reused from ../unix. + +Nacl context specifics +---------------------- + + NaCl lets us run in our sandbox, in a dedicated process; the only +possible interactions with the browser process are: + + - at init time, one of our functions is called + + - then, each side can post a string message to the other one + + - on reception, a callback is called with the string as + argument. This happens on each side's single thread. + +This asynchronous communication method ensures that the JS context +will never be blocked, whatever the sandboxed child does. + +For maximal genericity, the way NaTcl "retroacts" on the JS context is +by posting back a JS string to eval(). Then you can do whatever you +want, including of course arranging for future JS events to call back +into NaTcl. See [domset] and [after] (in init.natcl, which is compiled +into the binray .nexe) as two very simple examples. + +In an universe without syscalls, loading other scripts is +problematic. To circumvent this (and bootstrap the loading of the main +script), [source $url] is reimplemented over a JS XmlHttpRequest. And +to preserve the blocking semantics of traditional [source] while XHR +is purely async, this implementation is coroutine-based and calls +[yield] after starting the request. When the download completes, JS +calls back into Tcl to resume the coro, and continue the sequential +execution of the Tcl script where it left. This allows for arbitrary +series and nesting of [source]. + +For this reason, the main script is bootstrapped by evaluating: + + coroutine main_coro source $url + +This means that all the init code in the script will run in the coro +context (for [source]'s benefit, but that could be extended to other +things). But once the execution has fallen back out of the main +script, hopefully after setting up many (JS) event handlers, it is up +to the app to establish other coro contexts if needed. + +A few things about GUI and blocking: + + - a simple, ol'good-Tk-style event-driven script will work as usual + + - lengthy computations on the Tcl side will *not* block the JS's + side autonomous GUI elements, thanks to the new async interaction + described above + + - however, to be able ot interrupt the computation from the GUI, or + to have Tcl code implement part of the GUI reactions, one must of + course let the Tcl code return quickly. + + - in all cases, [source] works as usual to fetch scripts over HTTP + (in the same domain as the page serving the NaTcl + plugin). Relative URLs work: [source foo.natcl]. + + - in all cases, falling back out of the main scripts is equivalent + to going back to the Tk eventloop in wish (except it is the JS + eventloop). + + +The "Google Balls" demo +----------------------- + +If you point your chrome to "demo/balls.html" (eg with 'make balls'), +you'll get a full NaTcl emulation of the nice Javascript demo at: + + http://www.html5canvastutorials.com/labs/html5-canvas-google-bouncing-balls + +This uses a canvas emulation script "canv.natcl", which demonstrates a +possible (among many) way of organizing Tcl-JS interaction for +graphics. In the balls demo, items are never destroyed nor shuffled, +which is a favourable case for lazy recompilation of the JS repaint +function (basically the func is written just once, and only the coords +stored in a global array get updated, hence allowing for JIT compiling +of this function). + +Perf measurements: the NaTcl version currently costs 3x the CPU of the +JS version, so at 40fps it consumes a full core of my 2GHz laptop +(against 33% for the JS one). + +One should note that the pure string API used currently precludes any +use of the internal reps of coordinates, so there are many +string/integer conversions. To be continued. + +Comparison with native Tcl/Tk +----------------------------- + +With the command 'tools/natcl2tk balls.natcl', you can run the same +code in pure Tcl/Tk, in a true wish canvas. You can use it for +performance and rendering comparisons. + +Future work +----------- + + Coming soon: [domget], more [canvas] features, and optimizations ;-) + ADDED nacl/configure Index: nacl/configure ================================================================== --- /dev/null +++ nacl/configure @@ -0,0 +1,41 @@ +#! /bin/sh + +tmp=/tmp/nacl-configure.$$ + +findarch() +{ + echo -n "Finding default arch ..." >&2 + echo "int foo(x) {return x*x;}" > $tmp.c + nacl-gcc -c $tmp.c -o $tmp.o + kind=`file $tmp.o` + /bin/rm $tmp.[co] + case "$kind" in + *32-bit*) arch=32;; + *64-bit*) arch=64;; + *) echo "### Cannot compute default arch. Please specify -m32 or -m64.">&2;exit 1;; + esac + echo " -m$arch" >&2 +} + +case "$1" in + -m32) arch=32;; + -m64) arch=64;; + "") findarch;; + *) echo "Usage: ./configure [-m32|-m64]">&2;exit 1;; +esac +export arch +set -ex +CC="nacl-gcc -m$arch" CPP="nacl-cpp -m$arch" CFLAGS="-Wno-long-long -pthread -DNACL" ../unix/configure --host nacl --disable-threads --disable-shared +rm -f a.out core.* || true +cat Makefile > $tmp.mk +sed -e '/^CC[ ]*=/ a\ +CCPLUS = nacl-g++ -m'$arch'\ +arch='$arch' +' < $tmp.mk > Makefile +patch -l -p0 < Makefile.patch +set +x +echo " + Makefile generated and patched for NaCl. Ready for 'make' :) +">&2 +exit 0 + ADDED nacl/demo/NaTk/NaTk.html Index: nacl/demo/NaTk/NaTk.html ================================================================== --- /dev/null +++ nacl/demo/NaTk/NaTk.html @@ -0,0 +1,31 @@ + + + + + + + + + + +
Loading ...
+ + + + + ADDED nacl/demo/NaTk/NaTk.js Index: nacl/demo/NaTk/NaTk.js ================================================================== --- /dev/null +++ nacl/demo/NaTk/NaTk.js @@ -0,0 +1,31 @@ +function variableTk () { + tcl("::oo::" + $(this).attr("id"), 'changed', $(this).val()); +} + +function buttonTk () { + tcl("::oo::" + $(this).attr("id"), 'changed'); +} + +function rbuttonTk () { + tcl("::oo::" + $(this).attr("id"), 'changed', $(this).val()); +} + +function cbuttonTk () { + var val = this.value; + if(!$(this).is(":checked")) { + val = 0; + } + tcl("::oo::" + $(this).attr("id"), 'changed', val); +} + +function sliderTk (e, id, ui) { + if(e.originalEvent!=undefined) { + tcl("::oo::" + id, 'changed', ui.value); + } +} + +function autocompleteTk (event,entry) { + if(event.originalEvent!=undefined) { + tcl("::oo::" + $(entry).attr("id"), 'changed', $(entry).val()); + } +} ADDED nacl/demo/NaTk/NaTk.tcl Index: nacl/demo/NaTk/NaTk.tcl ================================================================== --- /dev/null +++ nacl/demo/NaTk/NaTk.tcl @@ -0,0 +1,1368 @@ +# NaTk - Tk emulation under NaTcl +# +# Colin McCormack +proc ::puts {args} { + if {[llength $args] == 1} { + printf "STDOUT: [lindex $args 0]" + } else { + printf "[string toupper [lindex $args 0]]: [lindex $args 1]" + } +} + +set _packages {mime base64} +proc package {cmd args} { + printf "PKG: package $cmd $args" + switch -- $cmd { + require { + lassign $args what + if {$what in {Tcl Tk TclOO}} return + if {$what in $::_packages} return + source lib/Utilities/[lindex $args 0].tcl + } + provide { + lassign $args what + lappend ::_packages $what + } + vsatisfies { + return 1 + } + } +} +source tcllib/textutil/string.tcl +source tcllib/textutil/repeat.tcl +source tcllib/textutil/adjust.tcl +source tcllib/textutil/split.tcl +source tcllib/textutil/tabify.tcl +source tcllib/textutil/trim.tcl +source tcllib/textutil/textutil.tcl +source lib/extensions/extend-1.0.tm +source lib/extensions/file-1.0.tm +source lib/extensions/memoize-1.0.tm +source lib/extensions/know-1.0.tm + +package require Form + +namespace import oo::* +package provide NaTk 1.0 + +# radiobutton - textvariable command variable value +# entry - textvariable validatecommand +# scale - command variable +# checkbutton - textvariable command variable +# button - textvariable command + +# TextVariable: radiobutton entry checkbutton button +# Command: radiobutton scale checkbutton button +validate:entry +# Variable: radiobutton scale checkbutton + +# NaTk - class connecting an interp to an NaTcl window +class create ::NaTk { + superclass FormClass + + method toplevel {args} { + variable widgets + if {[llength $args]} { + {*}[dict get $widgets .] {*}$args + } else { + return [dict get $widgets .] + } + } + + method widget {widget} { + variable widgets; return [dict get $widgets $widget] + } + + method widgets {} { + variable widgets; return $widgets + } + + method mkwidget {type widget args} { + variable ns + variable interp + variable widgets + + Debug.widget {mkwidget $widget of type $type ($args)} + + if {$widget ne "."} { + set parent [join [lrange [split $widget .] 0 end-1] .] + if {$parent eq ""} { + set parent . + } + if {![dict exists $widgets $parent]} { + error "Invalid Widget Name - no parent widget '$parent' exists for '$widget'" + } + set p [list -parent [dict get $widgets $parent]] ;# parent object + } elseif {[dict exists $widgets .]} { + error "Invalid Widget - Toplevel . already exists" + } else { + set p {-parent ""} + } + + # construct a widget of given type + Debug.widget {::NaTk::$type new -widget $widget $args -interp $interp $p -connection [self]} + set cmd [::NaTk::$type new -widget $widget {*}$args -interp $interp {*}$p -connection [self]] + return $widget + + if {[catch { + ::NaTk::$type new -widget $widget {*}$args -interp $interp {*}$p -connection [self] + } cmd eo]} { + Debug.widget {FAILED $widget of type '$type' as obj: $cmd ($eo)} + return -options $eo $cmd + } else { + Debug.widget {created $widget of type '$type' as obj:$cmd} + } + + return $widget + } + + # addwidget - to both Interp and mapping + method addwidget {widget cmd} { + Interp alias $widget $cmd ;# install widget alias in Interp + + # remember name<->command mapping + variable widgets + dict set widgets $widget $cmd + dict set widgets $cmd $widget + } + + # delwidget - from both Interp and mapping + method delwidget {obj} { + Interp alias $widget {} + + # forget name<->command mapping + variable widgets + set widget [dict get $widgets $obj] + dict unset widgets $widget + dict unset widgets $obj + } + + method grid {args} { + Debug.grid {NATK GRID: $args} + if {[string index [lindex $args 0]] in {x . ^}} { + set args [linsert $args 0 configure] + } + set args [lassign $args command] + switch -- $command { + anchor - + bbox - + columnconfigure - + info - + location - + propagate - + rowconfigure - + size - + slaves { + set anchor {} + set args [lassign $args widget] + tailcall [dict get $widgets $widget] grid $command $widget {*}$args + } + + configure - + forget - + remove - + { + set slaves {} + while {[string index [lindex $args 0] 0] in {x . ^}} { + set args [lassign $args slave] + lappend slaves $slave + } + variable widgets + set result {} + foreach slave $slaves { + lappend result $slave + lappend result [[dict get $widgets $slave] grid $command $slave {*}$args] + } + return $result + } + } + } + + method interp {script} { + Debug.interp "INTERP: $script" + return [Interp eval $script] + } + + method start {script} { + variable verbose + set ::nacl::verbose $verbose + + Debug.interp "INTERP: $script" + Interp eval $script + my toplevel render + } + + method bgerror {args} { + Debug.interp "INTERP BGERROR: $args" + ::nacl bgerror {*}$args [Interp info errorstack] + } + + constructor {args} { + Debug.widgets {[self] Creating ::NaTk $args} + variable safe 0 + variable verbose 1 + variable {*}$args + variable widgets {} + variable ns [info object namespace [self]] + + # create an interpreter for NaTk program + variable interp [::interp create {*}[expr {$safe?"-safe":""}] ${ns}::Interp] + Interp alias ::bgerror [self] bgerror + Interp alias ::alert ::nacl alert + + my mkwidget toplevel . + + # install each widget creator as alias in the interp + foreach n {button entry label frame + checkbutton radiobutton scale + select combobox + } { + Interp alias $n [self] mkwidget $n + } + Interp alias $n grid [self] grid + + #::dom get [dict get $::argv script] [self] start + } +} + +class create ::NaTk::Widget { + variable id props widget interp parent connection rendered + + method js {} {return ""} + + method element {} { + return $id; + #return "document.getElementById('$id')" + return "\$('#$id')" ;# if jQuery + } + + # catch unknown methods and palm them off to the parent + method unknown {cmd args} { + Debug.widgets {unknown $cmd $args} + if {[string match <*> $cmd]} { + return [{*}$parent $cmd {*}$args] + } elseif {[string match .* $cmd]} { + return [$cmd {*}$args] + } + error "Unknown method '$cmd' in [self] of class [info object class [self]]" + } + + method connection {args} { + return [{*}$parent {*}$args] + } + + # grid - percolates up to the parent containing a grid + method grid {args} { + Debug.grid {percolating grid to $parent: grid $args} + tailcall $parent grid {*}$args + } + + # gridded - record grid's values + method gridded {args} { + variable grid + if {[llength $args]} { + set grid [dict merge $grid $args] + } + return $grid + } + + # Grid - interpret -grid options to configure as grid commands + method Grid {args} { + # this widget needs to be gridded + set rs 1; set cs 1; set r 0; set c 0 + Debug.widgets {config gridding: '$args'} + set pargs [lsearch -glob $args -*] + if {$pargs > -1} { + # we've got extra args + set gargs [lrange $args $pargs end] + set args [lrange $args 0 $pargs-1] + } else { + set gargs {} + } + lassign $args r c rs cs + + set ga {} + foreach {v1 v2} {r row c column rs rowspan cs columnspan} { + if {[info exists $v1] && [set $v1] ne ""} { + if {$v1 in {rs cs}} { + if {[set $v1] <= 0} { + set $v1 1 + } + } else { + if {[set $v1] < 0} { + set $v1 0 + } + } + lappend ga -$v2 [set $v1] + } + } + + Debug.widgets {option -grid: 'grid configure $widget $ga $gargs'} + return [my grid configure $widget {*}$ga {*}$gargs] + } + + # style - make an HTML style form + method style {gridding} { + set attrs {} + foreach {css tk} { + background-color background + color foreground + text-align justify + vertical-align valign + border borderwidth + border-color bordercolor + width width + } { + set tkval [dict get? $props $tk] + if {$tkval eq ""} continue + + if {$tk eq "background"} { + lappend attrs background "none $tkval !important" + if {![dict exists $props bordercolor]} { + dict set attrs border-color $tkval + } + # TODO: background images, URLs + } else { + dict set attrs $css $tkval + } + } + + if {0} { + # process -sticky gridding + set sticky [dict gridding.sticky?] + if {$sticky ne ""} { + # we have to use float and width CSS to emulate sticky + set sticky [string trim [string tolower $sticky]] + set sticky [string map {n "" s ""} $sticky];# forget NS + if {[string first e $sticky] > -1} { + dict set attrs float "left" + } elseif {[string first w $sticky] > -1} { + dict set attrs float "right" + } + + if {$sticky in {"ew" "we"}} { + # this is the usual case 'stretch me' + dict set attrs width "100%" + } + } + } + + # todo - padding + set result "" + dict for {n v} $attrs { + append result "$n: $v;" + } + append result [dict gridding.style?] + + if {$result ne ""} { + set result [list style $result] + } + + Debug.widgets {style attrs:($attrs), style:($result)} + + if {[dict exists $props class]} { + lappend result class [dict get $props class] + } + + if {[dict exists $props state] + && [dict get $props state] ne "normal" + } { + lappend result disabled 1 + } + + return $result + } + + # getvalue - return a widget's textvariable or text, where applicable + method getvalue {} { + if {[dict exists $props textvariable]} { + set result [my iget? [dict get $props textvariable]] + Debug.widgets {[self] getvalue from textvariable:'[dict get $props textvariable]' value:'$result'} + } elseif {[dict exists $props text]} { + set result [dict get $props text] + Debug.widgets {[self] getvalue from text '$result'} + } else { + Debug.widgets {[self] getvalue default to ""} + set result "" + } + return $result + } + + # compound - return a widget's image/value compound + method compound {args} { + if {[llength $args] == 1} { + set text [lindex $args 0] + Debug.widget {[self] compound explicit '$text'} + } else { + set text [my getvalue] + Debug.widget {[self] compound implicit '$text'} + } + set text [armour $text] + + set image [dict get? $props image] + if {$image ne ""} { + set image [$image render] + } + set result "" + switch -- [dict get? $props compound] { + left { + set result $image$text + } + right { + set result $text$image + } + center - + top { + set result "$image[my
]$text" + } + bottom { + set result "$text[my
]$image" + } + none - + default { + # image instead of text + if {$image ne ""} { + set result "$image" + } else { + set result "$text" + } + } + } + Debug.widget {[self] compound ($args) -> $result} + return $result + } + + # access interp variables + method iset {n v} { + Debug.interp {iset '$n' <- '$v' traces:([{*}$interp eval [list trace info variable $n]]) ([lrange [info level -1] 0 1])} + return [{*}$interp eval [list ::set $n $v]] + } + + method iget? {n} { + try { + Debug.widgets {iget $n: {*}$interp eval ::if \{\[info exists $n\]\} \{set $n\}} + set result [{*}$interp eval ::if \{\[info exists $n\]\} \{set $n\}] + } on error {e eo} { + set result "" + } + + Debug.interp {iget '$n' -> '$result' ([lrange [info level -1] 0 1])} + return $result + } + + method iget {n} { + try { + set result [{*}$interp eval [list ::set $n]] + } on error {e eo} { + set result "" + } + + Debug.interp {iget '$n' -> '$result' ([lrange [info level -1] 0 1])} + return $result + } + + method iexists {n} { + set result [{*}$interp eval [list ::info exists $n]] + Debug.interp {iexists '$n' -> $result} + return $result + } + + # itrace - trace an Interp variable + method itrace {what args} { + variable trace ;# set of active traces for this widget + if {[llength $args]} { + # add a trace + dict set trace $what $args + {*}$interp eval [list trace add variable $what write $args] + Debug.interp {itrace add $what $args: ([{*}$interp eval [list trace info variable $what]])} + } elseif {[dict exists $trace $what]} { + {*}$interp eval [list trace remove variable $what write [dict get $trace $what]] + Debug.interp {itrace removed $what $args ([dict get $trace $what]) leaving ([{*}$interp eval [list trace info variable $what]])} + dict unset trace $what + } + } + + # Configure - reflect configuration in $props dict + # give trace-effect to -textvariable and -variable opts + method Configure {args} { + # set configuration opts + Debug.widgets {[info coroutine] Configure [self] ($args)/[llength $args]} + if {[llength $args]%2} { + error "Configure requires even number of args" + } + + # clean the '-' prefix from property names + dict for {n v} $args { + if {[string match -* $n]} { + dict unset args $n + dict set args [string trim $n -] $v + } + } + + dict for {n v} $args { + switch -- $n { + variable - + textvariable { + # remove any old traces first + if {[dict get? $props $n] ne ""} { + my itrace [dict get $props $n] + } + + dict set props $n $v + + if {$v ne ""} { + # (re-)establish variable trace + Debug.widgets {tracking -$n '$v' changes} + if {![my iexists $v]} { + # create variable if necessary + {*}$interp eval [list ::variable ::$v] + } + + if {[dict exists $args text]} { + my iset $v [dict get $args text] + } + + # track changes to textvariable + my itrace [dict get $props $n] $widget $n + } else { + catch {dict unset props $n} + } + } + + grid { + my Grid {*}$v + } + + default { + # normal old configuration variable + dict set props $n $v + } + } + } + } + + method configure {args} { + switch -- [llength $args] { + 0 { + # get the names of all configuration opts + set _result {}; + foreach v $props { + lappend result -$v [dict get $props $v] + } + return $result + } + + 1 { + # get the value of a single configuration opt + set v [string trimleft [llength $args 0] -] + return [dict get $props $v] + } + + default { + # handle configure with sensitivity to -command, -variable, etc + tailcall my Configure {*}$args + } + } + } + + destructor { + $connection delwidget [self] ;# remove full widget name + } + + method id {} { + return $id + } + + method nacl {args} { + if {!$rendered} return + set script [join $args \;\n] + ::nacl js $script + } + + method render {args} { + incr rendered + } + + constructor {args} { + variable grid {} + set id [namespace tail [self]] + set rendered 0 ;# not yet rendered + + # get structural vars from NaTk mkwidget + foreach v {widget interp parent connection} { + set $v [dict get $args -$v] + dict unset args -$v + } + Debug.widgets "create $widget ([self]) parent: $parent" + + # add widget to Interp and mapping + $connection addwidget $widget [self] + + set props {} ;# no properties yet + variable trace {} ;# no traces yet + my Configure {*}$args ;# fill up props + } +} + +class create ::NaTk::button { + superclass ::NaTk::Widget + variable id props widget interp parent connection rendered + + # button - textvariable command + + # textvariable - interp's textvariable has changed + method textvariable {} { + variable ignore; if {$ignore} return + set val [my iget [dict get $props textvariable]] + my nacl [my element].innerHTML='[my compound]' + } + + method changed {} { + set cmd [dict get? $props command] + if {$cmd ne ""} { + {*}$interp eval $cmd + } + } + + method render {args} { + next + set event [list onclick "tcl(\"[self]\",\"changed\");"] + return [my