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 {*}[regexp -inline -start $i {\s*} $s]]
        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 {*}[regexp -inline -start $i %s $s]]
            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 a la bindtags(n) example looks interesting
# 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 debug
package require tkImprover


pkg -export * Window {
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
                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]
                proc windowcontext {} [list return $w]
            }
            set griddefaults {}

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

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


        export varname  ;# this will be useful for consumers
                        ;# as will this:
        method callback {method args} {
            namespace code [list my $method {*}$args]

        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 $name
            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 {$a in [info object variables [self]]}
                        debug assert {$n in [info object variables [self]]}
                        set q 0
                        my varname $a
                    } else {
                        set a
                    }
                } else {
                    if {[string match -*variable $a]} {
                    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
                    }
                }
            if {$cmd in "anchor bbox location size propagate slaves configure rowconfigure columnconfigure"} {
            } 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
                grid {*}[my GridArgs $cmd {*}$args] ;#-in $w
            }
        }
        method pack {cmd args} {
            my GM pack [my GetIn $args]
            if {$cmd in "propagate slaves"} {
            if {$cmd in "propagate slaves forget"} {
                pack $cmd $w {*}[my ItemArgs {*}$args]
            } else {
                pack {*}[my GridArgs $cmd {*}$args] -in $w
                pack {*}[my GridArgs $cmd {*}$args] ;#-in $w
            }
        }
        method ItemArgs {args} {
            set j [lsearch -glob $args -*]
            if {$j == -1} {
                set preargs $args
            set i 0
            set args [lmap a $args {
                if {[string match -* $a]} {
                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]} {
                    incr i
                }
                dict set opts -in [my WinArg [dict get $opts -in]]
            }
                expr {$i ? $a : [$a w]}
            }]
            concat $preargs $opts
        }
        method GridArgs {args} {
            set j [lsearch -glob $args -*]
            if {$j == -1} {
                set preargs $args
            set i 0
            array set def $griddefaults
            set args [lmap a $args {
                if {[string match -* $a]} {
                    unset -nocomplain def($a)
                    incr i
                }
                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]
            }
                expr {$i ? $a : [$a w]}
            }]
            concat $args [array get def]
        }

        method bind args {
            multiargs {
                {event script} {
                    bind [my w] $event $script
                }
        method bind {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]
                {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 {name} {
            set [my varname $name]
        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 [my w]
                return [self] ;#[my w]
            } else {
                tailcall [my w] {*}$args
            }
        }
    }
}

if 1 {
    package require Tk

# 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} {
        }
    }

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


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

}
if 0 {
    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!
}
                #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]
    }
if 0 {
    package require repl
    chan configure stdin -blocking 0
    chan configure stdout -buffering none
    coroutine repl repl::chan stdin stdout
    puts vwaiting
    vwait forever
}


    "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 {}]
            }
if 0 {

    Window create notebook toplevel
    notebook widget tabs frame
    notebook widget main frame
    set tabs [notebook tabs]
}

            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
    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