oometa  - TclOO extension done right
    procmap - collect metadata about Tcl procedures at runtime.  Dangerously.
    tcltags - ctags(1) clone for Tcl

    modules - various general-purpose pure-Tcl modules

    hacks   - interesting hacks that are too experimental to be useful yet

Where stuff is demo'able, I've included "boot.tcl" which will stuff the
appropriate dirs into $::auto_path and tcl::tm::path so that it can find its
modules.  Just put that in the command-line:

    $ tclsh boot.tcl hacks/Window-0.tm


!NOTE!:  the contents of this repository often lag dreadfully behind what I'm
actually using in live projects.  If anything seems particularly funky, or
simply fails to work, ping me with a ticket (or on the chat) to update it.

#!/usr/bin/env tclsh
#
#lappend auto_path [file normalize [info script]/../modules]
#::tcl::tm::path add [file normalize [info script]/../modules]
proc boot {args} [format {
    {*}$args [list lappend auto_path %1$s]
    {*}$args [list ::tcl::tm::path add %1$s]
} [list [file normalize [info script]/../modules]]]
boot eval
package provide boot 0.1

if {$::argv ne ""} {
    proc info_cmdline {} [list list [info nameofexe] $::argv0 $::argv]      ;# hack for restartability
    set ::argv [lassign $::argv ::argv0]
    source $::argv0
} else {
    return
    # async repl:
    package require repl
    coroutine main repl::chan stdin stdout stderr
    trace add command main delete {unset ::forever; #}
    vwait forever
}

** Inbuilt lexers

    [token]      - consume (space then) a literal without reporting (doesn't appear in $0)
    [token!]     - consume (space then) a literal and push its value onto $0
    [opt script] - attempt script.  If it fails, push a single empty result onto $0.
    [any s0 ...] - attempt each script until one succeeds.  The successful script's results will appear on $0.
    [many script]- try script repeatedly until it fails.  Results are collected into a list and pushed.


** References

http://www.garshol.priv.no/download/text/bnf.html

        debug log {[string repeat "  " [info level]][info level -1]: [uplevel 1 {list $i $s}] -> $args}
        tailcall tailcall lappend 0 {*}$args
    }
;# commands to define parsers:
    proc space {} {}    ;# default space is a noop
    proc space {} { ;# for RC we want a better space
        upvar 1 s s i i
        incr i [string length [lindex [regexp -inline -start $i {\s*} $s] 0]]
        return
    }
    proc %space {re} {
        set re \\A(?:$re)
        tailcall proc space {} [format {
            upvar 1 s s i i
            incr i [string length [lindex [regexp -inline -start $i %s $s] 0]]
            return
        } [list $re]]
    }

    proc %token {name re {result "set 0"}} {
        set re \\A(?:$re)
        tailcall proc $name {} [format {

    subscribe pattern ?cmd? ?arg ...?
    proc waiton {args} { subscribe $args [info coroutine] }
    notify event
    delete event

unrelated margin note: [yieldto _ [info coroutine]] ~= (call/cc)


Further refinements might be had from examining:

  http://jlongster.com/Taming-the-Asynchronous-Beast-with-CSP-in-JavaScript

Note that his [go] returns a one-shot channel for the generator's final result.
[take [timeout 100]] vs [sleep 100] is a tidy identity too.
Sliding and Dropping channels are missing from securitykiss CSP and this implementation.

# an OptSpec looks like:
#  {-commandlineswitch resourceName ResourceClass defaultValue verifier}
# snit provides -default -verifier -configuremethod -cgetmethod
# I think options belong in class definition, whilst this is (so far) object definition
#
# making classes out of these is going to be the kicker!
#
# Hierarchical bindtags (bubbling) a la bindtags(n) example looks interesting
#
# method upvar is indeed cool, but I've broken [my variable].
#
#  Do we want instead [myvariable] and [mymethod] ?  I think we do, because [variable] is a useful method name.
#
#
# w container constructor ?...? {script}] can put things in a container
# gridconfigure to hide things
#
# containers make visible hierarchies, which will be interesting
#
#
# To make forms:
#   * frames (also panes and tabs)
#   * onchange and condition need a bit of work
#   * collections are still a bit icky
#
# Some tidy up is due:
#   * widget/varnames should be Upper Cased but the Tk name has to be .lOwer
#   * options want to come from a metaclass.  But remember I want item options too.
#   * a trace mixin would tidy thing some
#
# I almost want to make these namespace ensembles rather than objects
#
# TODO:
#   * ttk-ify everything
#     * panedwindow container
#     * notebook container
#   * tooltips!
#   * some kind of options support
#
package require Tk
package require snidgets

package require pkg
package require tests
package require adebug
#package require repl

package require tkImprover


pkg -export {[A-Z]*} Window {

    proc putl args {puts $args}

    proc callback {args} {
        tailcall namespace code $args
    }

    proc windowcontext {} {}

    oo::class create Widget {
        variable w
        constructor {cmd args} {
            namespace path [linsert [namespace path] end ::ttk]
            # if the first argument is a window path, we adopt that window
            # otherwise, it is a window constructor
            if {[string match .* $cmd]} {
                set w $cmd
                $w configure {*}$args
            } else {
                set w [uplevel 1 windowcontext].[namespace tail [self object]]
                $cmd $w {*}$args
            }
            # move the window into this object's namespace
            rename $w [namespace current]::$w
            namespace export $w
            namespace eval :: [list namespace import [namespace current]::$w]

            # init vars
            if {$w eq "."} {
                proc windowcontext {} {return ""}
            } else {
                proc windowcontext {} [list return $w]
            }
            set griddefaults {}

            bind $w <Destroy> [list catch [callback my Reaper %W]]  ;# we still need to catch
                                                                    ;# because tear-down order
            return [self]
        }

        destructor {
            bind $w <Destroy> {}
            catch next
        }


        export varname  ;# this will be useful for consumers

        method eval {script} {
            try $script
        }

        method Reaper {W} {
            if {$W eq $w} {
                debug log {[self] Dying on <Destroy>}
                my destroy
            } else {
                debug log {WARNING: [self] Reaper $W (doing nothing)}
            }
        }

        method w {} {return $w}
        method widget {cmd name args} {
            Widget create $name $cmd {*}[my WidgetArgs $args]
            oo::objdefine [self] forward $name $name
            oo::objdefine [self] export $name
            if {[info exists autolayout] && $autolayout ne ""} {
                set largs [lassign $autolayout method]
                my $method $name {*}$largs
            }
            return [namespace which $name]
        }
        method WidgetArgs {arglist} {
            set q 0
            lmap a $arglist {
                if {$q} {
                    if {![string match ::* $a]} {
                        if {[string match *(*) $a]} {   ;# unwrap array name
                            set n [lindex [split $a (] 0]
                        } else {
                            set n $a
                        }
                        debug assert {$n in [info object variables [self]]}
                        set q 0
                        my varname $a
                    } else {
                        set a
                    }
                } else {
                    if {[string match -*variable $a] || [string match -*var $a]} {
                        set q 1
                    }
                    set a
                }
            }
        }

            if {$args eq ""} {
                bind $w destroy {}
                next    ;# destroy self, taking window with
            } else {
                destroy {*}[my ItemArgs $args]
            }
        }

        variable autolayout
        method autolayout args {
            multiargs {
                {packer args} {
                    my GM $packer [my GetIn $args]
                    set autolayout [list $packer {*}$args]
                }
                {} {
                    return $autolayout
                }
            }
        }

        variable griddefaults
        method griddefaults args {
            set griddefaults $args
        }
        method packdefaults args {
            set griddefaults $args
        }

        method GM args {
            multiargs {
                {} {
                    list [self] [dict get $GM $w]
                }
                {packer container} {
                    if {![string match .* $container]} {
                        set container [$container w]
                    }
                    if {[info exists GM] && [dict exists $GM $container]} {
                        set gm [dict get $GM $container]
                        if {$gm ne $packer} {
                            throw {GM CONFLICT} "Geometry manager is already $gm!"
                        }
                    }
                    dict set GM $container $packer
                }
            }
        }
        method GetIn {opts} {
            set idx [lsearch -exact $opts -in]
            if {$idx == -1} {
                return $w
            } else {
                lindex $opts $idx+1
            }
        }

        method grid {cmd args} {
            my GM grid [my GetIn $args]
            if {$cmd eq "anchor"} {
                multiargs {
                    {slave} {
                        grid $cmd [my WinArg $slave]
                    }
                    {slave anchor} {
                        grid $cmd [my WinArg $slave] $anchor
                    }
                }
            } elseif {$cmd in "bbox location size propagate slaves configure rowconfigure columnconfigure forget"} {
                putl grid $cmd $w {*}[my ItemArgs {*}$args]
                grid $cmd $w {*}[my ItemArgs {*}$args]
            } else {
                grid {*}[my GridArgs $cmd {*}$args] ;#-in $w
            }
        }
        method pack {cmd args} {
            my GM pack [my GetIn $args]
            if {$cmd in "propagate slaves forget"} {
                pack $cmd $w {*}[my ItemArgs {*}$args]
            } else {
                pack {*}[my GridArgs $cmd {*}$args] ;#-in $w
            }
        }
        method ItemArgs {args} {
            set j [lsearch -glob $args -*]
            if {$j == -1} {
                set preargs $args
                set opts {}
            } else {
                set preargs [lrange $args 0 [expr {$j-1}]]
                set opts [lrange $args $j end]
            }
            puts "preargs = $preargs"
            set preargs [lmap a $preargs {my WinArg $a}]
            puts "postargs = $preargs"
            if {[dict exists $opts -in]} {

                dict set opts -in [my WinArg [dict get $opts -in]]
            }


            concat $preargs $opts
        }
        method GridArgs {args} {
            set j [lsearch -glob $args -*]
            if {$j == -1} {
                set preargs $args
                set opts {}
            } else {
                set preargs [lrange $args 0 [expr {$j-1}]]
                set opts [lrange $args $j end]
            }
            set preargs [lmap a $preargs {my WinArg $a}]
            set opts [dict merge $griddefaults $opts]
            if {[dict exists $opts -in]} {
                dict set opts -in [my WinArg [dict get $opts -in]]
            }
            concat $preargs $opts
        }
        method WinArg {w} {
            if {[string match .* $w]} {
                return $w
            } else {
                return [$w w]
            }



        }

        method bind args {
            multiargs {
                {event script} {
                    bind [my w] $event $script
                }
                {event argspec body args} {
                    oo::objdefine [self] method $event [my BindArgs $argspec] $body
                    oo::objdefine [self] export $event
                    set cmdargs [my BindCmdArgs $argspec]
                    bind [my w] $event [list [self] $event {*}$cmdargs {*}$args]
                }
            }
        }
        method BindArgs {argspec} {
            lmap a $argspec {
                string trimleft $a %
            }
        }
        method BindCmdArgs {argspec} {
            lmap a $argspec {
                if {![string match %* $a]} break
                set a
            }
        }

        method bindtags args {
            tailcall bindtags [my w] {*}$args
        }

        method dialog {args} {
            if {[llength $args]%2} {
                set args [linsert $args end-1 -message]
            }
            if {![dict exists $args -parent]} {
                dict set args -parent [my w]
            }
            tk_messageBox {*}$args
        }

        method choosefile {args} {
            if {[llength $args]%2} {
                set args [linsert $args 0 -type]
            }
            if {![dict exists $args -type]} {
                throw {TCL BADARGS} "Must specify -type!"
            }
            switch -exact $type {
                "multi" {
                    set cmd tk_getOpenFile
                    dict set args -multiple yes
                }
                "open" {
                    set cmd tk_getOpenFile
                }
                "save" {
                    set cmd tk_getSaveFile
                }
                "dir" - "folder" {
                    set cmd tk_chooseDirectory
                }
            }
            if {![dict exists $args -parent]} {
                dict set args -parent [my w]
            }
            $cmd {*}$args
        }

        variable options
        method options {} {
            lsort -dictionary [concat [array values options] [$w configure]]
        }
        method option {option resource class default verifier} {
            # -commandlineswitch resourceName ResourceClass defaultValue verifier
            set options($option) [list $option $resource $class $default $verifier]
            # .. learn more from snit
        }

        method method {name argspec body} {
            oo::objdefine [self] method $name $argspec $body
            oo::objdefine [self] export $name
        }
        method variable args {
            oo::objdefine [self] variable {*}$args
        }

        method upvar {name} {   ;# this wants more arguments, but their selection is subtle
            oo::objdefine [self] variable $name
            set upvar [uplevel 1 namespace current]::$name 
            set myvar [my varname $name]
            upvar 0 $upvar $myvar
            return $myvar
        }

        method get args {
            if {[llength $args] eq 1} {
                set [my varname $name]
            } elseif {$args eq ""} {
                my getdict
            } else {
                throw {TCL WRONGARGS} [list [self class] get ?name?]
            }

        }
        method set args {
            foreach {name val} $args {
                set [my varname $name] $val
            }
        }
        method getdict {} {
            lconcat name [info object variables [self]] {
                list $name [set [my varname $name]]
            }
        }

        method unknown {args} {
            if {$args eq ""} {
                return [self] ;#[my w]
            } else {
                tailcall [my w] {*}$args
            }
        }
    }
}




# used in the "notebook class" demo
    catch {rename After {}}
    oo::class create After {    ;# a mixin that cancels afters when the object is destroyed
        variable Afters
        method AfterCancel {id} {
            if {[info exists Afters($id)]} {
                after cancel $Afters($id)
                unset Afters($id)

            foreach k [array names Afters] {
                my AfterCancel $k
            }
            catch next    ;# eww .. but it's a mixin
        }
    }


if 0 {  ;# shell
    chan configure stdin -blocking 0
    chan configure stdout -buffering none
    coroutine repl repl::chan stdin stdout
    puts vwaiting
    vwait forever
}

if 0 {
    oo::class create Notebook {
        variable w
        constructor {} {
            set w [Widget win]
            w griddefauts -sticky nsew
            w grid [w widget ttk::frame tabs]
            w grid [w widget ttk::frame main]

        method insert {index id pane} {
        }
        method remove {index} {
        }
        method move {id index} {
        }
    }
}


set demos {
    "winspector" {
        oo::class create Winspector {
            superclass Widget
            mixin After
            constructor {} {
                next toplevel
    #            proc windowcontext {} [list return [namespace tail [self]]]

                #Widget create w toplevel
                #oo::objdefine [self] forward w w
                my variable name
                my variable class
                my variable bindtags
                my widget label _name -textvariable name
                my widget label _class -textvariable class
                my widget label _bindtags -textvariable bindtags
                my griddefaults -sticky nsew
                my grid _name _class
                my grid _bindtags -
                #bind all <Enter> [namespace code {my Enter %W}]
                my Refresh
            }
            method Refresh {} {
                try {
                    set xy [winfo pointerxy .]
                    set name [winfo containing {*}$xy]
                    if {$name eq ""} return
            #        if {[string match [[self]]* $name]} return
                    set class [winfo class $name]
                    set bindtags [bindtags $name]
                    my set xy $xy name $name class $class bindtags $bindtags
                } finally {
                    my After refresh 300 {my Refresh}
                }
            }
        }
        Winspector create win
    }
    "tabs" {
        Widget create notebook toplevel
        notebook widget frame tabs
        notebook widget frame main
        set tabs [notebook tabs]
    }

    "basic multi-function Tk example" {
        Widget create t toplevel
        t widget entry e1
        t widget button b1 -command {puts hello}
        t griddefaults -sticky nsew
        t grid e1
        t grid b1   ;# -weight 1
        t grid [t widget button b2 -text okde]
        t grid rowconfigure b1 -weight 1
        t e1 insert end "lalala"
        t configure b1 -text "Press me"
        t bind <1> {%W %x %y a} {           ;# implicitly creates a method on the object ..
            puts "$W $x $y: $ack ($a)"      ;# that can resolve object variables!
        } five                              ;# remember: % args must come first!
        t variable ack
        t configure e1 -textvariable ack    ;# ack is resolved in t's scope!
    }

    "container widgets" {
        Widget create t toplevel
        t widget ttk::labelframe one -text "First set"
        t widget entry e1
        t widget checkbutton cb1 -text "Really?"
        t widget ttk::labelframe two -text "Next set"
        t widget entry e2
        t widget checkbutton cb2 -text "are you sure?"
        t grid one
        t grid two
        puts [t e1]
        t one grid [t e1]
        t one grid [t cb1]
        t two grid [t e2]
        t two grid [t cb2]
    }


    "choiceform with method upvar" {
        oo::class create ChoiceForm {
            variable choices
            constructor {dict} {
                Widget create w toplevel
                w upvar choices         ;# shares this variable with the Widget
                dict for {k v} $dict {
                    set b b[incr i]
                    w widget checkbutton $b -text $k -variable choices($v)
                    w grid $b -
                }
                w widget button invert -command [namespace code {my Invert}] -text "Invert selections"
                w widget button print -command [namespace code {my Print}] -text "Print values"
                w grid invert print
            }
            method Invert {} {
                dict for {k v} [array get choices] {
                    set choices($k) [expr {!$v}]
                }
            }
            method Print {} {
                parray choices
            }
        }
        ChoiceForm create c {"One fine day" tomorrow "Never comes" around "There once was a" "little blue pony"}
    }

    "a basic form" {
        oo::class create ::FormWidget {
            superclass Widget

            variable OnChange
            variable Conditions

            constructor args {
                namespace path [linsert [namespace path] end ::ttk]
                set OnChange {}
                set Conditions {}
                next {*}$args
            }

            method onchange {varname script} {
                my SetTrace $varname
                variable OnChange
                dict set OnChange $varname $script
            }
            method condition {w option expr args} {
                my SetTrace {}  ;# hack?
                variable Conditions
                multiargs {
                    {}              { set true true; set false false }
                    {true}          { set false "" }
                    {true false}    {  }
                }
                dict set Conditions $expr [list w $w option $option expr $expr true $true false $false]
            }

            method SetTrace {varname} {
                trace remove variable [my varname $varname] write "[callback my HandleTrace $varname]; --"
                trace remove variable [my varname $varname] unset "[callback my SetTrace $varname]; --"
                trace add variable [my varname $varname] write "[callback my HandleTrace $varname]; --"
                trace add variable [my varname $varname] unset "[callback my SetTrace $varname]; --"
            }

            method HandleTrace {varname} {
                variable Triggers
                dict incr Triggers $varname
                after 0 [list after idle [callback my Trigger]]
            }
            method Trigger {} {
                variable Triggers
                variable OnChange
                variable Conditions
                if {![info exists Triggers]} return
                foreach varname [dict keys $Triggers] {
                    if {[dict exists $OnChange $varname]} {
                        my Apply [dict get $OnChange $varname]
                    }
                    dict unset Triggers $varname
                }
                my update
            }
            method update {} {
                dict for {expr cond} $Conditions {
                    dict with cond {}
                    set new [expr {[my Apply expr $expr] ? $true : $false}]
                    set old [$w cget $option]
                    if {$new ne $old} {
                        my configure $w $option $new
                    }
                }
            }
            method Apply {cmd args} {
                variable {}
                try [concat $cmd $args]
            }

        }


        oo::class create ::FormBase {

            variable {} ;# the form

            constructor {args} {
                namespace path [linsert [namespace path] end ::ttk]
                proc windowcontext {} {}        ;# FIXME: this is a dirty hack
                FormWidget create w {*}$args    ;# FIXME: use args better than just for this
                #array set {} {}
                w upvar {}
                w method frame {name args} {
                    if {[llength $args] % 2} {
                        set script [lindex $args end]
                        set args [lreplace $args end end]
                    } else {
                        set script ""
                    }
                    if {[dict exists $args -text] || [dict exists $args -labelwidget]} {
                        set win [my widget ::ttk::labelframe $name {*}$args]
                    } else {
                        set win [my widget ::ttk::frame $name {*}$args]
                    }
                    set win [$name w]

                    if {$script ne ""} {
                        set al [my autolayout]
                        my autolayout {*}$al -in $win
                        try {
                            my eval $script
                        } finally [callback my autolayout {*}$al]
                    }
                }

                my Construct

                w bind <<Submit>> [callback my Submit]
                w bind <<Cancel>> [callback my Cancel]
                w update
                my Defaults
            }

            forward dialog w dialog

            method buttons {script} {
                w frame buttons
                set w [w buttons w]
                set al [w autolayout]
                puts "Autolayout was: $al"
                w autolayout pack -in $w -side left -expand yes -fill x
                puts "Autolayout is: [w autolayout]"
                try {
                    my eval $script
                } finally [callback w autolayout {*}$al]
            }

            method button {text args} {
                set name b$text
                if {![dict exists $args -command]} {
                    if {$text in [info object methods [self] -all -private]} {
                        dict set args -command [callback my $text]
                    } else {
                        dict set args -command [callback my Return $text]
                    }
                }
                w widget button $name -text $text {*}$args
            }

            method Defaults {} {
                variable Defaults
                set Defaults [array get {}]
            }

            method changed? {} {
                variable Defaults
                dict for {k v} $Defaults {
                    if {$v ne $($k)} {
                        return true
                    }
                }
                return false
            }

            method Cancel {} {
                if {![my changed?] || [my ConfirmCancel]} {
                    my Return ""
                }
            }

            method Submit {} {
                if {![my Validate]} {
                    # highlight errors
                    my dialog -type okay -message "Please complete the form before pressing Okay"
                    return
                }
                my Return [my get]
            }


            method ConfirmCancel {} {
                my dialog -type yesno -message "Really cancel?"
            }

            method Validate {} {
                return true
            }
            
            method wait {} {    ;# wait is to be called in a coroutine
                my ReturnTo  [info coroutine]
                return [yield]
            }

            method get {} {
                array get {}
            }

            method ReturnTo {args} {
                variable ReturnTo
                set ReturnTo $args
            }

            method Return {what} {
                variable ReturnTo
                # after idle?
                tailcall {*}$ReturnTo $what
            }
        }

        oo::class create ::FormClass {
            superclass oo::class
            self method create {name script} {
                set script "superclass ::FormBase; variable {}; $script"
                next $name $script
            }

            method run {{w toplevel} args} {
                set i [my new $w {*}$args]
                try {
                    $i wait
                } finally {
                    $i destroy
                }
            }
        }

        FormClass create Inliner {

            method Construct {} {
                w autolayout grid -sticky nsew
                w frame wrapper -padding 10 
                w grid anchor wrapper center
                w autolayout grid -sticky nsew -in [w wrapper w]
                w eval {
                    my widget FilesChooser   files   -listvariable (files) -text "Choose HTML file"   -multiple yes
                    my frame selections -text " Selections: " {
                        # the -variable args work because of [w upvar ""] in the constructor
                        my widget checkbutton    do_toc  -variable (do_toc)    -text "Generate ToC"
                        my widget checkbutton    do_js   -variable (do_js)     -text "Inline JS"
                        my widget checkbutton    do_css  -variable (do_css)    -text "Inline CSS"
                        my widget checkbutton    do_img  -variable (do_img)    -text "Inline images"
                    }
                }

                w onchange (do_js) {puts lalala:\$(do_js)}
                w condition do_js -state {$(do_toc)} normal disabled
                #w condition selections 

                set (do_toc) 0
                set (do_js)  1
                set (do_css) 1
                set (do_img) 1

                w autolayout grid -sticky nsew
                my buttons {
                    my button "Cancel"
                    my button "Show"
                    my button Submit -text "Okay"    -default active
                }
            }

            method Show {} {
                my dialog "[array get {}]"
            }


        }

        coroutine main {*}[namespace code {
            set d [Inliner run toplevel]
            if {$d eq ""} {
                puts "Form cancelled!"
            } else {
                puts "Form submitted!"
                pdict $d
            }
        }]

        catch {
            source [file normalize [info script]/../../modules/inspect-0.tcl]
            puts "== inspecting Inliner =="
            pdict [inspect Inliner]
            puts ""
        }
    }
}

# run demos

proc restart {} {
    try {
        set cmd [info_cmdline]
    } on error {} {
        set cmd [list [info nameofexe] $::argv0 {*}$::argv]
    }
    puts "Executing: $cmd"
    exec {*}$cmd &
    exit
}

proc run_demo {key} {
    set script [dict get $::demos $key]
    catch {namespace delete ::demo}
    namespace eval ::demo {}
    apply [list {} $script ::demo]
}

if 1 {
    package require tkcon
    tkcon show
}

if {$::argv eq ""} {
    Widget create main .    ;# adopt the root window
    main griddefaults -sticky nsew
    set i 0
    dict for {label script} $demos {
        main widget button b[incr i] -text $label -command [list run_demo $label]
        main grid b$i
    }
    main grid [main widget button bRestart -text "Restart" -command restart]
    main grid [main widget button bQuit -text "Quit" -command exit]
} else {
    coroutine main apply {{} {
        foreach a $::argv {
            foreach k [dict keys $::demos $a] {
                puts "** running demo: \"$a\""
                run_demo $a
                yieldto after 1000 [info coroutine]
            }
        }
    }}
}

#!/bin/sh
#
# AES sampler
#
package require aes

proc randbytes {n} {
    set r {}
    while {$n > 0} {
        lappend r [expr {int(rand()*256)}]
        incr n -1
    }
    binary format c* $r
}

# PKCS-style padding
proc pad {data {mul 16}} {
    set len [string length $data]
    set n [expr {$mul - ($len % $mul)}]
    append data [binary format c* [lrepeat $n $n]]
}

proc unpad {data {mul 16}} {
    binary scan [string index $data end] c n
    set pad [string replace $data 0 end-$n]
    set expect [binary format c* [lrepeat $n $n]]
    if {$pad ne $expect} {
        error "Bad padding! [list [binary encode hex $pad] != [binary encode hex $expect]]"
    }
    string range $data 0 end-$n
}

proc encrypt {key data} {
    set fd [file tempfile fn]
    try {
        chan configure $fd -translation binary
        aes::aes -mode cbc -dir encrypt -key $key -out $fd [pad $data]
        return $fn
    } finally {
        close $fd
    }
}

proc decrypt {key filename} {
    set fd [open $filename r]
    try {
        chan configure $fd -translation binary
        unpad [aes::aes -mode cbc -dir decrypt -key $key -in $fd]
    } finally {
        close $fd
    }
}

proc readbinary {filename} {
    set fd [open $filename r]
    try {
        chan configure $fd -translation binary
        read $fd
    } finally {
        close $fd
    }
}

namespace eval main {
    proc enc {key filename} {
        puts -nonewline [encrypt [binary decode base64 $key] [readbinary $filename]]
    }
    proc dec {key filename} {
        puts -nonewline [decrypt [binary decode base64 $key] $filename]
    }

    proc test {filename} {
        puts "Generating key"
        set key [randbytes 32]
        puts "Reading file"
        set data [readbinary $filename]
        puts "Encrypting"
        set file [encrypt $key $data]
        puts "Decrypting"
        set data2 [decrypt $key $file]
        puts "Encrypted file: $file"
        puts "Key (base64): [binary encode base64 $key]"
        puts --
        puts -nonewline "Verifying: "
        if {$data eq $data2} {
            puts "OK!"
        } else {
            puts "Error!"
            puts "data = [binary encode hex $data]"
            puts "data2 = [binary encode hex $data2]"
        }
    }
    namespace export *
    namespace ensemble create
}

main {*}$argv

# tclconfig is configuration for tcl; configtcl is tcl for configuration!
#
# mini config script with a slave interp, for https://pastebin.mozilla.org/8883694
#
# If terminals were dicts with a key of {} (or lists of length 1), the config
# could be pretty-printed quite easily.

proc loadconf {filename} {
    set cint [interp create -safe]
    foreach cmd [$cint eval {info commands}] {
        # you can expose commands if you like:
        if {$cmd ni "foreach if"} {
            $cint hide $cmd
        }
    }
    # I like to expose [source] as [Include]:
    interp alias $cint Include {} interp invokehidden $cint source
    # give unknown handler a funny name so it doesn't collide:
    interp alias $cint #unknown {} cunk $cint
    interp invokehidden $cint namespace unknown #unknown
    # expose these for the lambda:
    foreach cmd {try set} {
        if {$cmd in [interp hidden $cint]} {
            interp alias $cint #$cmd {} interp invokehidden $cint $cmd
        } else {
            interp alias $cint #$cmd $cint $cmd
        }
    }
    interp invokehidden $cint set Config {}
    try {
        interp invokehidden $cint source $filename
    } on error {e o} {
        puts "Config error: $e"
    } finally {
        interp delete $cint
    }
}

proc readfile {filename} {
    try {
        set fd [open $filename r]
        read $fd
    } finally {
        close $fd
    }
}

proc cunk {cint args} {
    switch [llength $args] {
        1   {
            cerror $cint "Expected value for \"$args\""
        }
        2 {
            lassign $args key value
            set keys [list $key]
        }
        3 {
            lassign $args key1 key2 value
            set keys [list $key1 $key2]
        }
        default {
            cerror $cint "Too many arguments for [lindex $args 0]"
        }
    }
    if {[dict exists [interp invokehidden $cint set Config] {*}$keys]} {
        cerror $cint "Redefinition of $keys"
    }
    if {[string match \n* $value]} {
        set value [interp invokehidden $cint apply [list {{Config {}}} [list #try $value on ok {} {\#set Config}]]]
    }
    interp invokehidden $cint dict set Config {*}$keys $value
}

proc cerror {cint msg} {
    set ctx [interp invokehidden $cint info frame 0]
    set ctx "[dict get $ctx file]:[dict get $ctx line]"
    interp invokehidden $cint return -code error "$msg!\n  at $ctx"
}

puts [loadconf test.conf]

# first, ensure the package autoload commands are all initialised:
catch {package require nonexistent}

# get all the toplevel commands
set before [info commands ::*]

# load Tk
package require Tk
wm withdraw .

# see what commands exist now
set after [info commands ::*]

set commands [lmap c $after {
    expr {$c in $before ? [continue] : $c}
}]

proc is_widget {c} {
    try {
        info args $c
    } on ok {} {
        return false    ;# it's a proc, not a widget
    } on error {} {
        ;# it might be a widget!  Carry on ..
    }
    try {
        $c
    } trap {TCL WRONGARGS} {e o} {
        if {[string match "wrong # args: should be \"$c pathName ?-option value ...?\"" $e]} {
            return true         ;# it's a widget!
        } else {
            puts stderr "Probably not $c"
        }
    } trap { * } {} {
        ;# any other error - not a widget
    } on ok {} {
        ;# no error - oops!
        puts stderr "Sorry!  Shouldn't have run $c"
    }
    return false
}

set widgets [lmap c $commands {
    expr {[is_widget $c] ? $c : [continue]}
}]


# now try Ttk:
package require Ttk
set commands [info commands ::ttk::*]

lappend widgets {*}[lmap c $commands {
    expr {[is_widget $c] ? $c : [continue]}
}]

puts "** Widgets **"
puts [join [lsort $widgets] \n]

# now inspect their runtime state:
foreach w $widgets {
    destroy .test
    $w .test
    set class($w) [winfo class .test]
    set opts [.test configure]
    set opts [lmap o $opts {
        expr {[llength $o] == 2 ? [continue] : [lindex $o 0]}   ;# skip aliases
    }]
    set opts [lsort -dictionary $opts]
    set options($w) $opts
}
parray class
#parray options
#

exit

::tcl::tm::path add [pwd]
package require db

namespace eval billy {

    db::reset {
        db eval {
            drop if exists table packages;
        }
    }
    db::setup {
        if {[db::exists packages]} return
        puts "Setting up billy"
        db eval {
            create table if not exists packages (
                name text,
                ver text collate vcompare,
                arch text,
                filedata blob,
                primary key (name, ver, arch)
            );
        }
    }

    proc add_tms {path} {
        set re {([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)\.tm}
        foreach file [glob -tails -dir $path *.tm] {
            if {[regexp $re $file -> pkg ver]} {
                set fd [open [file join $path $file] r]
                fconfigure $fd -encoding binary -translation binary
                set filedata [read $fd]
                close $fd
                db eval {
                    insert into packages (name, ver, arch, filedata)
                    values (:pkg, :ver, 'tcl', @filedata);
                }
            }
        }
    }

    proc gen_tpm {} {
        set result {}
        db eval {
            select name, ver, arch from packages
        } {
            lappend result [list package $name $ver $arch 0]
        }
        return $result
    }

    proc serve {req} {
        if {[regexp {^/package/list/?$} $req]} {
            set tpm [gen_tpm]
            return [subst -noc {<!--[[TPM[[$tpm]]MPT]] -->}]
        }
        if {[regexp {^/package/name/(.*)/ver/(.*)/arch/(.*)/file$} $req -> name ver arch]} {
            db eval {
                select filedata from packages where
                    name = :name and ver = :ver and arch = :arch
                ;
            } {
                return $filedata
            }
        }
    }

    proc test {args} {
        ::db::init billy.db
        add_tms {*}$args
        puts [serve /package/name/mainscript/ver/1/arch/tcl/file]
        puts [serve /package/list]
    }
}

billy::test {*}$argv

package require sqlite3
package require geturl
package require vfs::zip
::tcl::tm::path add [pwd]
package require db
package require lib

package require platform

namespace eval cuppa {

    variable map_os {
        tcl         %
        linux-%     linux
        win32       windows
        solaris%    {solaris sunos}
        freebsd     freebsd_%
        irix        irix_%
        macosx%     darwin
    }
    variable map_cpu {
        ix86        {x86 intel i_86 i86pc}
        sparc       sun4%
        sparc64     {sun4u sun4v}
        universal   %
        ""          %
        powerpc     ppc
    }

    db::reset {
        db eval {
            drop table if exists servers;
            drop table if exists packages;
            drop table if exists map_os;
            drop table if exists map_cpu;
        }
    }
    db::setup {
        if {[db::exists servers]} return
        log::info {setting up cuppa}
        db eval {
            create table if not exists servers (
                server text not null, uri text not null,
                last_checked integer default 0,
                pri integer default 100,
                primary key (server),
                unique (uri)
            );
            insert or replace
                into servers (pri, server,    uri)
                values  ( 1, 'activestate',  'http://teapot.activestate.com'
                ),      ( 2, 'rkeene',       'http://teapot.rkeene.org'
                );
            create table if not exists packages (
                name    text,
                ver     text collate vcompare,
                arch    text, os text, cpu text,
                server  text,
                pkgurl  text,
                primary key (name, ver, arch, os, cpu, server),
                foreign key (server) references servers (server)
            );

            create table if not exists map_os ( teapot text, local text );
            create table if not exists map_cpu ( teapot text, local text );
        }
        init_maps
    }

    proc init_maps {} {
        puts "setting up CPU/OS mappings"

        variable map_os
        variable map_cpu

        db eval {delete from map_os; delete from map_cpu;}

        foreach {teapot local} $map_os {
            foreach t $teapot {
                foreach l $local {
                    db eval {
                        insert into map_os (teapot, local) values (:t, :l)
                    }
                }
            }
        }

        foreach {teapot local} $map_cpu {
            foreach t $teapot {
                foreach l $local {
                    db eval {
                        insert into map_cpu (teapot, local) values (:t, :l)
                    }
                }
            }
        }
    }

    proc join_url {args} {
        set url [join $args /\0/]
        regsub -all {/*\0/*} $url / url
        return $url
    }

    proc server_uri {server args} {
        db eval {select uri from servers where server = :server} {
            return [join_uri $uri {*}$args]
        }
    }
    proc update_cache {{limit 604800}} {
        set now [clock seconds]
        set last [expr {[clock seconds]-$limit}]
        log::info {updating servers since $last}
        db eval {select server, uri, last_checked from servers where last_checked < :last} {
            set when [clock format $last_checked]
            log::info {Updating cache for $server (last: $when)}
            cache_server $server $uri
        }
    }

    proc cache_server {server uri} {
        set data [geturl [join_url $uri /package/list]]
        set now [clock seconds]
        if { ![regexp {\[\[TPM\[\[(.*)\]\]MPT\]\]} $data -> data]} {
            throw {CUPPA BADTPM} "No TPM data at $uri"
        }
        if {  [catch {llength $data}] } {
            throw {CUPPA BADTPM} "TPM data not a list at $uri"
        }
        db eval {
            delete from packages where server = :server
        }
        foreach record $data {
            lassign $record type pkg ver arch
            if {$type ne "package"} continue
            if {$arch eq "source"}  continue
            regexp {^(.*)(?:-(.*))?$} $arch -> os cpu
            try {
                package vsatisfies $ver 0-
            } on error {e o} {
                log::warn {Bad version: ignoring! $pkg $ver @ $server}
                continue
            }
            set pkgurl [join_url $uri package name $pkg ver $ver arch $arch file]
            db eval {
                insert or replace
                into packages (name, ver, arch, os, cpu, server, pkgurl)
                values (:pkg, :ver, :arch, :os, :cpu, :server, :pkgurl);
            }
        }
        db eval {
            update servers set last_checked = :now where server = :server;
        }
    }

    db::qproc Find {
        name %  ver 0-  arch %  os %  cpu %
    } {
            with t as (
                select distinct name, ver, arch, os, cpu, server, pkgurl, pri
                from packages
                 inner join servers using (server)
                   -- inner join map_cpu on ( cpu like teapot and :cpu like local )
                where name like :name
                  and vsatisfies(ver, :ver)
                  and (cpu like :cpu
                    or exists (select * from map_cpu where cpu like teapot and :cpu like local))
                  and (os like :os
                    or exists (select * from map_os  where os  like teapot and :os  like local))
            )
            select * from t
            -- where ver = (select max(ver) from t)
            order by ver desc, pri;
    }

    proc find {args} {
        Find {pkgurl} $args {
            puts "Found at $pkgurl"
        }
    }

    proc platform {} {
        split [platform::generic] -
    }

    proc download {path uri} {
        set data [geturl $uri]
        set fd [open $path w]
        fconfigure $fd -encoding binary
        puts -nonewline $fd $data[unset data]
        close $fd
        puts "Wrote $path"
    }

    proc check_exists {dir name ver} {
        foreach cmd [info commands [namespace current]::Path:*] {
            set path [$cmd $dir $name $ver]
            if {[file exists $path]} {return $path}
        }
    }

    proc Path:dl {dir name ver} {
        set name [string trimleft $name ::]
        file join $dir [string map {:: _ _ __} "$name-$ver.zip"]
    }
    proc Path:tm {dir name ver} {
        set name [string trimleft $name ::]
        file join $dir [string map {:: /} "$name-$ver.tm"]
    }
    proc Path:dir {dir name ver} {
        set name [string trimleft $name ::]
        file join $dir [string map {:: _ _ __} "$name-$ver"]
    }

    proc install {dir pkg args} {
        lassign [platform] os cpu
        lib::dictargs args {
            os  $os
            cpu $cpu
            ver 0-
        }
        if {$os eq "tcl"} {
            set cpu %
        }
        Find {name ver uri} {name $pkg ver $ver os $os cpu $cpu} {
            set loc [check_exists $dir $name $ver]
            if {$loc ne ""} {
                throw [list CUPPA EXISTS $loc] "Package (maybe?) exists at \"$loc\""
            }
            set path [Path:dl $dir $name $ver]
            puts "Trying $uri -> $path"
            try {
                download $path $uri
            } on error {e o} {
                puts "geturl $uri -- $e"
                continue
            } on ok {} {
                break
            }
        }
        if {![info exists path]} {
            throw {CUPPA NOTFOUND} "No candidate $pkg for $os-$cpu"
        }
        if {![file exists $path]} {
            throw {CUPPA ERROR} "Failed to install $path"
        }
        try {
            set vfsd [vfs::zip::Mount $path $path]
        } on error {} {
            set dest [Path:tm $dir $name $ver]
            file rename $path $dest
            set path $dest
            puts "$path is a tcl module: finished!"
            return $path
        }
        try {
            set dest [file rootname $path]
            if {[file exists $dest]} {
                error "Destination path exists: [list $dest]"
            }
            set dest [Path:dir $dir $name $ver]
            file copy $path $dest
        } finally {
            vfs::zip::Unmount $vfsd $path
        }
        file delete $path
        set path $dest
        puts "$path is a tcl package: finished"
        return $path
    }

    namespace ensemble create -map {
        update  update_cache
        check   check_exists
        find    find
        install install
    }

}


#::cuppa::main {*}$argv
lib::main args {
    db::init cuppa.db
    puts [cuppa {*}$args]
}

package require sqlite3
package require log 0

namespace eval db {
    namespace export *

    proc db {args} { init; tailcall db {*}$args }

    proc glob {s} {
        string map {* % ? _} $s
    }
    proc qn {s} {
        return \"[string map {\" ""} $s]\"
    }
    proc qs {s} {
        return '[string map {' ''} $s]'
    }

    # decodes a list like {a b:bee c}
    # into "a as a, b as bee, c as c"
    proc sargs {fields} {
        join [lmap f $fields {
            lassign [split $f :] name alias
            if {$alias eq ""} {
                string cat "[qn $name]"
            } else {
                string cat "[qn $name] as [qn $alias]"
            }
        }] ,
    }
    proc vargs {fields} {
        lmap f $fields {regsub {^.*:} $f {}}
    }

    # declare an sql-backed procedure
    # a qproc takes arguments: fields where ??varName? script?
    #  - fields is a list of names to select, or name:alias to project [sarg]/[farg]
    #  - where is a [lib::subl] dict of parameters to the query
    # additional args are like the ??row? script? args to sqlite
    proc qproc {name defaults sqlquery} {
        set name [lib::upns 1 $name]

        dict set map @SQL   [list $sqlquery]
        dict set map @DEF   [list $defaults]

        set args {fields where args}
        set body [string map $map {
            set _FIELDS [db::sargs $fields]
            set _VARS   [db::vargs $fields]
            set _SQL    [string map [list * $_FIELDS] @SQL]
            set _ARGS   [lib::updo lib::lsub $where]
            lib::dictargs _ARGS @DEF
            lib::dictable $_VARS [db eval $_SQL {*}$args]
        }]
        proc $name $args $body
    }

    proc init {{filename ""}} {
        if {[running]} {
            return
        }
        log::info {$filename}
        sqlite3 [namespace current]::db $filename
        db collate  vcompare    {package vcompare}
        db function vsatisfies  {package vsatisfies}
        Setup
    }

    proc stat {} {
        if {![running]} {
            puts "not running"
            return
        }
        db eval {select name from sqlite_master where type = 'table'} {
            db eval "select count(1) count from [qn $name]" {
                puts "$name: $count records"
            }
        }
    }

    proc tables {{pattern}} {
        db eval {select name from sqlite_master where type = 'table' and name like :pattern}
    }

    proc exists {table} {
        db exists {select 1 from sqlite_master where type = 'table' and name = :table}
    }

    proc running {} {
        expr {[info procs [namespace current]::db] eq {}}
    }

    variable Setup_scripts {}
    proc Setup {} {
        variable Setup_scripts
        foreach {namespace script} $Setup_scripts {
            log::info {setup $namespace}
            apply [list {} $script $namespace]
        }
    }
    proc setup {script} {
        variable Setup_scripts
        set ns [uplevel 1 {namespace current}]
        dict set Setup_scripts $ns $script              ;# register a setup script
        if {[running]} {
            log::info {late setup $namespace}
            apply [list {} $script $ns]                 ;# apply immediately
        }
        tailcall namespace import [namespace which db]  ;# make db accessible
    }

    variable Reset_scripts
    proc reset script {
        variable Reset_scripts
        set ns [uplevel 1 {namespace current}]
        dict set Reset_scripts $ns $script
    }

}

# leaves reads teapot descriptions
#
# SYNOPSIS:
#
#  $ leaves.tcl scan lib/
#  $ leaves.tcl find path lib/%
#  $ leaves.tcl deps lib/snit-2.3.2
#
::tcl::tm::path add [pwd]
package require db
package require lib
package require vfs::mk4
package require vfs::tar
package require vfs::zip

namespace eval leaves {
    db::reset {
        db eval {
            drop table if exists teapkgs;
            drop table if exists teameta;
        }
    }
    db::setup {
        if {[db::exists teapkgs]} return
        puts "Setting up leaves"
        db eval {
            create table if not exists teapkgs (
                name text,
                ver text collate vcompare,
                arch text,
                path text,
                primary key (path),
                -- index teapkgs_i_nvp (name, ver, arch),
                unique (path)
            );
            create table if not exists teameta (
                path text,
                field text,
                value text,
                primary key (path, field),
                foreign key (path)
                  references pkg_meta (path)
                    on delete cascade
            );
        }
        #subject description require platform summary recommend category license
    }

    proc db_insert {args} {
        set keys {key name version platform path}
        set d [dict filter $args {*}$keys]
        dict with d {
            db eval {
                insert or replace
                    into teapkgs ( name,  ver,      arch,      path)
                          values (:name, :version, :platform, :path);
            }
        }
        foreach {field value} $args {
            if {$field in $keys} continue
            if {$field in {require recommend}} {
                set value [parse_reqs $value]
            }
            db eval {
                insert or replace
                    into teameta ( path,  field,  value)
                          values (:path, :field, :value);
            }
        }
    }

    proc scan {topdir args} {
        foreach path [glob $topdir/*] {
            try {
                parse_teapot $path
            } on ok {teameta} {
                log::info {Found teameta in $path}
                foreach {key meta} $teameta {
                    log::info { + inserting record for $key}
                    db_insert path $path {*}$args {*}$meta
                }
            } on error {e o} {
                if {[file isdirectory $path]} {
                    log::info {Recursing into $path}
                    scan $path {*}$args
                }
            }
        }
        set n [db onecolumn {select count(1) from teapkgs}]
        set m [db onecolumn {select count(1) from teameta}]
        log::info {Scanned $n packages, learned $m facts}
    }

    # simplifies a set of version bounds into a single bound
    proc vsimplify {vers} {
        set vers [lassign $vers first]
        set first [split $first -]
        lassign $first A B
        foreach ver $vers {
            lassign [split $ver -] a b
            if {[package vcompare $A $a] < 0} { set A $a }
            if {$B eq ""} {set B $b}
            if {$b eq ""} continue
            if {[package vcompare $b $B] < 0} { set B $b }
        }
        return $A-$B
    }
    #puts [vsimplify {8 8.4- 7.2-8.7.9 8.7.5-8.8}]; exit

    # parses a {Meta require} argument into a dictionary
    #
    # result always contains:   {name version}
    #           may contain:    {is platform archglob}
    proc parse_reqs {reqlist} { lmap r $reqlist { parse_req {*}$r } }
    proc parse_req {name args} {

        # ?ver ...? ?-opt val ...?
        set i -1
        foreach v $args {
            if {[string match -* $v]} break
            incr i
        }
        set vers [lrange $args 0 $i]
        set opts [lrange $args $i+1 end]

        # defaults:
        set o(-name)    $name
        set o(-exact)   false
        set o(-is)      package

        foreach {key val} $opts {
            if {$key ni {-archglob -is -platform -require  -version -exact}} {
                error "Invalid entity reference in \"$name\": $key"
            }
            if {$key eq "-require"} {
                lappend vers $val
            } else {
                set o($key) $val
            }
        }

        # backward-compatibility:
        if {[info exists o(-version)]} {
            if {$vers ne ""} {
                error "Cannot use -version with versions or -require"
            }
            lappend vers $o(-version)
            unset o(-version)
        }

        set vers [lmap v $vers {join $v -}]  ;# legacy list notation

        if {$o(-exact)} {
            if {[string match {*[- ]*} $vers]} {
                error "Can only use -exact with a single version! \"$name $vers\""
            }
            set v [lindex $vers 0]
            set v1 [split $v .]
            # FIXME: behaviour on a.b versions may be dodgy
            # NOTE: npm uses ^ for a similar (?) meaning:
            #     ^1.2.3 := >=1.2.3 <2.0.0
            #     ^0.2.3 := >=0.2.3 <0.3.0
            #     ^0.0.3 := >=0.0.3 <0.0.4
            #  see https://nodesource.com/blog/semver-tilde-and-caret/
            lset v1 end [expr {1+[lindex $v1 end]}]
            set v1 [join $v1 .]
            lset vers 0 $v-$v1
        }
        unset o(-exact)

        # normalise versions into vcompare strings
        set vers [lmap v0 $vers {
            if {[string match *-* $v0]} {
                string cat $v0
            } else {    ;# synthesise upper bound
                set v1 [split $v0 .]
                set v1 [lindex $v1 0]
                incr v1
                string cat $v0-$v1
            }
        }]

        if {[info exists o(-platform)]} {
            if {$o(-platform) ni {unix windows macosx}} {
                error "Invalid -platform $o(-platform) ($name)"
            }
        }

        if {$vers ne ""} {
            set o(-version) [vsimplify $vers]
        }

        if {$o(-is) eq "package"} {
            unset o(-is)
        }

        # result:
        dict map {k v} [array get o] {
            set k [string trimleft $k -]
            set v
        }
    }

    # returns a dict which ALWAYS has   {name version}
    #   and MAY have more               {platform require ...}
    proc parse_teapot {path} {
        set meta [get_meta $path]
        set meta [string trim $meta]
        foreach line [split $meta \n] {
            set line [string trimleft $line #]
            set line [string trim $line]
            if {$line eq ""} {continue}
            try {
                set args [lassign $line cmd]
            } on error {} {
                error "Malformed teapot"
            }
            set cmd [string tolower $cmd]
            if {$cmd in {package profile application}} {
                lassign $args name version
                set pkgInfo($name-$version) [dict create name $name version $version]
                continue
            } elseif {$cmd ni {meta}} {
                error "Unknown TEAPOT.txt cmd: $cmd $args"
            }
            set args [lassign $args field]
            set field [string tolower $field]
            dict lappend pkgInfo($name-$version) $field {*}$args
        }
        array get pkgInfo
    }

    proc get_meta {path} {
        if {[file isdirectory $path]} {
            set fd [open $path/teapot.txt r]
            set meta [read $fd]
            close $fd
            return $meta
        }
        set fd [open $path r]
        if {[get_meta_text $fd meta]} {
            return $meta
        }
        seek $fd 0
        if {[get_meta_bin $fd meta]} {
            return $meta
        }
        close $fd
        set unmount [try_mount $path]
        if {$unmount ne ""} {
            try {
                return [get_meta $path]
            } finally {
                {*}$unmount
            }
        }
    }
    proc get_meta_text {fd _meta} {
        upvar 1 $_meta meta
        gets $fd line0
        if {![catch {llength $line0} r] && $r == 3} {
            gets $fd line1
            if {![catch {lindex $line1 0} r] && $r eq "Meta"} {
                set meta $line0\n$line1\n[read $fd]
                return true
            }
        }
        return false
    }
    proc get_meta_bin {fd _meta} {
        upvar 1 $_meta meta
        fconfigure $fd -encoding binary
        set block [read $fd 16384]
        return [regexp {# @@ Meta Begin(.*)# @@ Meta End} $block -> meta]
    }

    proc try_mount {path} {
        foreach ext {zip mk4 tar} {
            try {
                set fd [::vfs::${ext}::Mount $path $path]
            } on error {e o} {
                puts "Failed to mount ${ext}://$path"
                continue
            } on ok {fd} {
                puts "Mounted ${ext}://$path"
                return [list ::vfs::${ext}::Unmount $fd $path]
            }
        }
        return ""   ;# failed to mount
    }

    db::qproc Find {
        pkg     %
        ver     0-
        path    %
    } {
        select *
          from teapkgs
         where name like :pkg
           and vsatisfies(ver, :ver)
           and path like :path || '%'
    }
    proc find args {
        Find {path} $args
    }

    db::qproc Deps {
        pkg     %
        ver     0-
        path    %
    } {
        select *
          from teameta
          natural join teapkgs
        where name like :pkg
          and vsatisfies(ver, :ver)
          and path like :path || '%'
          and field = ('require')
    }
    proc deps {args} {
        set table [Deps {name arch path value:reqs} $args]
        switch [llength $table] {
            0 {
                log::warn {No match for $args}
            }
            1 {
                lassign $table rec
                dict with rec {}
                log::warn {Deps from: $path}
                return $reqs
            }
            default {
                log::warn {Ambiguous match for $args}
                foreach rec $table {
                    log::warn { + Candidate:  $rec}
                }
            }
        }
    }

    namespace ensemble create -subcommands {scan deps find}
}

lib::main args {
    db::init leaves.db
    puts [leaves {*}$args]
}

package require platform

namespace eval lib {

    proc putl args {puts $args}

    proc main {arglist body} {      ;# lib::main {args} {puts "Invoked directly, with $args"}
        set m [expr {[info exists ::argv0]
                && [file dirname [file normalize $::argv0/...]]
                eq [file dirname [file normalize [lib::updo info script]/...]]}]
        if {$m} {
            package require log 0   ;# fixme - circular dependency too!
            set ns [lib::upns]
            set s [updo info script]
            log::warn "$s - running on [platform::identify] ([platform::generic])"
            tailcall apply [list $arglist $body $ns] {*}$::argv
        }
    }
    
    proc lsub script {              ;# [sl] from the wiki
        set res {}
        set parts {}
        foreach part [split $script \n] {
            lappend parts $part
            set part [join $parts \n]
            #add the newline that was stripped because it can make a difference
            if {[info complete $part\n]} {
                set parts {}
                set part [string trim $part]
                if {$part eq {}} {
                    continue
                }
                if {[string index $part 0] eq {#}} {
                    continue
                }
                #Here, the double-substitution via uplevel is intended!
                lappend res {*}[uplevel list $part]
            }
        }
        if {$parts ne {}} {
            error [list {incomplete parts} [join $parts]]
        }
        return $res
    }

    proc my {cmd args} {            ;# create cmdprefixes with local commands
        list [namespace current]::$cmd {*}$args
    }

    proc dictargs {_args defaults} {
        upvar 1 $_args args
        set defaults [uplevel 1 [my lsub $defaults]]
        set bad [dict filter $args script {k _} {
            expr {![dict exists $defaults $k]}
        }]
        if {$bad ne ""} {
            tailcall tailcall throw {TCL BADARGS} "Unexpect arguments \"$bad\"\naccepted arguments are ([dict keys $defaults])"
        }
        set args [dict merge $defaults $args]
        tailcall dict with $_args {}
    }

    ;# lang-utils
    proc alias {alias cmd args} {
        set alias   [upns 1 $alias]
        set cmd     [upns 1 $cmd]
        interp alias    {} $alias   {} $cmd {*}$args
    }

    proc upns {{lvl 1} args} {  ;# doubles as resolve-cmdname-in-caller
        if {$args eq ""} {
            tailcall uplevel $lvl {namespace current}
        } else {
            set cargs [lassign $args cmd]
            if {[string match :* $cmd]} {
                return $args
            }
            set ns [uplevel [expr {$lvl+1}] {namespace current}]
            set ns [string trimright $ns :]
            return [list ${ns}::$cmd {*}$cargs]
        }
    }
    proc updo {{lvl 1} args} {
        tailcall uplevel $lvl $args
    }

    proc dictable {names list} {
        set args [join [lmap name $names {
            set name [list $name]
            subst -noc {$name [set $name]}
        }] " "]
        lmap $names $list "dict create $args"
    }

}

# SYNOPSIS:
#
#  output control
#
#   log::to stderr
#   log::copy chan ?name?
#   loc::close chan
#
#  Levels set by namespace from {debug info warn error}
#
#   log::level ?level?
#
#  Messages are not substituted if level not exceeded - beware side effects
#
#   log::info {message $subst string}
#
::tcl::tm::path add [pwd]
package require lib

namespace eval log {

    variable to {stderr}
    lib::alias to set [namespace current]::chan

    variable levels { error warn info debug }   ;# wtf is "notice" anyway?
    variable profiles { :: 2 }      ;# default (root ns) gets {error warn}

    apply {{levels {i -1}} {
        foreach l $levels {
            lib::updo 1 lib::alias $l log [incr i] $l
        }
    }} $levels

    proc never {args} {
        foreach level $args {
            log::warn {suppressing $level}
            catch {
                lib::alias $level list
            }
        }
    }

    proc level {{n ""}} {
        variable levels
        variable profiles
        set ns [lib::upns]
        if {$n eq ""} {
            return [Getlevel $ns]
        } elseif {$n in {0 1 2 3}} {
        } elseif {-1 != [set i [lsearch -exact $levels $n]]} {
            set n $i
        } else {
            error "Invalid level \"$n\": should be an integer or in ($levels)"
        }
        dict set profiles $ns $n
        return $n
    }

    proc Getlevel {ns} {
        variable profiles
        while {![dict exists $profiles $ns]} {
            set ns [namespace parent $ns]
        }
        dict get $profiles $ns
    }

    variable start [clock milliseconds]
    proc runtime {} {
        variable start
        set now [clock milliseconds]
        set elapsed [expr {$now - $start}]
        set s  [expr {$elapsed / 1000}]
        set ms [expr {$elapsed % 1000}]
        set ms [format %03d $ms]
        #string trimleft [clock format $s -gmt 1 -format "%H:%M:%S.$ms"] 0:
        clock format $s -gmt 1 -format "%H:%M:%S.$ms"
    }

    variable copies {}
    proc copy {chan {name ""}} {
        if {$name eq ""} {set name $chan}
        variable copies
        dict set copies $chan $name
    }
    proc close {chan} {
        variable copies
        dict unset copies $chan
    }

    proc log {l level args} {
        variable to
        variable copies
        set ns [lib::upns]
        set t [Getlevel $ns]
        if {$l > $t} return
        set args [lmap a $args {lib::updo 1 subst $a}]
        if {[llength $args] == 1} {lassign $args args}
        set context [lib::updo namespace which [lindex [::info level -1] 0]]
        set lvl [dict get {
            debug   "d   "
            info    "in  "
            warn    "wrn "
            error   "ERR!"
        } $level]
        set msg "[runtime] $lvl $context | $args"
        puts $to $msg
        dict for {copy name} $copies {
            try {
                puts $copy $msg
            } on error {e o} {
                puts $to "[runtime]: warn: closed $name due to $e"
                close $copy
            }
        }
    }

}

package require tdom

set fd [open ref/packages.xml r]
fconfigure $fd -encoding utf-8
set data [read $fd]
set dom [dom parse $data]

proc dump {_d} {
    set _n [dict get $_d name]
    if {$_n ne "tdom"} return
    array set $_n $_d
    parray $_n
}
foreach p [$dom selectNodes {/gutter/package}] {
    set pkg {}
    dict set pkg name [$p @id]
    foreach c [$p childNodes] {
        set attr [$c nodeName]
        set text [$c asText]
        if {$attr in {author license requires homepage summary description}} {
            dict set pkg $attr $text
        }
        if {$attr in {link}} {
            dict lappend pkg $attr [$c @rel] $text
        }
        if {$attr in {release}} {
            dict lappend pkg $attr [$c @version] $text
        }
        if {$attr in {depends}} {
            dict lappend pkg $attr {*}[split $text ,]
        }
    }
    dump $pkg
}

# The goal here is to redirect events from one window to another, while preserving all of
# their fields.  To decide what fields, we parse the text of event(n).
#
# this uncovered a BUG:  [event generate . <<Cut>> -serial 1 -bar   returns the wrong error

package require Tk
package require Ttk

namespace eval Event {

    # copied from http://www.tcl.tk/man/tcl/TkCmd/event.htm#M9
    variable Manual {
-above window
    Window specifies the above field for the event, either as a window path name or as an integer window id. Valid for Configure events. Corresponds to the %a substitution for binding scripts.

-borderwidth size
    Size must be a screen distance; it specifies the border_width field for the event. Valid for Configure events. Corresponds to the %B substitution for binding scripts.

-button number
    Number must be an integer; it specifies the detail field for a ButtonPress or ButtonRelease event, overriding any button number provided in the base event argument. Corresponds to the %b substitution for binding scripts.

-count number
    Number must be an integer; it specifies the count field for the event. Valid for Expose events. Corresponds to the %c substitution for binding scripts.

-data string
    String may be any value; it specifies the user_data field for the event. Only valid for virtual events. Corresponds to the %d substitution for virtual events in binding scripts.

-delta number
    Number must be an integer; it specifies the delta field for the MouseWheel event. The delta refers to the direction and magnitude the mouse wheel was rotated. Note the value is not a screen distance but are units of motion in the mouse wheel. Typically these values are multiples of 120. For example, 120 should scroll the text widget up 4 lines and -240 would scroll the text widget down 8 lines. Of course, other widgets may define different behaviors for mouse wheel motion. This field corresponds to the %D substitution for binding scripts.

-detail detail
    Detail specifies the detail field for the event and must be one of the following:

        NotifyAncestor
            

        NotifyNonlinearVirtual

        NotifyDetailNone
            

        NotifyPointer

        NotifyInferior
            

        NotifyPointerRoot

        NotifyNonlinear
            

        NotifyVirtual

    Valid for Enter, Leave, FocusIn and FocusOut events. Corresponds to the %d substitution for binding scripts.

-focus boolean
    Boolean must be a boolean value; it specifies the focus field for the event. Valid for Enter and Leave events. Corresponds to the %f substitution for binding scripts.

-height size
    Size must be a screen distance; it specifies the height field for the event. Valid for Configure events. Corresponds to the %h substitution for binding scripts.

-keycode number
    Number must be an integer; it specifies the keycode field for the event. Valid for KeyPress and KeyRelease events. Corresponds to the %k substitution for binding scripts.

-keysym name
    Name must be the name of a valid keysym, such as g, space, or Return; its corresponding keycode value is used as the keycode field for event, overriding any detail specified in the base event argument. Valid for KeyPress and KeyRelease events. Corresponds to the %K substitution for binding scripts.

-mode notify
    Notify specifies the mode field for the event and must be one of NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed. Valid for Enter, Leave, FocusIn, and FocusOut events. Corresponds to the %m substitution for binding scripts.

-override boolean
    Boolean must be a boolean value; it specifies the override_redirect field for the event. Valid for Map, Reparent, and Configure events. Corresponds to the %o substitution for binding scripts.

-place where
    Where specifies the place field for the event; it must be either PlaceOnTop or PlaceOnBottom. Valid for Circulate events. Corresponds to the %p substitution for binding scripts.

-root window
    Window must be either a window path name or an integer window identifier; it specifies the root field for the event. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, and Motion events. Corresponds to the %R substitution for binding scripts.

-rootx coord
    Coord must be a screen distance; it specifies the x_root field for the event. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, and Motion events. Corresponds to the %X substitution for binding scripts.

-rooty coord
    Coord must be a screen distance; it specifies the y_root field for the event. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, and Motion events. Corresponds to the %Y substitution for binding scripts.

-sendevent boolean
    Boolean must be a boolean value; it specifies the send_event field for the event. Valid for all events. Corresponds to the %E substitution for binding scripts.

-serial number
    Number must be an integer; it specifies the serial field for the event. Valid for all events. Corresponds to the %# substitution for binding scripts.

-state state
    State specifies the state field for the event. For KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, and Motion events it must be an integer value. For Visibility events it must be one of VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured. This option overrides any modifiers such as Meta or Control specified in the base event. Corresponds to the %s substitution for binding scripts.

-subwindow window
    Window specifies the subwindow field for the event, either as a path name for a Tk widget or as an integer window identifier. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, and Motion events. Similar to %S substitution for binding scripts.

-time integer
    Integer must be an integer value; it specifies the time field for the event. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Enter, Leave, Motion, and Property events. Corresponds to the %t substitution for binding scripts.

-warp boolean
    boolean must be a boolean value; it specifies whether the screen pointer should be warped as well. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, and Motion events. The pointer will only warp to a window if it is mapped.

-width size
    Size must be a screen distance; it specifies the width field for the event. Valid for Configure events. Corresponds to the %w substitution for binding scripts.

-when when
    When determines when the event will be processed; it must have one of the following values:

    now
        Process the event immediately, before the command returns. This also happens if the -when option is omitted.

    tail
        Place the event on Tcl's event queue behind any events already queued for this application.

    head
        Place the event at the front of Tcl's event queue, so that it will be handled before any other events already queued.

    mark
        Place the event at the front of Tcl's event queue but behind any other events already queued with -when mark. This option is useful when generating a series of events that should be processed in order but at the front of the queue.

-x coord
    Coord must be a screen distance; it specifies the x field for the event. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Motion, Enter, Leave, Expose, Configure, Gravity, and Reparent events. Corresponds to the %x substitution for binding scripts. If Window is empty the coordinate is relative to the screen, and this option corresponds to the %X substitution for binding scripts.

-y coord
    Coord must be a screen distance; it specifies the y field for the event. Valid for KeyPress, KeyRelease, ButtonPress, ButtonRelease, Motion, Enter, Leave, Expose, Configure, Gravity, and Reparent events. Corresponds to the %y substitution for binding scripts. If Window is empty the coordinate is relative to the screen, and this option corresponds to the %Y substitution for binding scripts. 
    }

    variable Options
    variable Fields

    apply [list {} {
        variable Manual
        #set Manual [exec man --nh --nj event]
        regexp {\nEVENT FIELDS\n(.*?)(?=\n[A-Z])} $Manual -> Manual
        variable Options
        variable Fields

        foreach {_ option desc} [regexp -all -inline -lineanchor {^\s*?(-\S*) [^\n]*\n(.*)\.$} $Manual] {

            regsub -all {\s\s+} $desc " " desc
            set codes [regexp -all -inline {%.} $desc]
            regexp -nocase {Valid for (.*?) events.} $desc -> kinds
            set kinds [string map {"," "" " and " " "} $kinds]

            switch -exact $option {
                -warp - -when {continue}
                debug {
                    puts "option $option"
                    puts "desc $desc"
                    puts "codes $codes"
                    puts "kinds $kinds"
                }
            }

            foreach kind $kinds {
                dict lappend Fields $kind $option
            }

            switch -exact $option {
                -x  {
                    # FIXME: %x, %y should be relative to %W, so they need to be adjusted here!
                    dict set Options -x { -x [expr {$win eq "" ? %X : %x}]}
                }
                -y {
                    # FIXME: %x, %y should be relative to %W, so they need to be adjusted here!
                    dict set Options -y { -y [expr {$win eq "" ? %Y : %y}]}
                }
                default {
                    if {[lassign $codes code] ne ""} {
                        error "Bad codes for $option: $codes"
                    }
                    dict set Options $option " {*}\[if {{$code} ne {??}} {list [list $option $code]}\]"
                }
            }
        }
    } [namespace current]]

    proc redirect_script {event target} {
        variable Fields
        variable Options
        set script "event generate $target $event"
        set options [dict get $Fields "all"]
        if {[string match <<*>> $event]} {
            lappend options {*}[dict get $Fields "virtual"]
        }
        catch {
            lappend options {*}[dict get $Fields $event]
        }
        foreach opt $options {
            append script [dict get $Options $opt]
        }
        #set script "puts [list $script]"
        #puts $script
        return $script
    }

    proc redirect {win event target} {
        set script [redirect_script $event $target]
        append script ";break"
        bind $win $event $script
    }
}

if 0 {
    namespace path ::ttk
    pack [labelframe .f -text "Container"]
    pack [entry .e -textvariable str] -in .f
    bindtags .e {.e Entry .f all}
    set str "Hello"
    bind .f <<Cut>> {puts "<<Cut>> @ %W"}
    puts [Event::redirect .e <<Cut>> .f]
}

package require http
package require uri
catch {
    package require tls
    http::register https 443 ::tls::socket
}
::tls::init -tls1 1 -tls1.2 1 -tls1.1 0 -ssl3 0 -ssl2 0

#http::config -useragent poop   ;# ?? I think this was to get around sourceforge?

# -- simple wrapper for http::geturl
#  FIXME:  add wget (getfile, binary mode)
#  this would be cool as a filesystem too
proc geturl {url {_meta {}}} {

#            $n text
#        }
#    }
#    namespace export *
#    namespace ensemble create
#}

if {[info script] eq $::argv0 && $::argv ne ""} {
    foreach url $::argv {
        puts "Getting $url"
        geturl $url
    }
}

# coroutines are famously good at two things:
#  - asynchronous code that yields to the event loop
#  - generators
#
# I was lamenting the fact that these can't be combined, when a legitimate
# use of [yieldto yield] occurred to me.  This is that nightmare.
#
# Particularly fun:  draw what happens to the coroutine stack when
# [::iterators::yieldfor] is used!

namespace eval iterators {

    namespace export {iterate iterator}

    # define an interator that uses the "standard" protocol.
    # see also tcllib generator
    proc iterator {name arglist body} {
        proc $name $arglist "
            ::yield \[info coroutine\]
            try {
                $body
                return -code break
            }
        "
    }

    # start an iterator.
    proc iterate {cmd args} {
        variable NUM
        coroutine iter#[incr NUM] $cmd {*}$args
    }

    # this is the magic.  Example:  [yieldfor fileevent $chan readable]
    proc ::yieldfor {cmd args} {
        set cmd [uplevel 1 [list namespace which -command $cmd]]
        $cmd {*}$args [info coroutine]
        yield
    }

    # but when used inside an iterator, [yieldfor] means something else
    proc yieldfor {cmd args} {
        set cmd [uplevel 1 [list namespace which -command $cmd]]
        yieldto try "
            [list yieldfor $cmd {*}$args]
            continue
        "
    }

    # so we need coroutine::util analogues that use [yieldfor]
    # for any asynchronous functions we want to use in our generators
    # this is the 80% solution
    proc gets {chan varname} {
        upvar 1 $varname var
        while 1 {
            if {[::gets $chan x] >= 0} {
                tailcall set $varname $x
            }
            if {[::chan eof $chan]} {
                return -1
            }
            if {[::chan blocked $chan]} {
                yieldfor ::chan event $chan readable
            }
        }
    }

    proc after {ms args} {
        if {$args eq "" && ($ms eq "idle" || [string is digit -strict $ms])} {
            tailcall yieldfor ::after $ms
        } else {
            tailcall ::after $ms {*}$args
        }
    }

    # now we just define some iterators to test with.
    # notice this one uses asynchronous gets!
    iterator input {{chan stdin}} {
        while {[gets $chan line] >= 0} {
            yield $line
        }
    }

    iterator range {{n 10}} {
        while {[incr i] < 10} {
            yield $i
        }
    }

    iterator double {iterator} {
        while 1 {
            set x [$iterator]
            yield $x$x
        }
    }
    iterator squares {iterator} {
        while 1 {
            set x [$iterator]
            yield [expr {$x*$x}]
        }
    }
}

namespace path ::iterators

# notice that
chan configure stdin -blocking 0

proc main {} {
    set iter [iterate input stdin]
    set iter [iterate double $iter]
    set iter [iterate double $iter]
    puts "Innermost iter: $iter"
    while 1 {
        set i [$iter]
        puts "Got: $i"
    }
    puts done
    exit
}
coroutine Main main
vwait ::forever
exit

# an experiment in how hard we can overload [loop]
# nb: args are not tip288-decomposable!
proc loop args {
    tailcall loop/[llength $args] {*}$args
}

proc loop/1 script {
    tailcall while 1 $script
}

proc loop/2 {iters script} {
    for {set i 0} {$i < $iters} {incr i} {
        uplevel 1 $script
    }
}

proc loop/3 {varName iters script} {
    upvar 1 $varName i
    for {set i 0} {$i < $iters} {incr i} {
        uplevel 1 $script
    }
}

proc loop/4 {varName from to script} {
    upvar 1 $varName i
    set i $from
    set incr [expr {$to > $from ? 1 : -1}]
    set cont [expr {$from > $to}]
    for {set i $from} {($i > $to) == $cont} {incr i $incr} {
        uplevel 1 $script
    }

}

proc loop/5 {varName from to incr script} {
    upvar 1 $varName i
    set i $from
    set cont [expr {$from > $to}]
    for {set i $from} {($i > $to) == $cont} {incr i $incr} {
        uplevel 1 $script
    }
}

proc test {} {
    loop {  ;# would loop forever
        loop 2 {
            puts "Do this twice"
        }
        loop i 2 {
            puts "Twice with index: $i"
        }
        loop i 9 7 {
            puts "Nine and Eight: $i"
        }
        loop i 9 0 -2 {
            puts "Descending odd digits: $i"
        }
        break   ;# otherwise loop forever
    }
}

test

# first, hook package:
oo::class create PkgMapper {
    variable Chain 
    variable Deps
    variable Cmd
    constructor {cmd args} {
        set Cmd $cmd
        set Chain {}
        set Deps {}
    }
    method info {} {
        array set deps $Deps
        parray deps
    }
    method package {cmd args} {
        switch $cmd {
            "require" {
                set reqs [lassign $args pkg]
                if {$pkg eq "-exact"} {
                    set reqs [lassign $reqs pkg]
                }
                lappend Chain $pkg
                set rc [catch {uplevel 1 [list $Cmd $cmd {*}$args]} e o]
                if {[llength $Chain] > 1} {
                    dict lappend Deps {*}[lrange $Chain end-1 end]
                }
                set Chain [lreplace $Chain end end]
                if {$rc != 0} {
                    dict unset Deps $pkg
                }
                if {[dict exists $o -level]} {
                    dict incr o -level 1
                }
                return {*}$o $e
            }
            "provide" {
                lassign $args pkg version
                dict lappend Known $pkg $version
                tailcall $Cmd $cmd {*}$args
            }
            default {
                tailcall $Cmd $cmd {*}$args
            }
        }
    }
}

if 1 {
    proc test {args} {
        # get the packages already known:
        catch {package require { none such }}
        set before [package names]

        # redirect [package]:
        set pm [PkgMapper new :package]
        rename package :package
        interp alias {} package {} $pm package

        # add to the path
        lappend ::auto_path {*}$args
        ::tcl::tm::path add {*}$args

        # get the new package names:
        catch {package require { none too }}
        set after [package names]

        # take the difference:
        set names [lmap a $after {
            if {$a in $before} continue
            set a
        }]
        puts [llength $before]-[llength $after]
        puts $names
        foreach pkg $names {
            if {$name in {console}} {
                puts "Skipping blacklisted: $name"
                continue
            }
            try {
                package require $pkg
            } on error {e o} {
                puts "! $e"
            }
        }
        $pm info
    }


    test {*}$argv
}

if 0 {
    set pm [PkgMapper new :package]
    rename package :package
    interp alias {} package {} $pm package

    puts [package names]
    catch {package require { none such }}
    #catch {package require gpx}
    set names [package names]
    puts "+ $names"
    $pm info
    puts " ---- "
    puts -nonewline [llength $names]:
    foreach pkg [lrange $names 0 50] {
        catch {
            package require $pkg
            puts -nonewline .
            flush stdout
        }
    }
    puts ""

    $pm info
}

# the point of this package is to have a two-level tablelist whose second-level items can be dragged around to anywhere on that second level
# the problem is in the last line of a level 1 entry:
#
#  ` foo
#    ` bar
#         <-- bad here
#  ` baz
#    ` qux
#         <-- ok here
#
# In the "bad" location, tablelist will only treat the drop as a root-level drop, which is not what we want.  So by binding the <<TablelistRowMoved>>
# event, we redirect the item.
#
# after idle after 0 ... seems to avoid Tcl_Panic("TkBTreeLinesTo couldn't find line"); .. and is a good idea anyway.
#
package require Tk
package require tablelist
namespace import tablelist::tablelist

proc acceptChildCmd {tbl targetParent sourceRow} {
#    try {
        set pdepth [$tbl depth $targetParent]
        expr { $pdepth <= 1 }
#    } on ok {r} {
#        puts "Child: $tbl $sourceRow -> $targetParent ($pdepth) (result: $r)"
#        return $r
#    }
}
proc acceptDropCmd {tbl targetRow sourceRow} {
#    try {
        set rowCount [$tbl size]
        if {$targetRow == 0} {
            expr 0  ;# never accept a drop at the top
        } elseif {$targetRow >= $rowCount} {
            expr 1  ;# always accept a drop at the end
        } else {
            set depth [$tbl depth $targetRow]
        }
#    } on ok {r} {
#        puts "Drop: $tbl $sourceRow -> $targetRow [if {[info exists depth]} {string cat ($depth)}] (result: $r)"
#        return $r
#    }
}

proc <<TablelistRowMoved>> {data} {
    lassign $data sourceIndex targetParent targetIndex
    if {$targetParent eq "root" && $targetIndex > 0} {
        set siblingKeys [.t childkeys "root"]
        set parent [lindex $siblingKeys $targetIndex-1]
        # special case for dragging to the end:
        if {$parent eq $sourceIndex} {
            set parent [lindex $siblingKeys $targetIndex-2]
        }
        # re-move the row:
        #puts "TablelistRowMoved:  .t move $sourceIndex $parent end"
        after idle [list after 0 [list .t move $sourceIndex $parent end]]
    }
}

grid [tablelist .t \
            -treestyle plastik \
            -columns {0 table 0 filename} \
            -movablerows 1 \
            -selectmode single \
            -acceptdropcommand acceptDropCmd \
            -acceptchildcommand acceptChildCmd \
            -stretch all \
            ;#
] -sticky nsew
grid rowconfigure    . 0 -weight 1
grid columnconfigure . 0 -weight 1
bind .t <<TablelistRowMoved>> {<<TablelistRowMoved>> %d}

set r1 [.t insertchild root end {"Foo" ""}]
.t insertchild $r1 end {"" "foo_1.csv"}
.t insertchild $r1 end {"" "foo_2.csv"}
set r [.t insertchild $r1 end {}]
#.t rowconfigure $r -hide 1
set r2 [.t insertchild root end {"Bar" ""}]
.t insertchild $r2 end {"" "bar_1.csv"}
.t insertchild $r2 end {}
#puts "r1 = $r1; r2 = $r2"

#
# |   Table Name: | [ foo     ]   | [x] - inspect    |
# |        `file: | bar_1.csv     |  [x] - headings  |
# |        `file: | bar_2.csv     |  [x] - headings  |
# |   Table Name: | [ foo     ]   | [x] - inspect    |
# |        `file: | bar_1.csv     |  [x] - headings  |

# DEMO:  differences between Tk and Ttk widgets
#
# == -variable options ==
#
#  Tk widgets will create the var if it doesn't exist;  ttk won't.
#
# == radiobutton default -value ==
#
#  Tk's default is "";  ttk's is "1"
#
# == tri-state ==
#
#  Tk's radio/check have configurable -tristatevalue (default "") and -tristateimage;
#  ttk tristate on the variable being unset and indicate it with "selected" or "alternate" in [$w state]
#
#
# == notebook style ==
#
#  Tk radio/check are easier for notebook-like behaviour using simple options:
#    -indicatoron false  -relief -offrelief -image -selectimage -tristateimage
#
#  ttk's require ttk::style hackery to do the same.
#
package require Tk
package require Ttk
namespace eval foo {    ;# just to prove we don't have clever var resolution
    variable {}
    pack [checkbutton .c -variable (c) -text checkbutton]
    pack [ttk::checkbutton .tc -variable (tc) -text ttk::checkbutton]
    pack [radiobutton .r -variable (r) -text radiobutton]
    pack [ttk::radiobutton .tr -variable (tr) -text ttk::radiobutton]
    pack [entry .e -textvariable (e)]
    pack [ttk::entry .te -textvariable (te)]
}
puts "\n== exists check =="
foreach name {(c) (tc) (r) (tr) (e) (te)} {
    if {![info exists $name]} {
        puts "::$name\t--"
    } else {
        puts "::$name\t\"[set $name]\""
    }
}
puts "\n== values =="
foreach w {.c .tc .r .tr} {
    foreach o {-value -tristatevalue} {
        catch {puts $w:\t[$w configure $o]}
    }
}
puts "\n== ttk::state =="
foreach w {.tc .tr} {
    puts [list $w state]:\t[$w state]
}
puts "\n== trace =="
trace add variable {} write {apply {{_ name op} {
    puts "TRACE: $name = $::($name)"
    if {[string match t* $name]} {
        puts [list .$name state]:\t[.$name state]
    }
}}}

if 0 {

    This is a simple visual demo for most of the Ttk widgets.

    Use the "theme" treeview to select themes, and see what different ones look like.

    Widgets *not* (yet) included are:

        ::ttk::frame
        ::ttk::notebook
        ::ttk::panedwindow
        ::ttk::scrollbar
        ::ttk::sizegrip

    Missing features include:

      * progress bar animation
      * menus for the menu buttons
      * showing off more of treeview
      * compound buttons and other stuff with images
      * included images and dialogs
      * colour-scheme selection

    Included widgets are:

        ::ttk::button
        ::ttk::checkbutton
        ::ttk::combobox
        ::ttk::entry
        ::ttk::label
        ::ttk::labelframe
        ::ttk::menubutton
        ::ttk::progressbar
        ::ttk::radiobutton
        ::ttk::scale
        ::ttk::separator
        ::ttk::spinbox
        ::ttk::treeview
}

package require Tk
package require Ttk

grid [
    ttk::labelframe .lf -text "Label relief" -padding 4
] - [
    ttk::labelframe .tvf -text "Treeview" -padding 4
] -padx 6 -pady 6 -sticky nsew

    set rs {flat groove raised ridge solid sunken}
    set i 0
    grid {*}[lmap r $rs {
        ttk::label .lf.l[incr i] -text [string totitle $r] -relief $r
    }] -padx 4 -pady 4 -sticky nsew

grid [
    ttk::labelframe .bf -text "Buttons" -padding 4
] - ^ -padx 6 -pady 6 -sticky nsew

    grid [
        ttk::button .bf.b1 -text "Normal Button"
    ] [
        ttk::button .bf.b2 -text "Disabled Button" -state disabled
    ] [
        ttk::button .bf.b3 -text "Undefaultable" -default disabled
    ] [
        ttk::button .bf.b4 -text "Default" -default active
    ] -sticky nsew

grid [
    ttk::labelframe .tbf -text "Toolbuttons" -padding 4
] - ^ -padx 6 -pady 6 -sticky nsew

    grid [
        ttk::button .tbf.bt1 -text "Tool 1" -style Toolbutton
    ] [
        ttk::button .tbf.bt2 -text "Disabled 2" -style Toolbutton -state disabled
    ] [
        ttk::button .tbf.bt3 -text "Undefaultable 3" -style Toolbutton -default disabled
    ] [
        ttk::button .tbf.bt4 -text "Default 4" -style Toolbutton -default active
    ] -sticky nsew

grid [
    ttk::labelframe .cf -text "Checkbuttons" -padding 4
] - [
    ttk::labelframe .kf -text "Keypress display" -padding 4
] -padx 6 -pady 6 -sticky nsew

    grid [
        ttk::checkbutton .cf.b1 -text "Normal Button"
    ] [
        ttk::checkbutton .cf.b2 -text "Disabled Button" -state disabled
    ] [
        ttk::checkbutton .cf.bt1 -text "Tool 1" -style Toolbutton
    ] [
        ttk::checkbutton .cf.bt2 -text "Tool 2" -style Toolbutton
    ] [
        ttk::checkbutton .cf.bt3 -text "Disabled 3" -style Toolbutton -state disabled
    ] -sticky nsew

    grid [
        ttk::label .kf.key -anchor center
    ] -sticky nsew

grid [
    ttk::labelframe .rf -text "Radiobuttons" -padding 4
] - ^ -padx 6 -pady 6 -sticky nsew

    grid [
        ttk::radiobutton .rf.b1 -value b1 -variable radio1 -text "Normal Button"
    ] [
        ttk::radiobutton .rf.b2 -value b2 -variable radio1 -text "Disabled Button" -state disabled
    ] [
        ttk::radiobutton .rf.bt1 -value bt1 -variable radio1 -text "Tool 1" -style Toolbutton
    ] [
        ttk::radiobutton .rf.bt2 -value bt2 -variable radio1 -text "Tool 2" -style Toolbutton
    ] [
        ttk::radiobutton .rf.bt3 -value bt3 -variable radio1 -text "Disabled 3" -style Toolbutton -state disabled
    ] -sticky nsew

grid [
    ttk::labelframe .ef -text "Entries" -padding 4
] - - -padx 6 -pady 6 -sticky nsew
    set e1 "Normal"
    set e2 "Disabled"
    set e3 "Readonly"
    grid [
        ttk::label .ef.l1 -text $e1
    ] [
        ttk::entry .ef.e1 -textvariable e1
    ] [
        ttk::label .ef.l2 -text $e2
    ] [
        ttk::entry .ef.e2 -textvariable e2 -state disabled
    ] [
        ttk::label .ef.l3 -text $e3
    ] [
        ttk::entry .ef.e3 -textvariable e3 -state readonly
    ] -sticky nsew -padx 4

    # justification
    set e4 "Left"
    set e5 "Right"
    set e6 "Center"
    grid [
        ttk::label .ef.l4 -text $e4
    ] [
        ttk::entry .ef.e4 -textvariable e4 -justify [string tolower $e4]
    ] [
        ttk::label .ef.l5 -text $e5
    ] [
        ttk::entry .ef.e5 -textvariable e5 -justify [string tolower $e5]
    ] [
        ttk::label .ef.l6 -text $e6
    ] [
        ttk::entry .ef.e6 -textvariable e6 -justify [string tolower $e6]
    ] -sticky nsew -padx 4

    
grid [
    ttk::labelframe .vf -text "Validated Entries (max length 8)" -padding 4
] [
    ttk::labelframe .cbf -text "Comboboxes" -padding 4
] - -padx 6 -pady 6 -sticky nsew

    set vcmd {expr {!(%d && ([string length %s]>7))}}
    set ivcmd {%W delete 0 end; %W insert end [string range %s 0 7]}
    set vmodes {none focus focusin focusout key all}

    set ev0 "Password"
    grid [
        ttk::label .vf.lp0 -text $ev0
    ] [
        ttk::entry .vf.p0 -textvariable ev0 -validate "all" -validatecommand $vcmd  -show *
    ] -sticky nsew

    grid [
        ::ttk::separator .vf.sep0 -orient horiz
    ] - -pady 6 -sticky nsew

    set spin 12.5
    grid [
        ttk::label .vf.ls0 -text "Spinbox"
    ] [
        ::ttk::spinbox .vf.s0 -from 0.0 -to 100.0 -increment 12.5 -textvariable spin -format %.1f
    ] -sticky nsew

    grid [
        ::ttk::separator .vf.sep1 -orient horiz
    ] - -pady 6 -sticky nsew

    set i 0
    foreach vmode $vmodes {
        set ev[incr i] $vmode
        grid [
            ttk::label .vf.l$i -text [set ev$i]
        ] [
            ttk::entry .vf.e$i -textvariable ev$i -validate $vmode -validatecommand $vcmd -invalidcommand $ivcmd
        ] -sticky nsew
    }


# comboboxes
    set values "One Two Buckle My Shoe"
    grid [
        ::ttk::label .cbf.l1 -text "Combobox"
    ] [
        ::ttk::combobox .cbf.c1 -values $values     -width 10
    ] [
        ::ttk::label .cbf.l2 -text "Readonly"
    ] [
        ::ttk::combobox .cbf.c2 -values $values -state readonly     -width 10
    ] [
        ::ttk::label .cbf.l3 -text "Disabled"
    ] [
        ::ttk::combobox .cbf.c3 -values $values -state disabled     -width 10
    ] -sticky nsew

grid ^ [
    ttk::labelframe .mf -text "Menubuttons" -padding 4
] [
    ttk::labelframe .pf -text "Scale and Progressbar" -padding 4
] -padx 6 -pady 6 -sticky nsew

    set menu {}
    set dirs {above below left right flush}
    set i 0
    foreach dir $dirs {
        set mb[incr i] $dir
        grid [
            ttk::label .mf.l$i -text [set mb$i]
        ] [
            ttk::menubutton .mf.e$i -text [set mb$i] -direction $dir -menu $menu
        ] -sticky nsew
    }

    set p0 10
    set p1 10
    set pv0 10
    set pv1 10
    grid [
        ::ttk::progressbar .pf.p0 -orient horiz -mode determinate -variable p0
    ] [
        ::ttk::separator .pf.sep -orient vert
    ] [
        ::ttk::progressbar .pf.pv0 -orient vert -mode determinate -variable pv0
    ] [
        ::ttk::scale .pf.sv0 -orient vert -from 0 -to 100 -variable pv0
    ] [
        ::ttk::progressbar .pf.pv1 -orient vert -mode indeterminate -variable pv1
    ] [
        ::ttk::scale .pf.sv1 -orient vert -from 0 -to 100 -variable pv1
    ] -sticky nsew -padx 6 -pady 6

    grid [
        ::ttk::scale .pf.s0 -orient horiz -from 0 -to 100 -variable p0
    ] ^ ^ ^ ^ ^ -sticky nsew -padx 6 -pady 6
    grid [
        ::ttk::progressbar .pf.p1 -orient horiz -mode indeterminate -variable p1
    ] ^ ^ ^ ^ ^ -sticky nsew -padx 6 -pady 6
    grid [
        ::ttk::scale .pf.s1 -orient horiz -from 0 -to 100 -variable p1
    ] ^ ^ ^ ^ ^ -sticky nsew -padx 6 -pady 6


grid [
    ::ttk::treeview .tvf.tv -columns {Theme} -show {headings}
] -sticky nsew -padx 4 -pady 4

set styles [::ttk::style theme names]
.tvf.tv configure -height [llength $styles]

foreach style $styles {
    .tvf.tv insert {} end -id $style -text $style -values [list "Use the \"$style\" theme"]
}

.tvf.tv heading Theme -text Theme
.tvf.tv selection set [list [::ttk::style theme use]]

bind .tvf.tv <<TreeviewSelect>> {
    ::ttk::style theme use [%W selection]
}

bind all  <Key> {
    .kf.key configure -text "You pressed %K\n(keycode %k)"
}
bind all  <Button> {
    .kf.key configure -text "Button %b"
}

package require Tk

package require tkImprover
#source tkImprover-0.tm

#bind . <Escape> {puts Escape:%M}
#bind . <Return> {puts Return:%M}

pack [button .b -text button -command {puts Button!}]
pack [checkbutton .c -text check -command {puts Check!}]
pack [radiobutton .r1 -text radio\ 1 -variable radio -value 1 -command {puts Radio:$::radio}]
pack [radiobutton .r2 -text radio\ 2 -variable radio -value 2 -command {puts Radio:$::radio}]
pack [entry .e]

pack [ttk::button .tb -text button -command {puts Button!}]
pack [ttk::checkbutton .tc -text check -command {puts Check!}]
pack [ttk::radiobutton .tr1 -text radio\ 1 -variable radio -value 1 -command {puts Radio:$::radio}]
pack [ttk::radiobutton .tr2 -text radio\ 2 -variable radio -value 2 -command {puts Radio:$::radio}]
pack [ttk::entry .te]

pack [text .t -undo 1]

.e insert end "the sun always"
.t insert end "
    byteOrder - is the most significant, or least significant, byte first
    machine - some info specific to the kind of hardware
    os - a string identifying the operating system
    osVersion - the version of the os
    pathSeparator — character used to split variables like env(PATH) into a proper Tcl list (from 8.6)
    platform - which of the major types of computers is this
    pointerSize - bytes taken up by a void pointer (from 8.5)
    user - user's login id
    wordSize - number of bytes for a machine-word (actually, a long)
"

puts "\n\n====\n\n"
foreach w {. .b .c .r1 .e .t .tb .tc .tr1 .te} {
    puts "bindtags $w: [bindtags $w]"
    puts "class $w: [set class [winfo class $w]]"
    #puts "bind $class <Return>: [bind $class <Return>]"
}

#
# This is an exercise in asynchronous sockets, by implementing some of 
# the "obsolete named protocols" from inetd.  It should serve as a decent
# illustration of async socket techniques using coroutines.
#
# Probably a good example for benchmarking too.
#
# See http://networksorcery.com/enp/protocol/ip/ports00000.htm for assignments and references.
#
# Currently represented:
#   1     tcpmux   rfc1078
#   7     echo     rfc862
#   9     discard  rfc863
#   11    systat   rfc866
#   13    daytime  rfc867
#   15    netstat  rfc866?
#   17    qotd     rfc865
#   19    chargen  rfc864
#   37    time     rfc868
#   43    whois    rfc3912
#   79    finger   rfc1288, 4146
#   113   ident    rfc1413
#   129   pwdgen   rfc972
#   1080  socks5   rfc1928 (outbound tcp only)
#   8080  proxy    rfc2616(ish)
#
# Potentially interesting to add:
#   telnet/23   (illustrate handling telnet \xff codes in a transchan)

#
#   sntp/123    rfc5905     $ date -r$((16#`printf "\xb%-47.s"|nc -uw1 ntp.metas.ch 123|xxd -s40 -l4 -p`-2208988800))
#       0b[string cat 00 001 011 ][ string repeat \x00 47]
#       binary scan $resp a40I _ epoch
#       incr epoch [clock scan {00:00 January 1, 1900 UTC}]     ;# -2208988800
#
#
# Interesting but non-trivial directions to extend, suggesting pluggable modules:
#
#   * add some UDP protocols using a suitable extension
#     * syslog
#     * schelte's upnp/ssdp could plug in nicely
#   * a chat protocol (irc? ntalk?) would be fun
#   * make qotd more efficient by caching, or by using fortune.dat
#   * telnet?  With a stubborn client that WONT?
#     * feeds into serial-over-tcp, which is useful
#   * how simple http can get away with? dustmote?

#


namespace eval inet {
    variable BASEPORT 0         ;# offset from declared port
    namespace eval sockets {}   ;# we will keep coroutines here

    # our coros need to accept multiple arguments (tcpmux - for chan copy)
    proc yieldm args {yieldto string cat {*}$args}

    # this is handy for cleanup
    proc finally {script} {
        tailcall trace add variable :#finally#: unset [list apply [list args $script]]
    }

    # coroutine-friendly IO proxies - like coroutine::util:
    proc gets {chan args} {
        if {![chan configure $chan -blocking]} {
            set was [chan event $chan readable]
            chan event $chan readable [list catch [info coroutine]]
            yield
            chan event $chan readable $was
        }
        tailcall ::gets $chan {*}$args
    }

    proc read {chan args} {
        if {![chan configure $chan -blocking]} {
            set was [chan event $chan readable]
            chan event $chan readable [list catch [info coroutine]]
            yield
            chan event $chan readable $was
        }
        tailcall ::read $chan {*}$args
    }

    proc after args {   ;# needs to wrap with [catch] in case the socket is killed while we're waiting
        if {[llength $args] == 1} {
            ::after {*}$args [list catch [info coroutine]]
            yield
        } else {
            ::after {*}$args
        }
    }

    # accept and dispatch a new connection
    proc accept {handler chan host port} {
        chan configure $chan -blocking 0 -buffering line -translation auto
        # :: (as in ipv6 addresses) is not permissible in command names, except as a namespace separator
        set coname [namespace tail $handler]:[string map {: _} $host]:$port
        coroutine sockets::$coname $handler $chan
    }

    # set up all listening ports
    proc listen {{baseport 0}} {
        variable BASEPORT
        set BASEPORT $baseport
        foreach cmd [info commands [namespace current]::*/*] {
            if {![regexp {/(\d+)$} $cmd -> port]} continue
            incr port $BASEPORT
            socket -server [namespace code [list accept $cmd]] $port
            puts $cmd
        }
    }

    # declare a service
    proc service {name body} {
        set body [format {
            puts "Start [info coroutine]"
            finally [list catch [list close $chan]]
            try {
                %s
            } on error {e o} {
                puts "Error in [info coroutine]: $e"


            }
            puts "End [info coroutine]"
        } $body]
        tailcall proc $name {chan} $body
    }

# HELP is a special method for tcpmux.  It doesn't listen on a port, so /*
    service HELP/* {
        foreach cmd [info commands [namespace current]::*/*] {

            puts $chan $line
        }
    }

    service discard/9 {
        while {![eof $chan]} {
            # discard result
            read $chan
        }
    }

# chargen, qotd send some data:
    service chargen/19 {
        set chargen { !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz} ;# " - vim syntax hack
        set max [string length $chargen]
        append chargen $chargen
        set i 0
        while {![eof $chan]} {
            while {[chan pending output $chan]} {
                after idle
            }
            puts $chan [string range $chargen $i $i+71]
            after idle      ;# make sure other clients get serviced!
            incr i
            if {$i >= $max} {incr i -$max}
        }
    }

    service qotd/17 {
        set fd [open /usr/share/games/fortunes/fortunes r]

                set opsys "UNIX"        ;# see "Assigned Numbers"
                set charset "US-ASCII"  ;# ugh, really?
                puts $chan "$remote, $local : USERID : $opsys, $charset : $userid"
            }
        }
        # FIXME: this can continue to accept requests, timing out after 60-180s idle
    }

    service pwdgen/129 { ;# rfc972
        package require base64
        for {set i 0} {$i < 6} {incr i} {
            set bits [lmap _ {1 2 3} {expr {entier((2**16)*rand())}}]
            set pw [base64::encode [binary format ttt {*}$bits]]
            puts $chan $pw
        }

        }
    }
    service netstat/15 {
        foreach cmd [info commands sockets::*] {
            puts $chan $cmd
        }
    }

# socks5 is pretty simple - outbound TCP only
    service socks5/1080 {
        chan configure $chan -encoding binary -bufferin none

        # authentication
        scan [read $chan 2] %c%c ver nmeth
        if {$ver != 5} return
        binary scan [read $chan $nmeth] c* meths
        if {0 in $meths} {          ;# no authentication! yay
            # do nothing?
        } elseif {2 in $meths} {    ;# user/passwd
            scan [read $chan 2] %c%c ver len
            if {$ver != 1} return
            set username [read $chan $len]
            scan [read $chan 1] %c len
            set password [read $chan $len]
            puts -nonewline $chan \1\0  ;# success!
        } else {                    ;# no supported auth methods
            puts -nonewline $chan \x05\xff
            return
        }

        # request
        scan [read $chan 4] %c%c%c%c ver cmd z atyp
        if {$ver != 5 || $z != 0} return

        if {$atyp == 1} {
            scan [read $chan 4] %c%c%c%c a b c d
            set dst $a.$b.$c.$d
        } elseif {$atyp == 3} {
            scan [read $chan 1] %c alen
            set dst [read chan $alen]
        } elseif {$atyp == 4} {
            binary scan [read $chan 16] c* dst
            set dst [join $dst :]
        }

        binary scan [read $chan 2] Su dpt

        if {$cmd == 3} {        ;# UDP
            puts -nonewline $chan \5\7\0\3\0\0\0    ;# cmd not supported ":0"
            return
        } elseif {$cmd == 2} {  ;# bind
            puts -nonewline $chan \5\7\0\3\0\0\0    ;# cmd not supported ":0"
            return
        } elseif {$cmd == 1} {  ;# connect

            set upchan [socket -async $dst $dpt]
            finally [list catch [list close $upchan]]

            yieldto chan event $upchan writable [info coroutine]
            chan event $upchan writable ""

            set err [chan configure $upchan -error]
            if {$err ne ""} {
                # 1 generic 2 notallowed
                # 3 netunreach 4 hostunreach
                # 5 connrefused 6 ttlexpired
                puts -nonewline $chan \5\5\0\1\0\0\0    ;# connection refused
                return
            }

            lassign [chan configure $upchan -peername] myaddr _ myport

            if {[scan $myaddr %d.%d.%d.%d a b c d] == 4} {
                set myaddr [format %c%c%c%c 3 $a $b $c $d]  ;# ipv4
            } else {
                # pack an IPv6 address
                lassign [split $myaddr ::] a b
                set myaddr [lrepeat 16 0]
                set i -1
                foreach octet $a {
                    lset $myaddr [incr i] $octet
                }
                set i 16
                foreach octet [lreverse $b] {
                    lset $myaddr [incr i -1] $octet
                }
                set myaddr [binary format cc* 4 $myaddr]    ;# ipv6
            }
            set myport [binary format Su $myport]
            puts -nonewline $chan \5\0\0$myaddr$myport      ;# OK

            chan configure $upchan -translation binary

            chan copy $chan $upchan -command [info coroutine]
            chan copy $upchan $chan -command [info coroutine]
            lassign [yieldm] nbytes err     ;# twice to catch both events
            lassign [yieldm] nbytes err
        }
    }

# a web proxy is a very nice thing to have, and not really much more complex:
    service proxy/8080 {

        chan configure $chan -translation crlf  -encoding iso8859-1

        # read first line
        gets $chan request

        # read until \n\n
        set preamble ""
        while {[gets $chan line] > 0} {
            append preamble $line\n
        }
        # note $preamble doesn't include the extra \n

        # parse request line
        if {![regexp {^([A-Z]+) (.*) (HTTP/.*)$} $request -> verb dest httpver]} {
            throw {PROXY BAD_REQUEST} "Bad request: $request"
        }

        if {[regexp {^(\w+)://\[([^\]/ ]+)\](?::(\d+))?(.*)$} $dest -> scheme host port path]} {
            # IPv6 URL
        } elseif {[regexp {^(\w+)://([^:/ ]+)(?::(\d+))?(.*)$} $dest -> scheme host port path]} {
            # normal URL
        } elseif {[regexp {^([^:/ ]+)(?::(\d+))?$} $dest -> host port]} {
            # CONNECT-style host:port
        } elseif {[regexp {^\[([^\]/ ]+)\](?::(\d+))?$} $dest -> host port]} {
            # CONNECT-style host:port IPv6
        } else {
            throw {PROXY BAD_URL} "Bad URL: $dest"
        }

        if {$port eq ""} {set port 80}

        # open outgoing conn
        set upchan [socket -async $host $port]  ;# -async ensures we don't block other clients.
                                                ;# But beware:  DNS lookup blocks!

        chan configure $upchan -blocking 0 -translation crlf -buffering none   -encoding iso8859-1

        # wait till we're connected:
        yieldto chan event $upchan writable [info coroutine]
        chan event $upchan writable ""

        # .. or did connection fail?
        set err [chan configure $upchan -error]
        if {$err ne ""} {
            # FIXME: smarter responses
            puts $chan "$httpver 502 Bad Gateway"
            puts $chan "Content-type: text/plain"
            puts $chan ""
            puts $chan "Error connecting to $host port $port:"
            puts $chan "  $err"
            return
        }
        finally [list close $upchan]

        if {$verb eq "CONNECT"} {
            # for CONNECT, we need to synthesise a response:
            puts $chan "$httpver 200 OK"
            puts $chan ""
        } else {
            # else, forward the request headers:
            puts $upchan $request
            puts $upchan $preamble  ;# extra newline is wanted here!
        }

        # revert to binary mode, and hand over to [chan copy]:
        chan configure $chan   -buffering none -translation binary -encoding binary
        chan configure $upchan -buffering none -translation binary -encoding binary
        chan copy $chan $upchan -command [info coroutine]
        chan copy $upchan $chan -command [info coroutine]
        lassign [yieldm] nbytes err     ;# twice to catch both events
        lassign [yieldm] nbytes err

        # and we're done!  Cleanup is automatic.
    }

}

::inet::listen 10000
vwait forever

oometa-1.tm     -- TclOO extension done right!  (a literate program)
    please steal and use this.  It needs examples.

totp-0.tm       -- simple totp/hotp implementation

tdbcplus-0.1.tm -- monkey patches for TDBC.  Illustrates [mixin] well.

sql-0.tm        -- helpers for safely composing SQL queries

snidgets/       -- various (mega-)widgets using the wonderful snit

# Usage:
#   try {package require debug} on error {} {proc debug args {}}
#
package require fun     ;# ?
package require extend  ;# dict get?

# this is intended to help with transcripts, but it ain't there yet
proc % args {
    #puts L:[info level [info level]]
    #puts F:[info frame -1]
    puts [dict get [info frame -1] cmd]
    #puts "% [debug level -1]"
    set rc [catch {uplevel 1 $args} e o]
    if {$rc} {
        ei
    } elseif {$e ne ""} {
        puts $e
    }
    return {*}$o $e
}

namespace eval debug {
    # gather context information for display:
    proc what {} {
        lograw [string repeat " " [info level]][uplevel 1 namespace current]::[info level -1]
    }
    proc level {{l -1}} { ;# this doesn't seem to work in the repl, and I'm not sure why
        incr l [info level]
        for {set f 1} {1} {incr f} {
            set fr [info frame $f]
            if {[dict exists $fr level] && [dict get $fr level]==$l} {
                return [dict get $fr cmd]
            }
        }
    }

    proc watch {varName} {
        set varName [uplevel 1 [list namespace which -variable $varName]]
        debug log {WATCH- tracing $varName}
        trace add variable $varName write [lambda {varName args} {
            debug log {WATCH: $varName = [set $varName]}
            debug log {WATCH  in [debug stack]}
        }]
    } 
    proc watcharray {varName} {
        set varName [uplevel 1 [list namespace which -variable $varName]]
        debug log {WATCH- tracing $varName}
        trace add variable $varName write [lambda {varName key args} {
            debug log {WATCH: ${varName}($key) = [set ${varName}($key)]}
            debug log {WATCH  in [debug stack]}
        }]
    }
    proc stack {} {
        set l [info level]
        set res {}
        while {[incr l -1] >= 0} {
            lappend res [info level $l]
        }
        set res
    }
    proc frames {} {
        set l [info frame]
        set res {}
        while {[incr l -1] >= 0} {
            lappend res [info frame $l]
        }
        set res
    }

    proc vars {{patterns *}} {
        set res {}
        foreach varName [concat {*}[map {uplevel 1 info vars} $patterns]] {
            if {![uplevel 1 [list info exists $varName]]} {
                # declared but uninitialised variables - ignore them
            } elseif {[uplevel 1 [list array exists $varName]]} {
                # ignore arrays
            } else {
                dict set res $varName [uplevel 1 [list set $varName]]
            }
        }
        set res
    }

    proc locals {{patterns *}} {
        foreach varName [concat {*}[map {uplevel 1 info locals} $patterns]] {
            if {[Uplevel 1 array exists $varName]} {
                Uplevel 1 parray $varName
            } else {
                Uplevel 1 debug show \$[list $varName]
            }
        }
    }

    proc getproc {name} {
        set argList [info args $name]
        set args [lmap arg [info args $name] {
            if {[info default $name $arg default]} {
                list $arg $default
            } else {
                set arg
            }
        }]
        set body [info body $name]
        return [list proc $name $args $body]
    }

    # just dumps info to stdout.  Here because introspection is fun.
    proc dumpns {{ns ::}} {
        # transitive closure:
        foreach ns [tclose {namespace children} ::] {
            foreach cmd [info commands ${ns}::*] {
                puts [list command $cmd]
            }
            foreach var [info vars ${ns}::*] {
                try {
                    if {[array exists $var]} {
                        puts [list array $var [array get $var]]
                    } else {
                        puts [list variable $var [set $var]]
                    }
                } on error {} {
                    puts [list UNREADABLE $var]
                }
            }
        }
    }

    proc ::noop args {}     ;# this goes in global space
    proc ::no-op args {}    ;# some call it no-op

    # like assert.h's NDEBUG: make everything a noop
    proc ndebug {} {
        interp alias {} ::debug {} ::noop
    }
    proc off {} {
        interp alias {} [uplevel 1 namespace current]::debug {} ::noop
    }

    proc show {args} {
        foreach s $args {
            try {
                puts "\[DEBUG\]: [list $s -> [uplevel 1 subst [list $s]]]"
            } on error e {
                puts "\[DEBUG-ERROR\]: $e evaluating [list $s]"
            }
        }
    }

    proc pdict {d} {
        dict for {k v} $d {
            if {[string length $v] > 100} {
                set v [string range $v 0 99]\u2026
            }
            debug log { $k -> $v}
        }
    }

    proc transcript {args} {
        foreach cmd [cmdsplit [concat {*}$args]] {
            debug log "% $cmd\n"
            try {
                set res [uplevel 1 $cmd]
                if {$res ne ""} {debug log "#  $res"}
            } on error {e o} {
                debug perror $e $o
            }
        }
    }

    # this should support logging to a different chan
    # facilities and level filtering ..
    # facility: namespace of caller?  first known namespace on call stack?
    proc lograw {args} {
        puts "\[DEBUG\]: $args"
    }

    proc ms {} {
        clock format [clock seconds] -format %M:%S
    }
    proc log {args} {
        try {
            puts "[ms]:\[DEBUG\]: [uplevel 1 subst [list $args]]"
        } on error e {
            puts "\[DEBUG-ERROR\]: $e evaluating [list $args]"
        }
        return
        try {
            puts "\[DEBUG\]: [uplevel 1 subst [list $s]]"
        } on error e {
            puts "\[DEBUG-ERROR\]: $e evaluating [list $s]"
        }
    }

    proc assert {x {msg ""}} {
        if {![uplevel 1 expr [list $x]]} {
            catch {
                set y [uplevel 1 [list subst -noc $x]]
                if {$y ne $x} {
                    set x "{$y} from {$x}"
                }
            }
            throw ASSERT "[concat "Assertion failed!" $msg] $x"
        }
    }

    proc demo args {
        log {% $args}
        set rc [catch {uplevel 1 $args} e o]
        if {$rc} {
            log {  --> ERROR($rc): $e [dict get $o -errorcode]}
        } else {
            log {  --> $e}
        }
        return {*}$o $e
    }
    proc where {{lvl 0}} {
        incr lvl -1
        set d [info frame $lvl]
        string cat "[dict get? $d type] [dict get? $d proc] at [dict get? $d file]:[dict get? $d line]"
    }
    proc do args {
        set where [debug where -1]
        log {DOING at $where: {$args}}
        set rc [catch {uplevel 1 $args} e o]
        log {RESULT : $rc {$e}}
        return {*}$o $e
    }
    proc eval {args} {
        log {TRACE => {$args}}
        set rc [catch {uplevel 1 $args} e o]
        log {TRACE <= $rc {$e}}
        return {*}$o $e
    }

    namespace eval tracer {
        namespace path [namespace parent [namespace current]]
        variable depth
        proc enter {command _} {
            variable depth
            log {TRACE [string repeat \  $depth]$command}
            incr depth
        }
        proc leave {command code result _} {
            variable depth
            incr depth -1
            log {TRACE [string repeat \  $depth]= ($code) {$result}}
        }
    }

    proc tracecmd {cmd} {
        set cmd [uplevel 1 [list namespace which $cmd]]
        trace add execution $cmd enter ::[namespace current]::tracer::enter
        trace add execution $cmd leave ::[namespace current]::tracer::leave
    }

    proc errorproc {tid error} {
        debug log {THREAD ERROR from $tid: $error}
    }

    proc bgerror {err opts} {
        debug log {BGERROR $err}
        debug pdict $opts
    }

    proc perror {err opts} {
        debug log {ERROR: $err}
        debug pdict $opts
    }

    namespace export {[a-z]*}
    namespace ensemble create
}

package require bitnary

namespace eval asciipacket {
    proc assert {expr} {    ;# for "static" assertions that throw nice errors
        if {![uplevel 1 [list expr $expr]]} {
            raise {ASSERT ERROR} "{$expr} {[subst -noc $expr]}"
        }
    }

        foreach _ $binargs {
            dict set result $_ [set $_]
        }
        return $result
    }
}
 
package require mainscript
if {[mainscript?]} {
proc test {} {
    set header {
        +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
        |                      ID                       |
        +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
        |QR|   Opcode  |AA|TC|RD|RA|   Z    |   RCODE   |
        +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+

    puts "encoded packet (hex): [asciipacket::b2h $pkt]"
    set decoded [asciipacket::decode $schema $pkt]
    dict for {k v} $values {
        debug assert {$v == [dict get $decoded $k]}
    }
}
test
}

            } [list $arg] [list [dict get $bitmap str]] [dict get $bitmap args]]]
        }
        tailcall ::try [join $script \n\t]
    }
}


package require mainscript
if {[mainscript?]} {
    proc h2b args { binary format H* [join $args ""] }
    proc b2h {data} { binary scan $data H* hex; set hex }
    proc frombinary args { binary format B* [join $args ""] }
    proc tobinary {s} { binary scan $s B* d; set d }

    proc string_chunk {n s} {
        if {$s eq ""} return

            return $data
        }
        proc flush {what x}              { }
        namespace export *
        namespace ensemble create -parameters what
    }

    oo::class create fifo {
        variable Block
        variable Watch
        variable Data
        variable Size
        constructor {{size 1}} {
            set Block 1
            set Watch {}
            set Size $size
            set Data {}
        }
        method Postevent {chan event} {
            if {$event in $Watch} {
                # FIXME: after idle? (see http://core.tcl.tk/tcl/tktview?name=67a5eabbd3)
                chan postevent $chan $event
            }
        }
        method data {} {
            return $Data
        }
        method initialize {chan mode} {
            return {initialize finalize blocking watch read write}
        }
        method finalize {chan} {
            my destroy
        }
        method blocking {chan mode} {
            set Block $mode
        }
        method watch {chan events} {
            set Watch $events
        }
        method read {chan bytes} {
            if {$Data eq ""} {
                #puts REAGAIN
                error EAGAIN
            }
            set data [lpop Data]
            #puts "READ: $data"
            if {[llength $Data] < $Size} {
                my Postevent $chan "write"
            }
            if {$Data ne ""} {
                my Postevent $chan "read"
            }
            return $data
        }
        method write {chan data} {
            if {[llength $Data] >= $Size} {
                #puts WEAGAIN
                error EAGAIN
            }
            #puts "WRITE: $data"
            lappend Data $data
            my Postevent $chan "read"
            if {[llength $Data] < $Size} {
                my Postevent $chan "write"
            }
            string length $data
        }
    }

    proc eachobj {_obj chan script} {
        upvar 1 $_obj obj
        while {1} {
            if {[coroutine::util gets $chan line] < 1} {
                if {[eof $chan]} break else continue
            }

            }
            return $blob
        }
    }


}

if 0 {
    chans::fifo create fi 2
    set fd [chan create {read write} fi]
    chan configure $fd -buffering line -blocking 0
    foreach i {0 1 2} {
        puts $fd lalala$i
        puts put$i:[fi data]
        flush $fd
    }
    foreach i {0 1 2 3} {
        puts line$i:[gets $fd line]:$line
        puts get$i:[fi data]
    }
}

# from http://wiki.tcl.tk/20619 revision 10 2015-12-01
if 0 {
    [NEM] 2008-01-11: Here is a little (ish) package that wraps up [toplevel], [wm], [winfo]
    and [MacWindowStyle] into a single mega-widget using [snit]. The window is actually somewhat
    more than just a toplevel, as it incorporates a toolbar ([ttk::frame]), menubar and a status/
    progressbar, as these are frequently needed items (at least for the apps I like to develop).
    I'm trying to put as much platform-specific knowledge into the implementation of this as
    possible, while keeping the interface platform-independent. Options that only make sense on
    a certain platform are ignored on others, etc.

        easywin .ew -option value -option value ...

    OPTIONS:

    A rather large number of options are supported, and probably more will be added.

        -title:         Set the title of the window (i.e. [wm title]).
        -toolbar:       Boolean, indicates whether to display the toolbar or not.
        -statusbar:     Whether to display the statusbar (and progressbar).
        -document:      Use this to set the full path name of the file currently being viewed in the window (if it is being used in that way).
                        On Mac this will set the -titlepath so that an appropriate proxy icon is displayed (very cool bit of polish).
        -modified:      Indicates whether the contents of the window have been modified since last save.

    Lots of other options which related to various [wm attributes] options for different platforms (and are no-ops on other platforms).

        -windowclass:   Sets the window class on TkAqua (see [MacWindowStyle])
        -attributes:    Sets the window attributes on TkAqua (see [MacWindowStyle])
        -savecommand:   Sets a command to invoke to save the current window contents (see below).

    METHODS:

        $win status ?msg?:          Get or set the current status message displayed in the statusbar.
        $win progress total done:   Set the current progress value. 
            This will display a progress bar in the statusbar if one is not already visible.
            If total==done then the progressbar is hidden again.
        $win hide ?component?/show ?component?/hidden ?component/toggle ?component?:   Hide or show a particular component of the window or check the status of a component.
            Valid component names are:
                self (ie, the entire window) (default)
                statusbar
                toolbar
        $win toolbar:               Returns the tk command of the toolbar frame widget, so you can add items to it.

    In addition, direct access to the underlying widgets is provided through the commands

        $win statusbar ...:   
        $win progressbar ...:   
        $win menu ...:   

    So for example you can do
        $win menu add cascade ...

    Various other methods exist: essentially the whole of [wm] and [winfo] exist as methods on the window.

    PROMPT TO SAVE FILE:

    If you supply a ''-savecommand'' option then the widget will check the ''-modified'' flag when
    a user attempts to close the window. If the contents have been modified then a dialog will be
    displayed asking if the user wants to save first. If they click yes, then the -savecommand is
    invoked passing the window name as an argument.
}
# easywin.tcl --
#
#       A wrapper around Tk's built-in toplevel command, providing support for
#       toolbars etc.
#
# Author: 2008 Neil Madden (nem@cs.nott.ac.uk).
# Public Domain.

package require Tcl         8.5
package require Tk          8.5
package require snit        2.2

snit::widgetadaptor easywin {
    option -title       -default "" -configuremethod ChangeTitle
    option -toolbar     -default 0  -configuremethod ChangeComponent
    option -statusbar   -default 0  -configuremethod ChangeComponent
    option -document    -default "" -configuremethod ChangeDocument \
                                    -cgetmethod      GetDocument
    option -modified    -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -alpha       -default 1  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -toolwindow  -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -topmost     -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -disabled    -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -fullscreen  -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -transparentcolor -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -notify      -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -transparent -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -zoomed      -default 0  -configuremethod ChangeAttribute \
                                    -cgetmethod      GetAttribute
    option -aspect      -default "" -configuremethod ChangeAspect
    option -client      -default [info hostname] \
                        -configuremethod ChangeClient
    # Tk Aqua window class and attributes (no-ops on other platforms)
    option -windowclass -default "document" -readonly 1
    option -attributes  -default {toolbarButton standardDocument} \
                        -readonly 1
    option -transient   -default ""  -configuremethod ChangeTransient
    option -savecommand -default ""
    delegate option -orient to mainframe

    component statusbar -public statusbar
    component progress  -public progressbar
    component menu      -public menu

    component mainframe
    component toolbar

    delegate option * to hull
    delegate method * to mainframe

    variable hidden [dict create]

    typevariable wmoptions
    typeconstructor {
        lappend ::snit::hulltypes window glib::window
        set wmoptions(aqua)     {-fullscreen -topmost -modified -titlepath
                                 -alpha -notify}
        set wmoptions(win32)    {-fullscreen -alpha -toolwindow -topmost
                                 -transparentcolor -disabled}
        set wmoptions(x11)      {-fullscreen -topmost -zoomed}
    }

    constructor args {

        # Extract options that must be supplied at creation time.
        set class ArtclWindow
        set orient vertical
        foreach op {class orient} {
            if {[set idx [lsearch -exact $args -$op]] >= 0} {
                set $op [lindex $args [expr {$idx+1}]]
                set args [lreplace $args $idx [incr idx]]
            }
        }

        if {[tk windowingsystem] eq "aqua"} {
            set tstyle Toolbar
        } else {
            set tstyle TFrame
        }

        # Construct components
        installhull         using toplevel -class $class
        wm withdraw $win
        install menu        using menu $win.mb
        install toolbar     using ttk::frame $win.tb -style $tstyle
        install mainframe   using ttk::panedwindow $win.main \
                                -orient $orient
        install statusbar   using ttk::label $win.status \
                                -font TkSmallCaptionFont \
                                -padding 2
        install progress    using ttk::progressbar $win.progress \
                                -orient horizontal -mode determinate

        $self configure -menu $menu
        wm protocol $win WM_DELETE_WINDOW [mymethod close]
        bind $win <<ToolbarButton>> [mymethod toggle toolbar]

        # Layout
        grid $toolbar       -sticky ew      -columnspan 2
        grid [ttk::separator $win.tsep -orient vertical] \
                            -sticky ew      -columnspan 2
        grid $mainframe     -sticky nsew    -columnspan 2
        grid [ttk::separator $win.bsep -orient vertical] \
                            -sticky ew      -columnspan 2
        grid $statusbar $progress -sticky ew

        # Add some space to avoid the window resize grip on Aqua
        grid configure $progress -padx {0 20}
        grid remove $progress

        grid columnconfigure $win 0 -weight 1
        grid rowconfigure    $win 2 -weight 1

        $self configurelist $args

        # Apply the window style on Mac OS X before the window gets mapped.
        if {[tk windowingsystem] eq "aqua"} {
            ::tk::unsupported::MacWindowStyle style $win \
                [$self cget -windowclass] [$self cget -attributes]
        }
        wm deiconify $win
    }

    # usage msg --
    #
    #       Convenience proc for creating wrong # args errors.
    #
    proc usage msg {
        return -code error -level 2 -errorcode [list WRONGARGS $msg] \
            "wrong # args: should be \"$msg\""
    }


    # status ?message? --
    #
    #       Get or set the status message for the window.
    #
    method status args {
        switch -exact [llength $args] {
            0       { $statusbar cget -text }
            1       { $statusbar configure -text [lindex $args 0] }
            default {
                usage "$self status ?message?"
            }
        }
    }

    # progress total done --
    #
    #       Set the progress value for the window. This causes the progress
    #       bar to be displayed in the status bar area (if the statusbar
    #       itself is visible). If total == done then the progress bar is
    #       removed.
    #
    method progress {total done} {
        if {$total == $done} {
            grid remove $progress
        } else {
            if {![$self hidden statusbar] &&
                $progress ni [grid slaves $win]} { grid $progress }
            $progress configure -maximum $total -value $done
        }
    }

    method toolbar {} { return $toolbar }

    # hide ?component? --
    #
    #       Hides the specified component (defaults to "self"). Valid
    #       component names are "statusbar", "toolbar" or "self" (which hides
    #       the entire window).
    #
    method hide {{component "self"}} {
        if {$component eq "self"} {
            wm withdraw $win
        } else {
            grid remove [set $component]
        }
        dict set hidden $component 1
    }

    # show ?component? --
    #
    #       Shows the specified component (defaults to "self"). Valid
    #       component names are "statusbar", "toolbar" or "self" (which
    #       deiconifies the entire window).
    #
    method show {{component "self"}} {
        if {$component eq "self"} {
            wm deiconify $self
        } else {
            grid [set $component]
        }
        dict set hidden $component 0
    }

    # hidden ?component? --
    #
    #       Returns 1 if the given component is hidden, or 0 otherwise.
    #
    method hidden {{component "self"}} {
        if {[dict exists $hidden $component]} {
            return [dict get $hidden $component]
        } else {
            return 0
        }
    }

    # toggle ?component? --
    #
    #       Toggles the hidden/shown status of a component.
    #
    method toggle {{component "self"}} {
        if {[$self hidden $component]} {
            $self show $component
        } else {
            $self hide $component
        }
    }

    # wm geometry ?newGeom? --
    #
    #       Wrapper around the [wm geometry] command.
    #
    method geometry args {
        wm geometry $win {*}$args
    }

    # close --
    #
    #       Attempt to close the window. This method will first check to see
    #       whether the contents of the window have been modified, and if so,
    #       offer the user the chance to save the contents before closing. The
    #       behaviour of this method is controlled by the -modified option and
    #       the -savecommand option. The dialog will only be displayed if
    #       -modified and a -savecommand has been specified. The save command
    #       will be invoked passing in the object command of this window. If
    #       the -savecommand returns 1 then closing of the window will be
    #       aborted.
    #
    method close {} {
        set command [$self cget -savecommand]
        if {[$self cget -modified] && $command ne ""} {
            set ans [tk_messageBox -icon warning -parent $win \
                -title "Contents Modified" \
                -message [concat \
                    "The contents of this window have been modified."\
                    "Do you want to save the changes before"\
                    "closing?"] \
                -type yesnocancel -default cancel]
            if {$ans eq "cancel"} { return 0 }
            if {$ans eq "yes"} {
                if {[uplevel #0 $command $self] == 1} {
                    # Save command aborted close
                    return 0
                }
            }
        }
        destroy $win
        return 1
    }

    # Various [wm] commands that I don't know how best to handle yet :-)
    foreach op {forget frame grid group iconbitmask iconify iconmask iconname
        iconphoto iconwindow manage maxsize minsize overrideredirect
        positionfrom protocol resizable sizefrom stackorder state} {

        method $op args [format { wm %s $win {*}$args } $op]
    }

    # And the same for [winfo] commands
    foreach op {atom atomname cells children class colormapfull containing
        depth exists fpixels height id interps ismapped manager name parent
        pathname pixels pointerx pointerxy pointery reqheight reqwidth rgb
        rootx rooty screen screencells screendepth screenheight screenmmheight
        screenmmwidth screenvisual screenwidth server toplevel viewable visual
        visualid visualsavailable vrootheight vrootwidth vrootx vrooty width x
        y} {

        method $op args [format { winfo %s $win {*}$args } $op]
    }

    #
    #======================================================================
    #
    # PRIVATE METHODS
    #
    #======================================================================
    #

    # Change the title of the window (implements -title option)
    method ChangeTitle {option value} {
        set options($option) $value
        wm title $win $value
    }

    # Change whether a particular component is displayed (-statusbar and
    # -toolbar options).
    method ChangeComponent {option value} {
        set options($option) $value
        set component [string range $option 1 end]
        if {$value} {
            $self show $component
        } else {
            $self hide $component
        }
    }

    # Change a window attribute (implements most of the platform-specific
    # options). Attributes that make no sense on a particular platform are
    # simply ignored.
    method ChangeAttribute {option value} {
        set options($option) $value

        if {$option in $wmoptions([tk windowingsystem])} {
            wm attributes $win $option $value
        }
    }

    # Return the current value of an option. This implements the cget method
    # for various [wm attribute] options as these can be changed from outside
    # the application itself (e.g. moving the file of a -document option in
    # the finder will change the -document value).
    method GetAttribute {option} {
        if {$option in $wmoptions([tk windowingsystem])} {
            return [wm attribute $win $option]
        }
        return $options($option)
    }

    # Maps the -document option to the rather more obscure -titlepath on
    # TkAqua.
    method ChangeDocument {option value} {
        set options($option) $value
        $self ChangeAttribute -titlepath $value
    }
    method GetDocument {option} {
        $self GetAttribute -titlepath
    }

    # Implements changes to -windowclass and -attributes options. Not sure if
    # you can actually change these after window creation, but might still be
    # useful in some cases.
    method ChangeWindow {option value} {
        if {[tk windowingsystem] eq "aqua"} {
            set class [$self cget -windowclass]
            set attrs [$self cget -attributes]
            ::tk::unsupported::MacWindowStyle style $win $class $attrs
        }
        set options($option) $value
    }

    # Implements -transient option
    method ChangeTransient {option value} {
        wm transient $win $value
        set options($option) $value
    }

    # Implements -aspect option
    method ChangeAspect {option value} {
        wm aspect $win $value
        set options($option) $value
    }

    # Implements -client option
    method ChangeClient {option value} {
        wm client $win $value
        set options($option) $value
    }
}

#  Demo:
if {[info exists ::argv0] && $::argv0 eq [info script]} {
    # editor.tcl --
    #
    #       A simple text editor application to demonstrate the glib library.
    #
    # Public domain.
    #

    package require Tcl     8.5
    package require Tk      8.5

    wm withdraw .

    set edcount 0

    proc editor w {
        global edcount
        # Create the editor window
        set win [easywin $w -title "Text Editor" -savecommand file:save]

        # Create the text component
        set f [ttk::frame $win.f]
        set t [text $f.t -highlightthickness 0 -yscrollcommand [list $f.vsb set]]
        set v [ttk::scrollbar $f.vsb -orient vertical -command [list $f.t yview]]

        bind $t <<Modified>> [list modified %W]

        # Grid them
        grid $t $v -sticky nsew
        grid rowconfigure $f 0 -weight 1
        grid columnconfigure $f 0 -weight 1

        $win add $f -weight 1

        # Create menu and toolbar entries
        set file [menu $win.file -tearoff 0]
        $win menu add cascade -label File -underline 0 -menu $file

        action $win open "Open..." O 0 [list file:open $win]
        $file add separator
        action $win close "Close" W 0 [list file:close $win]
        action $win save "Save" S 0 [list file:save $win]
        action $win saveas "Save As..." A 5 [list file:saveas $win]
        $file add separator
        action $win quit "Exit" Q 1 [list file:quit $win]

        $win status "Done"

        incr edcount
    }

    proc modifier key {
        switch -exact [tk windowingsystem] {
            aqua    { return "Command-$key" }
            win32   { return "Ctrl+$key"    }
            default { return "Ctrl-$key"    }
        }
    }
    proc binding key {
        set key [string tolower $key]
        switch -exact [tk windowingsystem] {
            aqua    { return "<Command-$key>" }
            default { return "<Control-$key>" }
        }
    }
    proc action {win name label accel uline cmd} {
        global col
        $win.file add command -label $label \
            -accelerator [modifier $accel] \
            -underline $uline \
            -command $cmd
        set tb [$win toolbar]
        ttk::button $tb.$name -text $label -command $cmd \
            -style Toolbutton
        grid $tb.$name -row 0 -column [incr col]
        bind $win [binding $accel] $cmd
    }

    # Handle changes to the text widget modified status
    proc modified w {
        set win [winfo toplevel $w]
        set text $win.f.t
        set mod [$text edit modified]
        $win configure -modified $mod
        set state [expr {$mod ? "normal" : "disabled"}]
        $win.file entryconfigure Save -state $state
        [$win toolbar].save configure -state $state
    }


    proc file:open win {
        set file [tk_getOpenFile -parent $win]
        if {$file eq ""} { return }
        set in [open $file]
        $win.f.t delete 1.0 end
        $win.f.t insert end [read $in]
        close $in
        $win.f.t see 1.0
        $win configure -document [file normalize $file] -title [file tail $file]
        $win.f.t edit modified 0
        modified $win
        $win status "Done"
    }

    proc file:save win {
        set file [$win cget -document]
        file:saveas $win $file
    }

    proc file:saveas win {
        if {$file eq ""} {
            set file [tk_getSaveFile -parent $win]
        }
        if {$file eq ""} { return 1 }
        set out [open $file w]
        puts $out [$win.f.t get 1.0 end-1c]
        close $out
        $win configure -document [file normalize $file]
        $win.f.t edit modified 0
        modified $win
        $win status "Opened $file"
    }

    proc file:close win { $win close }

    proc file:quit win {
        global edcount
        if {[$win close]} { incr edcount -1 }
        if {$edcount <= 0} { exit }
    }
    editor .ed
}

# taking some of the best wisdom from http://wiki.tcl.tk/9299 and putting it in an object
# why an object?  Mostly for convenient variables.  Independent instances that can clean
# up after themselves is possibly compelling too.
#
# Needs tests.
#
# Supports:
#  - cancel from within script with [break].  [continue] is harmless.
#  - [continue 100] - re-sets interval for 100ms
#  - cancel by id(s)
#  - kill (cancel all) - aka [cancel all] or [cancel *]
#  - pause/resume by id(s).  The clock keeps ticking, but events are skipped until resumed.
#  - info returns a dict

namespace eval every {

    # too nice to omit:
    proc callback args {
        tailcall namespace code $args
    }

    ::oo::class create namedclass {
        superclass ::oo::class
        self method create {name args} {
            tailcall my createWithNamespace $name $name {*}$args
        }

        method create {name args} {
            tailcall my createWithNamespace $name $name {*}$args
        }
    }

    # suggest importing these if you can:
    interp alias {} [namespace current]::continue   {}  ::return -level 0 -code continue
    interp alias {} [namespace current]::break      {}  ::return -level 0 -code break

    # might as well have a nice cleanup version of this too:
    namedclass create After {
        variable Afters

        constructor {} {
            set Afters [dict create]
        }

        destructor {
            dict for {id aid} $Afters {
                after cancel $aid
            }
        }

        method idle {args} {
            if {[llength $args] < 1} {
                tailcall ::after {*}$args
            }
            set args [lassign $args cmd]
            if { ! ([string is entier -strict $cmd] || $cmd in {idle}) } {
                tailcall ::after $cmd {*}$args
            }
            variable AfterID
            incr AfterID
            dict set Afters $AfterID [::after idle [callback my Bang $AfterID {*}$args]]
        }

        method Bang {id args} {
            dict unset Afters $ID
            uplevel #0 {*}$args
        }
    }

    namedclass create Every {
        variable Cancel
        variable Paused
        variable Active
        variable Afters

        constructor {} {
            set Active [dict create]
            set Cancel [dict create]
            set Paused [dict create]
            set Afters [dict create]
        }

        destructor {
            dict for {id aid} $Afters {
                after cancel $id
            }
        }

        # after <ms>
        method unknown {ms script} {
            variable EveryID
            if {![string is entier -strict $ms]} {
                return -code error "Invalid argument \"$ms\" - expected [join [info class methods Every] ", "] or an integer"
            }
            if {[string trim $script] eq ""} {return}
            set id every#[incr evID]
            dict set Active $id $script
            # after idle?
            dict set Afters $id [after 0 [callback my Tick $id $ms $script]]
            return $id
        }

        # public methods:
        method cancel {args} {
            if {$args in {all *}} {
                tailcall my kill
            }
            foreach id $args {
                dict set Cancel $id {}
            }
        }
        method kill {} {
            dict for {id _} $Active {
                dict set Cancel $id {}
            }
        }
        method pause {args} {
            foreach id $args {
                dict set Paused $id {}
            }
        }
        method resume {args} {
            foreach id $args {
                dict unset Paused $id
            }
        }
        method info {args} {
            if {$args eq ""} {
                return $Active
            }
            foreach id $args {
                dict set result $id [dict get $Active $id]
            }
            return $result
        }

        # internal implementation:
        method Tick {id interval script} {
            dict unset Afters $id
            if {[dict exists $Cancel $id]} {
                dict unset Active $id
                dict unset Cancel $id
                dict unset Paused $id   ;# to be safe
                my Log Cancelled $id
                return
            }
            set start   [clock milliseconds]
            if {[dict exists $Paused $id]} {
                my Log Paused $id
            } else {
                try {
                    uplevel #0 $script
                } on break {} {
                    dict unset Active $id
                    dict unset Cancel $id
                    dict unset Paused $id   ;# to be safe
                } on continue {r o} {
                    if {$r ne ""} {
                        set interval $r     ;# support [continue newIntervalMilliseconds]
                    }
                } on error {e o} {
                    my Log BGERROR $id
                    dict unset Active $id
                    dict incr o -level -1
                    return -code error -options $o $e   ;# pass to bgerror (?)
                }
            }
            set end     [clock milliseconds]
            set elapsed [expr {$end - $start}]
            if {$elapsed > $interval} {
                my Log TOO LONG $id - $elapsed vs $interval
                set elapsed [expr {$elapsed % $interval}]
            }
            set delay [expr {$interval - $elapsed}]
            dict set Afters $id [after $delay [callback my Tick $id $interval $script]]
            return ""   ;# polite from event handlers.  Avoids bugs elsewhere.
        }

        method Log {args} {
            #puts stderr "[self] $args"
        }
    }

    Every create every

    namespace export every
}

namespace import every::every

# Non-standard extensions to core commands
# based on DKF's version from http://wiki.tcl.tk/15566
#
# Putting procs in the namespace is a bit unpleasant, with generic/reused names
#  (eg [array foreach])
#
package require fun
package require adebug

# helper to make quoting less odious
if {[info commands Uplevel] eq ""} {
    proc Uplevel {n args} {tailcall uplevel $n $args}
}

proc extend {ens script} {
    namespace eval $ens [concat {
        proc _unknown {ens cmd args} {
            if {$cmd in [::namespace eval ::${ens} {::info commands}]} {
                ::set map [::namespace ensemble configure $ens -map]
                ::dict set map $cmd ::${ens}::$cmd
                ::namespace ensemble configure $ens -map $map
            }
            ::return "" ;# back to namespace ensemble dispatch
        }
    }   \; $script]
    namespace ensemble configure $ens -unknown ${ens}::_unknown
}

extend dict {

    proc print {d args} {
        # get what $d looks like in our invocation:
        #set _ [lindex [cmd::wordSplit [dict get [info frame -1] cmd]] 2]

    }
    # returns "" if the path doesn't exist
    # note: this doesn't error if the 1st arg is not a dict
    proc get? {d args} {
        if {$args eq ""} {return $d}
        if {[dict exists $d {*}$args]} {dict get $d {*}$args}
    }

    # like dict get, but matches with glob patterns in the dict
    # *not* similar to [dict filter keys]
    proc glob {dict key args} {
        dict for {k v} $dict {
            if {[string match $k $key]} {
                if {$args eq ""} {
                    return $v
                } else {
                    tailcall [glob $dict {*}$args]
                }
            }
        }
    }

    # will only set if the kye doesn't already exist
    # .. I'm unsure if I want an [info exists d] check
    proc set! {_d args} {
        upvar 1 $_d d
        set v [lindex $args end]
        set args [lrange $args 0 end-1]

    proc exportto {namespace cmd} {
        uplevel 1 [list namespace export $cmd]
        namespace eval $namespace [list namespace import [uplevel 1 {namespace current}]::$cmd]
    }
}

# this breaks tcltags. !!??!!?
extend ::oo::InfoObject {
    proc commands {o args} {
        map {::namespace tail} [info commands [info object namespace $o]::*]
    }
}

# functional-style-programming stuff
#
# the sort of things that belong in _.tcl, I guess
#
# For a list of lists:
#   [join $lol] eq [concat {*}$lol]
#
package require Tcl 8.6

package require options

namespace eval fun {

    proc K {a args} {set a}
    proc -- args {}    ;# pseudo-comment

    -- too raunchy?
    -- proc sex {name value} {
        tailcall try [format {
            set %s [expr {%s}]
        } [list $name] $value]
    }


    #package require lambda
    # copied straight out of tcllib, to avoid the dependency
    ## Originally (C) 2011 Andreas Kupries, BSD licensed.
    proc lambda {arguments body args} {
        list ::apply [list $arguments $body] {*}$args
    }
    proc lambda@ {namespace arguments body args} {
        list ::apply [list $arguments $body $namespace] {*}$args
    }

    ##namespace import ::tcl::mathop::*
    #namespace import ::tcl::mathfunc::*
    namespace path ::tcl::mathfunc

    # convenience function for printing lists (handy for debugging!)
    proc putl {args} {
        puts $args
    }

    proc callback {args} {
        tailcall namespace code $args
    }

    # max and min should be able to take list arguments!
    proc max {args} {
        tailcall ::tcl::mathfunc::max {*}[concat {*}$args]
    }
    proc min {args} {
        tailcall ::tcl::mathfunc::min {*}[concat {*}$args]

            set pattern [string range $model 0 $i]*
            if {![all {string match $pattern} $strings]} {
                return [string range $model 0 $i-1]
            }
        }
        return $model
    }

    # mimic's textutil::adjust::undent
    proc undent {text} {
        set pres [regexp -inline -all -linestop -lineanchor {^.*?(?=\S)} $text]
        set pre [common_prefix $pres]
        regsub -all -linestop -lineanchor "^$pre" $text "" text
        set text [string trimleft $text \n]
        set text [string trimright $text " \t"]
        return $text
    }


    # local aliases that respect namespaces
    proc alias {alias cmd args} {
        if {![string match ::* $alias]} {
            set alias [uplevel 1 {namespace current}]::$alias
        }
        if {![string match ::* $cmd]} {

            if {[set res [try $try]] ne ""} {
                return $res
            }
        }
        return -code error "$cmd is not a namespace ensemble or object!"
    }

    # cd with automatic return
    proc indir {dir script} {
        set return [list ::cd [pwd]]
        cd $dir
        tailcall try $script finally $return
    }


    # we can't import ::readfile in safe interps created by interps-0.tm, so check for it:
    if {[namespace which -command ::readfile] eq ""} {
        proc readfile args {
            options {-oflags RDONLY} {-encoding utf-8} {-translation auto} {-eofchar ""}    ;# sensible defaults
            arguments {filename}

            set fd [open $filename $oflags]
            fconfigure $fd -encoding $encoding -translation $translation -eofchar $eofchar

            try {
                read $fd
            } finally {
                close $fd
            }
        }
    }

    proc writefile args {
        options {-oflags {WRONLY CREAT}} {-encoding utf-8} {-translation auto} {-eofchar ""}    ;# sensible defaults
        arguments {filename data}

        # always mkdir - some vfs's don't respond well if we don't
        file mkdir [file dirname $filename]

        set fd [open $filename $oflags]
        fconfigure $fd -encoding $encoding -translation $translation -eofchar $eofchar

        try {
            puts -nonewline $fd $data
        } finally {
            close $fd
        }
    }

    # ensures that $path is under $top (modulo symlinks - use [file normalize] for those)
    proc path_contains {top path} {
        # exact match is okay:
        if {$path eq $top} {
            return true
        }
        append top /
        set len [string length $top]
        # adjacent similarly-named directory is not okay
        if {[string compare -length $len $top $path]} {
            return false
        }
        # ensure no escape with ..
        set path [string range $path $len end]
        set depth 0
        foreach part [file split $path] {
            if {$part eq ".."} {
                incr depth -1
                if {$depth < 0} {return false}
            } else {
                incr depth
            }
        }
        # otherwise, it's safe!
        return true
    }


    proc divmod {a b} {
        list [expr {$a/$b}] [expr {$a % $b}]
    }

    # incrmod 10 i ?1?
    proc incrmod {m _n {i 1}} {

    }

    # http://wiki.tcl.tk/26079
    proc yieldm {{value {}}} {
        yieldto string cat $value
    }

    proc func args {
        set expr [lindex $args end]
        set args [lrange $args 0 end-1]
        tailcall proc {*}$args [list expr $expr]
    }

    # helper for composing scripts:
    proc script {args} {

        }
        return $res
    }

    proc ldiff {a b} {
        lmap elem $a { expr {$elem in $b ? [continue] : $elem} }
    }

    proc union {a b} {
        concat $a [lmap x $b {
            if {$x in $a} continue
            set x
        }]
    }

    proc intersect {a b} {
        lmap x $a {
            if {$x ni $b} continue
            set x
        }
    }

    # With 3+ arguments, this should be more like
    #  lmap $1 $2 [list expr $3]
    proc lfilter args {
        switch [llength $args] {
            2 {
                tailcall lfilter/2 {*}$args

        set l [llength $ls]
        set n [expr {$n % $l}]
        set tail [lrange $ls $n end]
        set head [lrange $ls 0 $n-1]
        concat $tail $head
    }

    # lpush list ?arg ...?
    # set item [lpop list]
    # lpop list -> a1 a2 a3
    # lassign [lpop list 3] a1 a2 a3
    #
    # set list {the list}
    # expr {[list {*}$list 1 2 3] eq [lpush list 1 2 3]}
    # expr {[lpop list a b c] eq {the list}}
    # expr {[list $a $b $c] eq {3 2 1}}     ;# note reversal!
    # expr {[lpop list] eq "list"}

    interp alias {} lpush {} lappend
    proc lpop {_list args} {
        upvar 1 $_list list
        multiargs {
            {} {
                try {
                    lindex $list end
                } finally {
                    set list [lrange $list 0 end-1]
                }
            }
            {n} {
                if {$n <= 0} {return ""}
                try {
                    lreverse [lreplace $list 0 end-$n]
                } finally {
                    set list [lrange $list 0 end-$n]
                }
            }
            {-> args} {
                if {${->} ne {->}} {
                    error "Invalid arguments: expected \[lpop listName N\] or \[lpop listName -> varName ..\] or \[lpop listName\]"
                }
                set values [lpop list [llength $args]]

                tailcall lassign $values {*}$args   ;# set vars in caller
            }
        }
    }

    #
    # expr {[list $a1 $a2 {*}$list] eq [lunshift list $a1 $a2]}
    # for symetry, lpop needs lpush


    # pop items off the beginning of a list.
    # single argument form returns the item popped
    # multi-arg form assigns to varNames, returning the remaining list.
    proc lpop {_ls args} {
        if {$args eq ""} {
            upvar 1 $_ls ls

        lmap {*}$forArgs $body
    }

    proc zip! {args} {
        debug assert {[== [map {llength} $args]]}
        tailcall zip {*}$args
    }

    proc transpose {lol} {
        # zip {*}$lol
        set res {}
        set r [set c -1]
        foreach row $lol {
            incr r
            foreach v $row {
                incr c
                lset res $c $r $v
            }
            set c -1
        }
        return $res
    }

    # normal map, but does multiple arguments:
    #  % map {expr} {1 2 3} {+ - *} {2 4 5}
    #  {3 -2 15}
    #
    # The args are names $0,$1..  in local space - they
    # could be upvared with performance benefit, but I'm

            set kids [ldiff $kids $stack]   ;# avoid cycles
            lappend stack {*}$kids
            #lappend stack {*}[concat {*}[map {tclose $cmdPrefix} [{*}$cmdPrefix $el]]]
        }
        set stack
    }

    # cartesian product of a list of lists
    # adapted from http://wiki.tcl.tk/2546
    proc cprod {lol} {
        set xs {{}}
        foreach ys $lol {
            set result {}
            foreach x $xs {
                foreach y $ys {
                    lappend result [list {*}$x $y]
                }
            }
            set xs $result
        }
        return $xs
    }

    proc ssplit {str substr} {
        set res {}
        set i 0
        set n [string length $substr]
        while {[set j [string first $substr $str $i]] != -1} {
            lappend res [string range $str $i $j-1]

        tailcall {*}$script
    }

    proc chuck args {
        set args [lreverse [lassign [lreverse $args] msg code]]
        tailcall return {*}$args -code error -errorcode $code $msg
    }

    proc quote_glob {s} {
        regsub -all {[?*{}\[\]~\\]} $s {\\\0}
    }
    proc quote_regex {str} {
        regsub -all {[][$^?+*()|\\.]} $str {\\\0}
    }

    namespace export *
}

namespace import ::fun::*    ;# eeek!

package require mainscript
if {[mainscript?]} {
    #tcl::tm::path add [pwd]
    package provide fun 0
    package require tests
    tests {
        func odd? {n} {$n%2}
        func even? {n} {![odd? $n]}

        test lfilter-1 "lfilter" -body {
            lfilter even? {1 2 3 4 5 6 7 8 9}
        } -result {2 4 6 8}

        test lfilter-2 "lfilter striding" -body {
            lfilter {x y} {1 2 3 4 5 6 7 8 9 0} {$x < 5}

        } -result false
        test chuck-1 "chuck?" -body {
            proc foo {} {
                chuck {BAD JUJU} "your mojo is no good!"
            }
            list [catch foo r o] $r [dict get $o -errorcode]
        } -result {1 {your mojo is no good!} {BAD JUJU}}

        test pathcontains-1 "path contains test battery" -body {
            set top [pwd]
            lappend tests ${top} ${top}a ${top}/a [string replace $top end end] [file join $top a b .. c .. ..] [file join $top a .. b .. ..]
            lmap t $tests {path_contains $top $t}
        } -result {true false true false true false}
    }
}

package require http
package require uri
if {![catch {package require tls}]} {
    http::register https 443 ::tls::socket
}

# simple wrapper for http::geturl
# follows redirections and by returns the response body
# _meta is a dict out param.
proc geturl {url {_meta {}}} {
    if {$_meta ne ""} {
        upvar 1 $_meta meta
    }
    http::config -useragent moop    ;# thanks sourceforge!
    set tok [::http::geturl $url]   ;# -headers {User-Agent moop} adds a 2nd user-agent header
    try {
        upvar 1 $tok state
        if {[set status [::http::status $tok]] ne "ok"} {
            error $status
        }
        set headers [dict map {key val} [::http::meta $tok] {
            set key [string tolower $key]
            set val
        }]
        if {[dict exists $headers location]} {
            tailcall geturl [::uri::resolve $url [dict get $headers location]] $_meta
        }
        return [::http::data $tok]
    } finally {
        unset ${tok}(body)
        # charset?  Content-Type {text/html;charset=UTF-8}
        set meta [array get $tok]
        ::http::cleanup $tok
    }
}

# see http://wiki.tcl.tk/40097 - "..." means we resolve symlinks
interp alias {} mainscript? {} expr {
       [info exists ::argv0]
    && [file dirname [file normalize $::argv0/...]]
    eq [file dirname [file normalize [info script]/...]]
}

        set tail [namespace tail $cmd]
        if {$tail eq "self"} continue

        oo::define Metaclass method $tail {cls args} [format {
            set cls [uplevel 1 [list namespace which $cls]]     ;# could avoid this with [tailcall]..
            debug log {defining %1$s on $cls}
            oo::define $cls %1$s {*}$args
        } [list $tail]]
    }

    # The base class of all classes is an instance of Metaclass and a subclass of oo::class.
    # Got that?  No, neither have I.  But play along .. it works.
    #
    # As an instance of Metaclass, it gets all the methods defined above (eg [Class export $cls $name ...]).
    #

# records:
#  A record is a dictionary with a defined set of keys, a convenient constructor (${name}::create)
#  and collection constructor (${name}::table).  These get their sugar from [dictargs] and [llsub].
#  The values are just dicts.
#
#  Use [record::declare] to declare a record kind and create these two special methods.
#
#  % record::declare some id {-foo} {-bar $::tcl_version -baz ""} {
#    if {$baz eq ""} {
#      set baz [string reverse $bar]
#    }
#  }
#  ::some
#
#  % some::create one -foo frop
#  {-id one -foo frop -bar 8.6 -baz 6.8}
#
#  % some::table {
#    one -foo frop
#    two -foo twine -bar hello
#    tre -foo food -baz 23
#  }
#  {one {-id one -foo frop -bar 8.6 -baz 6.8}
#   two {-id two -foo twine -bar hello -baz hello}
#   tre {-id tre -foo food -bar 8.6 -baz 23}}
#
#  [record::method] is a convenience wrapper for procs which see all the record's fields as local variables.
#  Simply, it inserts an argument _ and wraps the body in [dict with _]:
#
#   % record::method some::foo {a b} {list $foo $bar $a $b}
#
#  is equivalent to:
#
#   % proc some::foo {_ a b} {dict with _ {list $foo $bar $a $b}}
#
#  and in fact I recommend making procedures alongside methods in this way.
#
#  Records are designed for immutable (create-once) use - mutator methods will need some care.
#
#
#  [${name}::create]: returns a dictionary
#   % ..::create id -field1 val1 -field2 val2
#   {id id field default field1 val1 field2 val2}
#
#  [${name}::table] returns a dictionary whose keys are ids and values are full dicts as above
#   % ..::table {
#       id1 -field value
#       id2 -field2 value2 -field3 [expr 40+2]
#   }
#   {id1 {id id1 field value field1 {} field2 {}}
#    id2 {id id2 field1 default field2 value2 field3 42}}
#
namespace eval record {
    # name  - the namespace in which to create the new record
    # id    - the key that acts as an identifier
    # req   - required arguments, as a list
    # opt   - optional arguments, as a {name default} dictionary
    # body  - an (optional) constructor script, which sees all fields as locals
    proc declare {name id req opt {body ""}} {
        if {![string match ::* $name]} {
            set ns [string trimright [uplevel 1 {namespace current}] :]::$name
        }
        set req [lmap k $req {regsub ^- $k {}}]
        set opt [lmap k $opt {regsub ^- $k {}}]
        set map [dict create @REQ [list $req] @OPT [list $opt] @BODY $body]
        namespace eval $ns {}
        proc ${ns}::create [list $id args] [string map $map {
            set args [dict map {_k _v} $args {
                if {![regsub ^- $_k {} _k]} {
                    throw {BAD ARGUMENT} "Invalid argument \"$_k\""
                }
                set _v
            }]
            unset _k; unset _v
            set _ $args; unset args
            ::record::dictargs _ @REQ @OPT
            unset _
            @BODY
            return [::record::capture]
        }]
        alias ${ns}::table table ${ns}
    }

    proc method {name args body} {
        tailcall proc $name [list _ {*}$args] [list dict with _ $body]
    }

    proc table {name table} {
        set result {}
        foreach arglist [updo [namespace which llsub] $table] {
            dict set result [lindex $arglist 0] [${name}::create {*}$arglist]
        }
        return $result
    }

# essentials:
    # compare:
    #   interp alias {} [namespace current]::the_alias {} [namespace which -command target] arg
    #   alias the_alias target arg
    proc alias {alias cmd args} {
        set alias   [upns 1 $alias]
        set cmd     [upns 1 $cmd]
        interp alias    {} $alias   {} $cmd {*}$args
    }
    # compare:
    #   set x [uplevel 1 [list namespace which $command]]
    #   set x [updo 1 namespace which $cmd]
    #   set x [updo {namespace which} $cmd]   ;# lvl can be elided when safe; first word will be expanded
    proc updo {{lvl 1} args} {
        tailcall uplevel $lvl $args
    }
    # [upns]            - get namespace of caller
    # [upns 2]          - get namespace of caller's caller
    # [upns 1 cmd]      - qualify cmd with caller's namespace
    # [upns 1 cmd 1 2]  - create a callback with two arguments
    #  level can only be elided in the argless case
    proc upns {{lvl 1} args} {  ;# doubles as resolve-cmdname-in-caller
        if {$args eq ""} {
            tailcall uplevel $lvl {namespace current}
        } else {
            set cargs [lassign $args cmd]
            if {[string match :* $cmd]} {
                return $args
            }
            set ns [uplevel [expr {$lvl+1}] {namespace current}]
            set ns [string trimright $ns :]
            return [list ${ns}::$cmd {*}$cargs]
        }
    }

    # get current (local) environment as a dict
    # arrays are ignored (bluntly, by [catch])
    proc capture args {
        if {$args eq ""} {
            set args [uplevel 1 {info locals}]
        }
        set result {}
        foreach arg $args {
            catch { ;# ignore arrays
                dict set result $arg [uplevel 1 [list set $arg]]
            }
        }
        return $result
    }

    # cmdsplit splits a Tcl script into a list of commands and comments
    proc cmdsplit {script} {
        set chunk {}
        set commands {}
        foreach line [split $script \n] {
            append chunk $line
            if {![info complete $chunk\n]} {    ;# no end of cmd yet - put back the newline
                append chunk \n
                continue
            }
            set cmd ""
            foreach part [split $chunk \;] {     ;# chunk may yet be split on semicolons
                append cmd $part
                if {![info complete $cmd\n]} {   ;# internal semicolon
                    append cmd \;
                    continue
                }
                set cmd [string trimleft $cmd]  ;# ignore leading whitespace
                if {$cmd eq ""} {continue}      ;# skip empty commands
                if {[string match #* $cmd]} {   ;# semicolon in comment
                    append cmd \;
                    continue
                }
                # else, we have a command!
                lappend commands $cmd
                set cmd ""
            }
            if {$cmd ne ""} {                   ;# if there's anything left, it will have an extra semicolon
                set cmd [string range $cmd 0 end-1]
                lappend commands $cmd
            }
            set chunk ""
        }
        if {![string is space $chunk]} {
            throw {PARSE ERROR} "Can't parse script into a sequence of commands:\n\
                                \tIncomplete command:\n\
                                -----\n\
                                $chunk
                                -----"
        }
        return $commands
    }

    # wordsplit splits a Tcl command into a list of its constituent (unevaluated) words
    proc wordsplit {cmd} {
        if {![info complete $cmd\n]} {
            throw {PARSE ERROR} "Not a complete command:\n-----\n$command\n-----"
        }
        # we can ignore leading whitespace, so the regex just has to pick up words
        # with trailing space
        set re { ( (?:\\.|[^\\\s])+ )        # backslash escapes or non-whitespace
                 ( \s* )                     # space (greedy) }
        set words {}    ;# result
        set word ""     ;# current word
        foreach {_ frag space} [regexp -all -inline -expanded $re $cmd] {
            append word $frag
            if {![info complete $word\n]} {                     ;# not yet a complete word
                append word $space
                continue
            }
            lappend words $word
            set word ""
        }
        if {$word ne ""} {lappend words $word}                  ;# we can have leftovers
        return $words
    }

    # [lsub] sits conceptually between [list] and [subst]:
    #  its argument is tokenised into words according to Tcl command syntax,
    #  and each word is substituted in the caller's environment.
    #
    # Example:
    #   % apply {{{greeting "Hello, %s!\n"} {who world}} {
    #     lsub { $greeting $who  ;# comments are allowed
    #            # and so are newlines
    #            [string toupper $who] }}}
    #   {{Hello, %s!\n} world WORLD}
    #
    proc lsub script {              ;# [sl] from the wiki
        # FIXME: this breaks badly on semicolons
        set res {}
        set parts {}
        foreach part [split $script \n] {
            lappend parts $part
            set part [join $parts \n]
            #add the newline that was stripped because it can make a difference
            if {[info complete $part\n]} {
                set parts {}
                set part [string trim $part]
                if {$part eq {}} {
                    continue
                }
                if {[string index $part 0] eq {#}} {
                    continue
                }
                #Here, the double-substitution via uplevel is intended!
                lappend res {*}[uplevel list $part]
            }
        }
        if {$parts ne {}} {
            error [list {incomplete parts} [join $parts]]
        }
        return $res
    }

    # llsub is lsub's simpler big brother.  It tokenises its argument according to
    # Tcl *script* syntax and returns a list of list, where each inner list is a
    # (substituted) command from the input.  Unlike lsub, newlines and semicolons
    # between elements are significant.
    #
    # This proc is a one-token change from lsub, but provided in full for
    # easy bytecoding.
    proc llsub script {              ;# tiny derivation from [lsub]
        # FIXME: this breaks badly on semicolons
        set res {}
        set parts {}
        foreach part [split $script \n] {
            lappend parts $part
            set part [join $parts \n]
            #add the newline that was stripped because it can make a difference
            if {[info complete $part\n]} {
                set parts {}
                set part [string trim $part]
                if {$part eq {}} {
                    continue
                }
                if {[string index $part 0] eq {#}} {
                    continue
                }
                #Here, the double-substitution via uplevel is intended!
                lappend res [uplevel list $part]    ;# the difference!  (no {*})
            }
        }
        if {$parts ne {}} {
            error [list {incomplete parts} [join $parts]]
        }
        return $res
    }

    # The named _args variable must have all requireds, and all keys must be in requireds OR defaults.
    # _args is updated with defaults, and all req+opt are created in the calling environment.
    #   * requireds is an ordinary list
    #   * defaults is an lsub dict.
    proc dictargs {_args requireds defaults} {
        upvar 1 $_args args
        set defaults [uplevel 1 [list [namespace which lsub] $defaults]]
        # FIXME: handle unambiguous prefixes
        set missing [lmap arg $requireds {
            if {[dict exists $args $arg]} continue
            set arg
        }]
        if {$missing ne ""} {
            tailcall tailcall throw {TCL BADARGS} "Missing required arguments \"[join $missing {", "}]\""
        }
        set bad [dict filter $args script {k _} {
            expr {($k ni $requireds) && ![dict exists $defaults $k]}
        }]
        if {$bad ne ""} {
            tailcall tailcall throw {TCL BADARGS} "Unexpect arguments \"$bad\"\naccepted arguments are ([dict keys $defaults])"
        }
        set args [dict merge $defaults $args]
        tailcall dict with $_args {}
    }

}


if 0 {
    record::declare option switch { } {
        -studly     {}
        -default    {}
        -verifier   {}
        -configuremethod {}
        -cgetmethod {}

        -delegate   {}
    } {
        if {$studly eq "" && $delegate eq ""} {
            error "Must provide either -studly or -delegate!"
        }
        set resname     [string tolower $studly 0 0]
        set resclass    $studly
        unset studly
    }

    #proc option::resource {_ value}
    record::method option::resource {value} {
        list $switch $resname $resclass $default $value
    }


    proc putl args {puts $args}
    putl ok
    #putl proc option::create [info args option::create] [info body option::create]
    #putl --

    set win .CONSOLE
    set options [option::table {
         -readonly   -studly ReadOnly -default false -verifier {string is boolean}
         -background -delegate $win.output
         -ibg        -delegate [list $win.input -background]
    }]
    array set {} $options; parray {}
    putl ok

    array set v {-readonly TRYE -background FREEN -ibg YELLOF}
    puts [join [lmap {o d} $options {option::resource $d $v($o)}] \n]
}

if 0 {
    package require fun
    foreach cmd [info procs ::fun::*] {
        set parts [record::cmdsplit [info body $cmd]]
        puts [list $cmd [llength $parts] $parts]
        set subs [lmap p $parts {
            if {[string match #* $p]} continue
            lindex $p 0}]
        puts [list $cmd [llength $parts] $subs]
    }
}
package require tests
tests {
    test record::wordsplit-1 "wordsplit" -body {
        join [record::wordsplit {{foo  bar}  "$baz   quz 23"   lel\ lal lka ${foo b  bar} froot\  bars bla[e {oo]}]lll}] "\n                "
    } -result  {{foo  bar}
                "$baz   quz 23"
                lel\ lal
                lka
                ${foo b  bar}
                froot\ 
                bars
                bla[e {oo]}]lll}
}

package require Tk
package require Ttk

# better selection behaviour
proc ::ttk::combobox::TraverseIn w {
    $w instate {!disabled} {
        $w selection range 0 end
        $w icursor end
    }
}
proc ::ttk::combobox::TraverseOut w {
    $w selection clear
}
bind TCombobox <<TraverseOut>> [list ::ttk::combobox::TraverseOut %W]

# necessary on linux: (from http://wiki.tcl.tk/1959)
ttk::style map TCombobox -fieldbackground {readonly white disabled #d9d9d9} 

# jcowgar's improved completion
#source misctcl/combobox/combobox.tcl

;# FIXME: still weird selection behaviour on change

#
# SYNOPSIS:
#
#  ButtEntry -command {tk_getOpenFile}
#
# A readonly entry which invokes -command on Invoke
# the result of -command becomes the new value
#
package require snit
package require vartrace

snit::widgetadaptor ButtEntry {

    option -command     -default {}

    delegate option -variable to hull as -textvariable  ;# go team!

    delegate option * to hull
    delegate method * to hull

    constructor args {
        installhull using entry
        $self configurelist $args
        $self configure -state readonly ;# yuck
        bind $win <1> [mymethod activate]
        bind $win <Return> [mymethod activate]
        bind $win <<Invoke>> [mymethod activate]
    }
    method activate args {
        # after idle ?
        set newval [uplevel #0 $options(-command) [list [$self get]]]  ;# how does this get arguments?
        $self configure -state normal   ;# yuck
        $self delete 0 end
        $self insert 0 $newval
        $self configure -state readonly ;# yuck
        #debug show {$self $newval}
        #debug show {[$self configure -textvariable]}
    }
}

snit::widgetadaptor OnButton {

    option -variable    -default {} -configuremethod setOpt
    option -command     -default {} -configuremethod setOpt

    delegate option * to hull
    delegate method * to hull

    variable var
    variable var_

    constructor args {
        set var_ 0
        upvar #0 [myvar var_] [myvar var]
        vartrace add [myvar var] write [mymethod traceHandler]

        installhull using ttk::button -command [mymethod activate]
        $self configure -variable [myvar var_]
        $self configurelist $args
    }

    destructor {
        vartrace remove [myvar var] write [mymethod traceHandler]
    }

    method activate args {
        debug what
        # after idle ?
        after idle [list set [myvar var] 1]
        #set var 1
        if {$options(-command) ne ""} {
            $options(-command)
        }
    } 

    method setOpt {name value} {
        debug what
        switch $name {
            -variable {
                vartrace suspend [myvar var] {
                    upvar 0 $value [myvar var]
                }
                variable var
                debug log {rebound to $value == $var [set [myvar var]]}
                if {![string is boolean -strict $var]} {
                    debug log {Initialising $value to 0!}
                    set var 0
                }
            }
            -command {
            }
            default {
                error "Unknown option: $name"
            }
        }
        set options($name) $value
    }

    method traceHandler args {
        debug log {$self traceHandler $args: $var}
        $self configure -state [expr {$var ? "disabled" : "normal"}]
    }
}

#
# SYNOPSIS:  a direct analogue of radioset
#
package require Tk
package require snit
package require adebug

snit::widgetadaptor CheckSet {

    option -command -default {} -configuremethod setOpt
    option -variable -default {} -configuremethod setOpt    ;# this is a list
    option -choices -default {} -configuremethod setOpt
    option -choicesvariable -default {} -configuremethod setOpt
    option -value -default {} -configuremethod setOpt

    variable items
    variable state      ;# this is an array, bound to the individual checkbuttons
                        ;# a trace on state updates the -variable, if present
    variable listvariable   ;# declared here so that methods see it

    constructor args {
        debug off
        set var {}
        set items {}
        array set state {}
        trace add variable [myvar state] write [mymethod stateTrace]
        installhull using frame
        $self configurelist $args
    }

    method get {} {return $listvariable}

    method set {ls} {
        set listvariable $ls
    }

    method setOpt {name value} {
        debug what
        switch $name {
            -command {
                $self configitems -command $value
            }
            -variable {
                if {[info exists listvariable]} {
                    unset listvariable  ;# takes traces with it
                }
                upvar #0 $value [myvar listvariable]
                trace add variable [myvar listvariable] write [mymethod variableTrace]
            }
            -choicesvariable {
                if {[info exists items]} {
                    unset items
                }
                upvar #0 $value [myvar items]
                trace add variable [myvar items] write [mymethod itemsTrace]
                $self build
            }
            -choices {
                set items $value
                $self build
            }
            -value {
                $self set $value
                return
            }
        }
        set options($name) $value
    }

    # this could do with insert and delete methods as well, to be complete as a container
    method build {} {
        map destroy [winfo children $win]
        set n 0
        dict for {value text} $items {
            if {![info exists state($value)]} {
                set state($value) 0
            }
            grid [checkbutton [$self widget $n] -text $text -anchor w \
                    -variable [myvar state($value)] -command $options(-command)] -sticky nsew
            grid rowconfigure $win $n -weight 1
            incr n
        }
        grid columnconfigure $win 0 -weight 1
    }

    method widget {idx} {
        if {[string is integer $idx]} {
            if {($idx < 0) || ($idx >= [dict size $items])} {
                return -code error "Index out of bounds: $idx"
            }
            return $win.r$idx
        }
        if {[dict exists $items $idx]} {
            set n [dict search $items $idx]
            tailcall $self widget $n
        } elseif {$idx in {end last}} {
            tailcall $self widget [expr {[dict size $items]-1}]
        }
        return -code error "Bad index: $idx"
    }

    method widgets {} {
        lmap idx [range [dict size $items]] {
            subst {$win.r$idx}
        }
    }

    method configitems {args} {
        lmap iw [$self widgets] {
            $iw configure {*}$args
        }
    }
    method itemconfig {idx args} {
        [$self widget $idx] {*}$args
    }

    variable notrace 0
    method notrace {script} {
        if {!$notrace} {
            incr notrace
            try {
                uplevel 1 $script
            } finally {
                incr notrace -1
            }
        }
        debug log {notrace skipping!}
    }

    method variableTrace args {
        debug log {variable changed}
        $self notrace {
            array set state [lconcat {k v} [array get state] {
                list $k [expr {$k in $listvariable}]
            }]
        }
    }

    method itemsTrace args {
        debug log {items changed}
        after idle [list $self build]
    }

    method stateTrace args {
        debug log {state changed}
        $self notrace {
            set listvariable [lmap {k v} [array get state] {
                if {!$v} continue
                set k
            }]
        }
    }
}

if 0 {
    package require Tk
    pack [CheckSet .rs -choices {blue "The colour of the sky" green "at the gills with envy"} -variable foo -command {puts "You chose $::foo"}]
}

# not really a snidget, but widget::dialog is!
# 
package require widget::dialog

proc choiceDialog {choices} {
    set w .choiceDialog[llength [info commands .choiceDialog*]]
    set dlg [widget::dialog $w -separator 1 -type custom]
    set frame [frame $w.f]
    label $frame.l -text "Choose target table"
    set lb [listbox $frame.lb]
    $lb insert end {*}$choices
    grid $frame.l -sticky nsew
    grid $frame.lb -sticky nsew
    grid columnconfigure $frame 0 -weight 1
    grid rowconfigure $frame 1 -weight 1
    $dlg setwidget $frame
    $dlg add button -text Okay -command [format {%s close [list ok [%s get active]]} [list $dlg] [list $lb]]
    $dlg add button -text Cancel -command [list $dlg close cancel]
    set result [$dlg display]
    destroy $dlg
    return [lindex $result 1]   ;# because widget::dialog binds <Escape> to {close cancel}
}

proc comboDialog {default choices} {
    set w .choiceDialog[llength [info commands .choiceDialog*]]
    set dlg [widget::dialog $w -separator 1 -type custom]
    set frame [frame $w.f]
    label $frame.l -text "Choose target table"
    entry $frame.e -exportselection yes
    $frame.e insert end $default
    set lb [listbox $frame.lb -exportselection yes]
    $lb insert end {*}$choices

    grid $frame.l -sticky nsew
    grid $frame.e -sticky nsew
    grid $frame.lb -sticky nsew

    grid columnconfigure $frame 0 -weight 1
    grid rowconfigure $frame $frame.lb -weight 1

    bind $frame.e <1> "$frame.e configure -state normal; $frame.lb configure -state disabled"
    bind $frame.lb <1> "$frame.lb configure -state normal; $frame.e configure -state disabled"

    $dlg setwidget $frame
    $dlg add button -text Okay -command [list {*}[lambda {dlg} {
        set f $dlg.f
        if {[$f.e cget -state] ne "disabled"} {
            $dlg close [list ok [$f.e get]]
        } else {
            $dlg close [list ok [$f.lb get [$f.lb curselection]]]
        }
    }] $dlg]
    $dlg add button -text Cancel -command [list $dlg close cancel]
    set result [$dlg display]
    destroy $dlg
    return [lindex $result 1]   ;# because widget::dialog binds <Escape> to {close cancel}
}

package require Tk
package require Ttk
package require snit
package require options


snit::widgetadaptor FileEntry {

    # one of {open save directory}
    #  - also support directory?  less options
    #  - also support multi?  doesn't work with a single [entry]
    option          -type   -default {open} -configuremethod setOpt

    # for tk_get*File:  see [method DlgOpts]
    option      -confirmoverwrite   -default true
    option      -defaultextension   -default ""
    option      -filetypes          -default ""
    option      -initialdir         -default ""
    option      -message            -default "\ufffd"
    option      -title              -default "\ufffd"
    # -parent is automatic
    # -typevariable is not used yet
    # -multiple is with -type multi
    # for tk_chooseDirectory
    option      -mustexist          -default true

    delegate option -width          to entry
    delegate option -variable       to entry as -textvariable

    delegate option -textvariable   to button
    delegate option -text           to button

    delegate method get             to entry

    constructor args {
        installhull using ttk::frame
        install entry using entry $win.entry
        install button using button $win.button -command [mymethod Invoke]
        bind $entry <Return> [mymethod Invoke]
        grid $entry $button -sticky nsew
        if {![dict exists $args -text]} {
            dict set args -text "Browse"
        }
        $self configurelist $args
    }

    method set {fn} {
        $entry delete 0 end
        $entry insert end $fn
        after idle [mymethod SetSel]
    }

    method setOpt {opt val} {
        switch -exact $opt {
            -type {
                if {$val ni {open save directory}} {
                    return -code error "Illegal option -type \"$val\": must be in {open save directory}"
                }
            }
            default {
                return -code error "Unknown options $option"
            }
        }
        set options($opt) $val
    }

    method DlgOpts {} {
        lappend res -parent $win
        set fn [$entry get]
        if {$fn eq ""} {
            set dir [pwd]
        } else {
            set dir [file dirname $fn]
        }
        lappend res -initialdir $dir
        if {$options(-type) eq "directory"} {
            set opts {
                -mustexist
            }
        } else {
            lappend res -initialfile $fn
            set opts {
                -defaultextension
                -filetypes
                -initialdir
                -message
                -title
            }
        }
        if {$options(-type) eq "multi"} {
            lappend res -multiple yes
        }
        if {$options(-type) eq "save"} {
            lappend opts -confirmoverwrite
        }
        foreach opt $opts {
            set val $options($opt)
            if {$val ne "\ufffd"} {
                lappend res $opt $val
            }
        }
        return $res
    }

    method Invoke {} {
        set fn [
            switch -exact $options(-type) {
                "open" - "multi" {
                    tk_getOpenFile {*}[$self DlgOpts]
                }
                "save" {
                    tk_getSaveFile {*}[$self DlgOpts]
                }
                "directory" {
                    tk_chooseDirectory {*}[$self DlgOpts]
                }
            }
        ]
        if {$fn ne ""} {
            set fn [file nativename $fn]
            $entry delete 0 end
            $entry insert end $fn
            after idle [mymethod SetSel 1]
        }
    }

    method SetSel {{focus 0}} {
        set fn [$entry get]
        set l [string length $fn]
        set a [expr {$l - [string length [file tail $fn]]}]
        set b [expr {$l - [string length [file extension $fn]]}]
        $entry selection range $a $b
        $entry xview end
        $entry icursor $b
        if {$focus} {
            focus $entry
        }
    }
}

#
# SYNOPSIS:
#
#   FilesChooser .fc -text "Choose some files" \
#       -multiple yes \
#       -filetypes {{txt *.txt} {common {*.csv *.tsv *.txt}} {all *.*}} \
#       -listvariable filenames
#
package require fun ;# maxlen, format_size, isodate

snit::widget FilesChooser {
    hulltype ttk::labelframe

    variable filenames  {}
    variable display    {}

    option -listvariable -default {} -configuremethod setOption
    option -command      -default {}

    # these are delegated to tk_get{Open,Save}File in chooseFiles
    option -multiple -default {}    ;# yes
    option -filetypes -default {}   ;# {{all *.*}}
    option -defaultextension -default {}
    option -initialdir -default {}
    option -title -default {}
    option -type -default tk_getOpenFile

    delegate method * to hull
    delegate option * to hull

    constructor args {
        $self buildWidgets
        $self configurelist $args
        $self setDisplay
    }

    method buildWidgets {} {
        grid [label $win.filenames -anchor nw -justify left -font TkFixedFont -textvariable [myvar display]] \
             [button $win.b_load -text "Choose Files" -command [mymethod chooseFiles]] \
            -in $win -sticky nsew -padx 5 -pady 5
        grid ^ \
             [button $win.b_clear -text "Clear" -command [mymethod clearFiles]] \
            -in $win -sticky nsew -padx 5 -pady {0 5}
        grid ^ \
             x \
            -in $win -sticky nsew

        grid columnconfigure $win 0 -weight 1
        grid columnconfigure $win 1 -weight 0
        grid rowconfigure $win 0 -weight 0
        grid rowconfigure $win 1 -weight 0
        grid rowconfigure $win 2 -weight 1
    }

    method setOption {option value} {
        switch -exact -- $option {
            -listvariable {
                set options(-listvariable) $value
                # it would be nice if we could simply:   upvar #0 $value filenames
                upvar #0 $value it
                if {[info exists it]} {
                    set filenames $it
                    $self setDisplay
                } else {
                    set it $filenames
                }
            }
            default {
                return -code error "Unknown option $option"
            }
        }
    }

    method chooseFiles {} {
        set params {}
        foreach opt {-multiple -filetypes -defaultextension -initialdir -title} {
            if {$options($opt) ne ""} {
                lappend params $opt $options($opt)
            }
        }
        set fs [$options(-type) {*}$params]
        if {$fs ne ""} {
            set filenames $fs
            if {$options(-listvariable) ne ""} {uplevel #0 [list set $options(-listvariable) $filenames]}
            $self setDisplay
        }
    }

    method setDisplay {} {
        set display [$self formatFilenames $filenames]
        if {$options(-command) ne ""} {
            after 0 [list {*}$options(-command) $filenames]
        }
    }

    method formatFilenames {fs} {
        if {$fs eq ""} {
            return "\nNo Files Chosen\n"
        } else {
            set dir [file dirname [lindex $filenames 0]]
            set fs [map {file tail} $filenames]
            set maxlen [maxlen $fs]
            set n [llength $fs]
            set files [expr {$n != 1 ? "files" : "file"}]
            set txt "$n $files from $dir:\n"
            foreach fn $filenames {
                set size [format_size [file size $fn]]
                set mtime [isodate [file mtime $fn]]
                set fn [file tail $fn]
                append txt [format "\n  %-${maxlen}s  %10s  %19s" $fn $size $mtime]
            }
            return $txt
        }
    }

    method clearFiles {} {
        set filenames {}
        if {$options(-listvariable) ne ""} {uplevel #0 [list set $options(-listvariable) $filenames]}
        $self setDisplay
    }
}

package require tooltip ;# tklib
package require snit

snit::widgetadaptor Lamp {
    variable State
    delegate method * to hull
    delegate option * to hull
    constructor args {
        installhull using label
        # $self configure -text \u25c9    ;# FISHEYE
        $self configure -text \u25cf      ;# LARGE BLACK CIRCLE
        # $self configure -text \u2022    ;# BULLET
        # $self configure -text *         ;# ultimate fallback
        $self configure -fg gray50
        $self configurelist $args
    }
    method state args {
        tailcall $self state/[llength $args] {*}$args
    }
    method state/0 {} {
        return $State
    }
    method state/1 {state} {
        set State $state
        $self configure -fg $State
    }
}

# this expects to be given a container widget
oo::class create Indicators {
    variable W
    variable Packer
    variable I
    variable Sym
    variable Statemap
    constructor {container {packer {pack -side right}}} {
        set W $container
        set Packer $packer
        array set I {}
        set Sym -1
        set Statemap {}
    }
    method statemap {d} {
        set Statemap [dict merge $Statemap $d]
    }
    method state args {
        catch {lset args end [dict get $Statemap [lindex $args end]]}
        tailcall my state/[llength $args] {*}$args
    }
    method delete {name} {
        tooltip::tooltip clear $I($name)
        destroy $I($name)
        unset I($name)
    }
    method widget {name} {
        if {![info exists I($name)] || $I($name) eq ""} {
            set I($name) [Lamp ${W}.i#[incr Sym]]
            tooltip::tooltip $I($name) $name
            {*}[linsert $Packer 1 $I($name)]
        }
        return $I($name)
    }
    method state/1 {name} {
        set w [my widget $name]
        $w state
    }
    method state/2 {name colour} {
        set w [my widget $name]
        $w state $colour
    }
}

#
# SYNOPSIS:
#
#   pack [labelled .e button -label "Type stuff" -text "Press me" -command {puts [.e get]}]
#
package require snit

proc otherside {side} {
    dict get {
        left right
        right left
        top bottom
        bottom top
    } $side
}

snit::widgetadaptor labelled {

    component label
    component widget

    option -side -default left
    option -state -default normal -configuremethod setOpt
    delegate option -label to label as -text
    delegate option * to widget
    delegate method * to widget

    method setOpt {opt value} {
        switch -exact $opt {
            -state {
                $label configure -state [expr {$value eq "disabled" ? "disabled" : "normal"}]
                $widget configure -state $value
            }
        }
        set options($opt) $value
    }

    constructor {cons args} {
        installhull using frame
        install label  using label $win.label -anchor w
        install widget using $cons $win.widget
        $self configure -takefocus {}   ;# why is this needed?  seems to only be in FormDialogs??
        $self configurelist $args
        pack $widget -side [otherside $options(-side)] -fill none -expand no    -padx 2 -pady 2
        pack $label  -side [otherside $options(-side)] -fill both -expand yes   -padx 2 -pady 2
#        grid $label  -sticky nsew
#        grid $widget -row 0 -column 1 
#        grid columnconfigure $win 1 -weight 0
#        grid columnconfigure $win 0 -weight 1
#        grid rowconfigure $win 0 -weight 1
        trace add command $widget delete "destroy $self; list"
    }

}

package provide labelled 0.1

if 0 {
    package require Tk
    grid [labelled .e button -label "This is a button" -text "Press me" -command {puts "aah!"}] -sticky nsew
    grid [labelled .e2 button -label "So is this" -side right -text "Push It" -command {puts "so good"}] -sticky nsew
    grid [labelled .e3 button -label "This is a button" -side top -text "Press me" -command {puts "aah!"}] -sticky nsew
    grid [labelled .e4 button -label "So is this" -side bottom -text "Push It" -command {puts "so good"}] -sticky nsew
    grid columnconfigure . 0 -weight 1
    grid rowconfigure . 0 -weight 1
    grid rowconfigure . 1 -weight 1
    grid rowconfigure . 2 -weight 1
    grid rowconfigure . 3 -weight 1
}

package require snit
package require adebug
package require tests
package require vartrace

snit::widgetadaptor ListChooser {

    option -variable    -default {} -configuremethod setOpt
    option -command     -default {} -configuremethod setOpt

    delegate option * to hull
    delegate method * to hull

    variable var
    variable var_

    constructor args {
        set var_ 0
        upvar #0 [myvar var_] [myvar var]
        vartrace add [myvar var] write [mymethod traceHandler]

        installhull using listbox
        bind $win <<ListboxSelect>> [list after idle [mymethod lbSelect]]
        $self configure -variable [myvar var_]
        $self configurelist $args
    }

    destructor {
        vartrace remove [myvar var] write [mymethod traceHandler]
    }

    method lbSelect {} {
        debug what
        set var [$self get [$self curselection]]

        if {$options(-command) ne ""} {
            after idle [list {*}$options(-command) $var]
        }
    } 

    method setOpt {name value} {
        debug what
        switch $name {
            -variable {
                vartrace suspend [myvar var] {
                    upvar 0 $value [myvar var]
                }
                variable var
                debug log {rebound to $value == $var [set [myvar var]]}
                if {$var ni [$self get 0 end]} {
                    debug log {Initialising $value to 0!}
                    set var [$self get 0]
                }
            }
            -command {
            }
            default {
                error "Unknown option: $name"
            }
        }
        set options($name) $value
    }

    method select {val} {
        set idx [lsearch -exact [$self get 0 end] $val]
        $self selection clear 0 end
        $self activate $idx
        $self selection set $idx $idx
    }

    method traceHandler args {
        debug log {$self traceHandler $args: $var}
        $self select $var
        #$self configure -state [expr {$var ? "disabled" : "normal"}]
    }
}

tests {
    proc test {} {
        package require Tk
        set ::l {one two three four five six}
        set ::v four
        pack [ListChooser .l -listvariable ::l -variable ::v -command {debug log CHOSE}]
        #pack [listbox .lb -listvariable ::l]
    }
    test
}