2013-05-31  Andreas Kupries  <andreask@activestate.com>

	* coroutine.tcl: Added Colin Macleod and http://wiki/21555
	* coro_auto.tcl: to the set of acknowledged contributors
	  and references for the module.

2013-05-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* coro_auto.tcl: Replaced uses of 'namespace current' in the wrap_
	* coro_auto.man: commands with a hardwired namespace name. As the
	  wrappers get renamed into different namespaces (:: and
	  ::tcl::chan) the result of 'namespace current' points to the
	  wrong namespace, causing the commands to miss the renamed
	  builtins, and fail. Bumped version to 1.1.1
	* pkgIndex.tcl: Updated version numbers.

2013-03-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* coroutine.man: Renamed, clashes with Tcl core manpage.
	* tcllib_coroutine.man: New name.

2013-02-08  Andreas Kupries  <andreask@activestate.com>

	* coroutine.man: Fixed missing short package title.
	* coro_auto.man: Ditto.

2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.15 ========================
	*

2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.14 ========================
	*

2011-04-18  Andreas Kupries  <andreask@activestate.com>

	* coroutine.tcl: [Bug 3252952]: Fixed clash between ::coroutine
	* coroutine.man: builtin of Tcl 8.6, and the same-named ensemble
	  of the package. Moved package command ::coroutine to
	  ::coroutine::util. Bumped version to 1.1.

	* coro_auto.tcl: [Bug 3252952]: Updated user of package coroutine
	* coro_auto.man: to the new command name. Bumped version to 1.1.

	* pkgIndex.tcl: Updated version numbers.

2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.13 ========================
	*

2010-08-17  Andreas Kupries  <andreask@activestate.com>

	* coroutine.man: Added package documentation.
	* coro_auto.man:

2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	*
	* Released and tagged Tcllib 1.12 ========================
	*

2009-11-10  Andreas Kupries  <andreask@activestate.com>

	* New module 'coroutine' providing to coroutine utility packages
	  for easier use of channel operations. These packages are for Tcl
	  8.6+.

[comment {-*- tcl -*- doctools manpage}]
[vset CORO_AUTO_VERSION 1.1.3]
[manpage_begin coroutine::auto n [vset CORO_AUTO_VERSION]]
[keywords after]
[keywords channel]
[keywords coroutine]
[keywords events]
[keywords exit]
[keywords gets]
[keywords global]
[keywords {green threads}]
[keywords read]
[keywords threads]
[keywords update]
[keywords vwait]
[copyright {2010-2014 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[moddesc   {Coroutine utilities}]
[category  Coroutine]
[titledesc {Automatic event and IO coroutine awareness}]
[require Tcl 8.6]
[require coroutine::auto [vset CORO_AUTO_VERSION]]
[require coroutine 1.1]
[description]

The [package coroutine::auto] package provides no commands or other
directly visible functionality.

Built on top of the package [package coroutine], it intercepts various
builtin commands of the Tcl core to make any code using them
coroutine-oblivious, i.e. able to run inside and outside of a
coroutine without changes.

[para] The commands so affected by this package are
[list_begin definitions]
[def [cmd after]]
[def [cmd exit]]
[def [cmd gets]]
[def [cmd global]]
[def [cmd read]]
[def [cmd update]]
[def [cmd vwait]]
[list_end]

[vset CATEGORY coroutine]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

## -- Tcl Module -- -*- tcl -*-
# # ## ### ##### ######## #############

# @@ Meta Begin
# Package coroutine::auto 1.1.2
# Meta platform        tcl
# Meta require         {Tcl 8.6}
# Meta require         {coroutine 1.1}
# Meta license         BSD
# Meta as::author      {Andreas Kupries}
# Meta as::origin      http://wiki.tcl.tk/21555
# Meta summary         Coroutine Event and Channel Support
# Meta description     Built on top of coroutine, this
# Meta description     package intercepts various builtin
# Meta description     commands to make the code using them
# Meta description     coroutine-oblivious, i.e. able to run
# Meta description     inside and outside of a coroutine
# Meta description     without changes.
# @@ Meta End

# Copyright (c) 2009-2014 Andreas Kupries

## $Id: coro_auto.tcl,v 1.3 2011/11/17 08:00:45 andreas_kupries Exp $
# # ## ### ##### ######## #############
## Requisites, and ensemble setup.

package require Tcl 8.6
package require coroutine

namespace eval ::coroutine::auto {}

# # ## ### ##### ######## #############
## API implementations. Uses the coroutine commands where
## possible.

proc ::coroutine::auto::wrap_global {args} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_global {*}$args
    }

    tailcall ::coroutine::util::global {*}$args
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_after {delay args} {
    if {
	([info coroutine] eq {}) ||
	([llength $args] > 0)
    } {
	# We use the core builtin when called from either outside of a
	# coroutine, or for an asynchronous delay.

	tailcall ::coroutine::auto::core_after $delay {*}$args
    }

    # Inside of coroutine, and synchronous delay (args == "").
    tailcall ::coroutine::util::after $delay
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_exit {{status 0}} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_exit $status
    }

    tailcall ::coroutine::util::exit $status
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_vwait {varname} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_vwait $varname
    }

    tailcall ::coroutine::util::vwait $varname
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_update {{what {}}} {
    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_update {*}$what
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {$what eq "idletasks"} {
        after idle [info coroutine]
    } elseif {$what ne {}} {
        # Force proper error message for bad call.
        tailcall ::coroutine::auto::core_update $what
    } else {
        after 0 [info coroutine]
    }
    yield
    return
} 

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_gets {args} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_gets {*}$args
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {[llength $args] == 2} {
	# gets CHAN VARNAME
	lassign $args chan varname
        upvar 1 $varname line
    } elseif {[llength $args] == 1} {
	# gets CHAN
	lassign $args chan
    } else {
	# not enough, or too many arguments (0, or > 2): Calling the
	# builtin gets command with the bogus arguments gives us the
	# necessary error with the proper message.
	tailcall ::coroutine::auto::core_gets {*}$args
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During 

    while {1} {
        set blocking [::chan configure $chan -blocking]
        ::chan configure $chan -blocking 0

	try {
	    set result [::coroutine::auto::core_gets $chan line]
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts
	}

	if {[::chan blocked $chan]} {
            ::chan event $chan readable [list [info coroutine]]
            yield
            ::chan event $chan readable {}
        } else {
            ::chan configure $chan -blocking $blocking

            if {[llength $args] == 2} {
                return $result
            } else {
                return $line
            }
        }
    }
}

# - -- --- ----- -------- -------------

proc ::coroutine::auto::wrap_read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN
    # * read               CHAN ?n?

    if {[info coroutine] eq {}} {
	tailcall ::coroutine::auto::core_read {*}$args
    }

    # This is a full re-implementation of mode (1), because the
    # coroutine-aware part uses the builtin itself for some
    # functionality, and this part cannot be taken as is.

    if {[llength $args] > 2} {
	# Calling the builtin read command with the bogus arguments
	# gives us the necessary error with the proper message.
	::coroutine::auto::core_read {*}$args
	return
    }

    set total Inf ; # Number of characters to read. Here: Until eof.
    set chop  no  ; # Boolean flag. Determines if we have to trim a
    #               # \n from the end of the read string.

    if {[llength $args] == 2} {
	lassign $args a b
	if {$a eq "-nonewline"} {
	    set chan $b
	    set chop yes
	} else {
	    lassign $args chan total
	}
    } else {
	lassign $args chan
    }

    # Run the read loop. Yield to the event loop where
    # necessary. Differentiate between loop until eof, and loop until
    # n characters have been read (or eof reached).

    set buf {}

    if {$total eq "Inf"} {
	# Loop until eof.

	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		set result [::coroutine::auto::core_read $chan]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		}
	    }
	}
    } else {
	# Loop until total characters have been read, or eof found,
	# whichever is first.

	set left $total
	while {1} {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    try {
		set result [::coroutine::auto::core_read $chan $left]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    } else {
		::chan configure $chan -blocking $blocking
		append buf $result
		incr   left -[string length $result]

		if {[::chan eof $chan]} {
		    ::chan close $chan
		    break
		} elseif {!$left} {
		    break
		}
	    }
	}
    }

    if {$chop && [string index $buf end] eq "\n"} {
	set buf [string range $buf 0 end-1]
    }

    return $buf
}

# # ## ### ##### ######## #############
## Internal. Setup.

::apply {{} {
    # Replaces the builtin commands with coroutine-aware
    # counterparts. We cannot use the coroutine commands directly,
    # because the replacements have to use the saved builtin commands
    # when called outside of a coroutine. And some (read, gets,
    # update) even need full re-implementations, as they use the
    # builtin command they replace themselves to implement their
    # functionality.

    foreach cmd {
	global
	exit
	after
	vwait
	update
    } {
	rename ::$cmd [namespace current]::core_$cmd
	rename [namespace current]::wrap_$cmd ::$cmd
    }

    foreach cmd {
	gets
	read
    } {
	rename ::tcl::chan::$cmd [namespace current]::core_$cmd
	rename [namespace current]::wrap_$cmd ::tcl::chan::$cmd
    }

    return
} ::coroutine::auto}

# # ## ### ##### ######## #############
## Ready

package provide coroutine::auto 1.1.3
return

# -*- tcl -*- aes.pcx
# Syntax of the commands provided by package coroutine.
#
# For use by TclDevKit's static syntax checker (v4.1+).
# See http://www.activestate.com/solutions/tcl/
# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
# for the specification of the format of the code in this file.
#

package require pcx
pcx::register coroutine
pcx::tcldep   1 needs tcl 8.6

namespace eval ::coroutine {}

pcx::check 1 std ::coroutine::util::create \
    {checkSimpleArgs 0 -1 {
	checkWord
    }}
pcx::check 1 std ::coroutine::util::global \
    {checkSimpleArgs 0 -1 {
	checkVarDecl
    }}
pcx::check 1 std ::coroutine::util::after \
    {checkSimpleArgs 1 1 {
	checkInt
    }}
pcx::check 1 std ::coroutine::util::exit \
    {checkSimpleArgs 0 1 {
	checkInt
    }}
pcx::check 1 std ::coroutine::util::vwait \
    {checkSimpleArgs 1 1 {
	checkVarName
    }}
pcx::check 1 std ::coroutine::util::await \
    {checkSimpleArgs 0 -1 {
	checkVarName
    }}
pcx::check 1 std ::coroutine::util::update \
    {checkSimpleArgs 0 1 {
	{checkKeyword 0 {idletasks}}
    }}
pcx::check 1 std ::coroutine::util::gets \
    {checkSimpleArgs 1 2 {
	checkChannelID
	checkVarNameWrite
    }}
pcx::check 1 std ::coroutine::util::read \
    {coreTcl::checkReadCmd 0}

# Initialization via pcx::init.
# Use a ::coroutine::init procedure for non-standard initialization.
pcx::complete

## -- Tcl Module -- -*- tcl -*-
# # ## ### ##### ######## #############

# @@ Meta Begin
# Package coroutine 1.2
# Meta platform        tcl
# Meta require         {Tcl 8.6}
# Meta license         BSD
# Meta as::author      {Andreas Kupries}
# Meta as::author      {Colin Macleod}
# Meta as::author      {Colin McCormack}
# Meta as::author      {Donal Fellows}
# Meta as::author      {Kevin Kenny}
# Meta as::author      {Neil Madden}
# Meta as::author      {Peter Spjuth}
# Meta as::origin      http://wiki.tcl.tk/21555
# Meta summary         Coroutine Event and Channel Support
# Meta description     This package provides coroutine-aware
# Meta description     implementations of various event- and
# Meta description     channel related commands. It can be
# Meta description     in multiple modes: (1) Call the
# Meta description     commands through their ensemble, in
# Meta description     code which is explicitly written for
# Meta description     use within coroutines. (2) Import
# Meta description     the commands into a namespace, either
# Meta description     directly, or through 'namespace path'.
# Meta description     This allows the use from within code
# Meta description     which is not coroutine-aware per se
# Meta description     and restricted to specific namespaces.
# Meta description     A more agressive form of making code
# Meta description     coroutine-oblivious than (2) above is
# Meta description     available through the package
# Meta description     coroutine::auto, which intercepts
# Meta description     the relevant builtin commands and changes
# Meta description     their implementation dependending on the
# Meta description     context they are run in, i.e. inside or
# Meta description     outside of a coroutine.
# @@ Meta End

# Copyright (c) 2009,2014-2015 Andreas Kupries
# Copyright (c) 2009 Colin Macleod
# Copyright (c) 2009 Colin McCormack
# Copyright (c) 2009 Donal Fellows
# Copyright (c) 2009 Kevin Kenny
# Copyright (c) 2009 Neil Madden
# Copyright (c) 2009 Peter Spjuth

## $Id: coroutine.tcl,v 1.2 2011/04/18 20:23:58 andreas_kupries Exp $
# # ## ### ##### ######## #############
## Requisites, and ensemble setup.

package require Tcl 8.6

namespace eval ::coroutine::util {

    namespace export \
	create global after exit vwait update gets read await

    namespace ensemble create
}

# # ## ### ##### ######## #############
## API. Spawn coroutines, automatic naming
##      (like thread::create).

proc ::coroutine::util::create {args} {
    ::coroutine [ID] {*}$args
}

# # ## ### ##### ######## #############
## API.
#
# global (coroutine globals (like thread global storage))
# after  (synchronous).
# exit
# update ?idletasks? [1]
# vwait
# gets               [1]
# read               [1]
#
# [1] These commands call on their builtin counterparts to get some of
#     their functionality (like proper error messages for syntax errors).

# - -- --- ----- -------- -------------

proc ::coroutine::util::global {args} {
    # Frame #1 is the coroutine-specific stack frame at its
    # bottom. Variables there are out of view of the main code, and
    # can be made visible in the entire coroutine underneath.

    set cmd [list upvar "#1"]
    foreach var $args {
	lappend cmd $var $var
    }
    tailcall {*}$cmd
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::after {delay} {
    ::after $delay [info coroutine]
    yield
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::exit {{status 0}} {
    return -level [info level] $status
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::vwait {varname} {
    upvar 1 $varname var
    set callback [list [namespace current]::VWaitTrace [info coroutine]]

    # Step 1. Wait for a write to the variable, using a trace to
    # restart the coroutine

    trace add    variable var write $callback
    yield
    trace remove variable var write $callback

    # Step 2. To prevent the next section of the coroutine code from
    # running entirely within the variable trace (*) we now use an
    # idle handler to defer it until the trace is definitely
    # done. This trick by Peter Spjuth.
    #
    # (*) At this point we are in VWaitTrace running the coroutine.

    ::after idle [info coroutine]
    yield
    return
}

proc ::coroutine::util::VWaitTrace {coroutine args} {
    $coroutine
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::update {{what {}}} {
    if {$what eq "idletasks"} {
        ::after idle [info coroutine]
    } elseif {$what ne {}} {
        # Force proper error message for bad call.
        tailcall ::tcl::update $what
    } else {
        ::after 0 [info coroutine]
    }
    yield
    return
}

# - -- --- ----- -------- -------------

proc ::coroutine::util::gets {args} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    if {[llength $args] == 2} {
	# gets CHAN VARNAME
	lassign $args chan varname
        upvar 1 $varname line
    } elseif {[llength $args] == 1} {
	# gets CHAN
	lassign $args chan
    } else {
	# not enough, or too many arguments (0, or > 2): Calling the
	# builtin gets command with the bogus arguments gives us the
	# necessary error with the proper message.
	tailcall ::chan gets {*}$args
    }

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During
    set blocking [::chan configure $chan -blocking]
    while {1} {
        ::chan configure $chan -blocking 0

	try {
	    set result [::chan gets $chan line]
	} on error {result opts} {
            ::chan configure $chan -blocking $blocking
            return -code $result -options $opts
	}

	if {[::chan blocked $chan]} {
            ::chan event $chan readable [list [info coroutine]]
            yield
            ::chan event $chan readable {}
        } else {
            ::chan configure $chan -blocking $blocking

            if {[llength $args] == 2} {
                return $result
            } else {
                return $line
            }
        }
    }
}


proc ::coroutine::util::gets_safety {chan limit varname {timeout 120000}} {
    # Process arguments.
    # Acceptable syntax:
    # * gets CHAN ?VARNAME?

    # Loop until we have a complete line. Yield to the event loop
    # where necessary. During
    set blocking [::chan configure $chan -blocking]
    upvar 1 $varname line
    try {
	while {1} {
	    ::chan configure $chan -blocking 0
	    if {[::chan pending input $chan]>= $limit} {
		error {Too many notes, Mozart. Too many notes}
	    }
	    try {
		set result [::chan gets $chan line]
	    } on error {result opts} {
		return -code $result -options $opts
	    }

	    if {[::chan blocked $chan]} {
	  set timeoutevent [::after $timeout [list [info coroutine] timeout]]
		::chan event $chan readable [list [info coroutine] readable]
		set event [yield]
		if {$event eq "timeout"} {
		  error "Connection Timed Out"
		}
		::after cancel $timeoutevent
		::chan event $chan readable {}
	    } else {
		return $result
	    }
	}
    } finally {
        ::chan configure $chan -blocking $blocking
    }
}



# - -- --- ----- -------- -------------

proc ::coroutine::util::read {args} {
    # Process arguments.
    # Acceptable syntax:
    # * read ?-nonewline ? CHAN
    # * read               CHAN ?n?

    if {[llength $args] > 2} {
	# Calling the builtin read command with the bogus arguments
	# gives us the necessary error with the proper message.
	::chan read {*}$args
	return
    }

    set total Inf ; # Number of characters to read. Here: Until eof.
    set chop  no  ; # Boolean flag. Determines if we have to trim a
    #               # \n from the end of the read string.

    if {[llength $args] == 2} {
	lassign $args a b
	if {$a eq "-nonewline"} {
	    set chan $b
	    set chop yes
	} else {
	    lassign $args chan total
	}
    } else {
	lassign $args chan
    }

    # Run the read loop. Yield to the event loop where
    # necessary. Differentiate between loop until eof, and loop until
    # n characters have been read (or eof reached).

    set buf {}

    if {$total eq "Inf"} {
	# Loop until eof.

	while 1 {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0
	    if {[::chan eof $chan]} {
		break
	    } elseif {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    }

	    try {
		set result [::chan read $chan]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    } finally {
		::chan configure $chan -blocking $blocking
	    }
	    append buf $result
	}
    } else {
	# Loop until total characters have been read, or eof found,
	# whichever is first.

	set left $total
	while 1 {
	    set blocking [::chan configure $chan -blocking]
	    ::chan configure $chan -blocking 0

	    if {[::chan eof $chan]} {
		break
	    } elseif {[::chan blocked $chan]} {
		::chan event $chan readable [list [info coroutine]]
		yield
		::chan event $chan readable {}
	    }

	    try {
		set result [::chan read $chan $left]
	    } on error {result opts} {
		::chan configure $chan -blocking $blocking
		return -code $result -options $opts
	    } finally {
		::chan configure $chan -blocking $blocking
	    }

	    append buf $result
	    incr left -[string length $result]
	    if {!$left} {
		break
	    }
	}
    }

    if {$chop && [string index $buf end] eq "\n"} {
	set buf [string range $buf 0 end-1]
    }

    return $buf
}

# - -- --- ----- -------- -------------
## This goes beyond the builtin vwait, wait for multiple variables,
## result is the name of the variable which was written.
## This code mainly by Neil Madden.

proc ::coroutine::util::await args {
    set callback [list [namespace current]::AWaitSignal [info coroutine]]

    # Step 1. Wait for a write to any of the variable, using a trace
    # to restart the coroutine, and the variable written to is
    # propagated into it.

    foreach varName $args {
        upvar 1 $varName var
        trace add variable var write $callback
    }

    set choice [yield]

    foreach varName $args {
	#checker exclude warnShadowVar
        upvar 1 $varName var
        trace remove variable var write $callback
    }

    # Step 2. To prevent the next section of the coroutine code from
    # running entirely within the variable trace (*) we now use an
    # idle handler to defer it until the trace is definitely
    # done. This trick by Peter Spjuth.
    #
    # (*) At this point we are in AWaitSignal running the coroutine.

    ::after idle [info coroutine]
    yield

    return $choice
}

proc ::coroutine::util::AWaitSignal {coroutine var index op} {
    if {$op ne "write"} { return }
    set fullvar $var
    if {$index ne ""} { append fullvar ($index) }
    $coroutine $fullvar
}

# # ## ### ##### ######## #############
## Internal (package specific) commands

proc ::coroutine::util::ID {} {
    variable counter
    return [namespace current]::C[incr counter]
}

# # ## ### ##### ######## #############
## Internal (package specific) state

namespace eval ::coroutine::util {
    #checker exclude warnShadowVar
    variable counter 0
}

# # ## ### ##### ######## #############
## Ready
package provide coroutine 1.2
return

# -*- tcl -*- coroutine::auto.pcx
# Syntax of the commands provided by package coroutine::auto.
#
# No commands in this package. The point of the package is to overlay
# existing builtin commands with syntactically and semantically
# equivalent variants which behave propery inside and outside of
# coroutines.
#
# For use by TclDevKit's static syntax checker (v4.1+).
# See http://www.activestate.com/solutions/tcl/
# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
# for the specification of the format of the code in this file.
#

package require pcx
pcx::register coroutine::auto
pcx::tcldep   1 needs tcl 8.6

namespace eval ::coroutine {}

# Initialization via pcx::init.
# Use a ::coroutine::init procedure for non-standard initialization.
pcx::complete

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded coroutine       1.2   [list source [file join $dir coroutine.tcl]]
package ifneeded coroutine::auto 1.1.3 [list source [file join $dir coro_auto.tcl]]

[comment {-*- tcl -*- doctools manpage}]
[vset CORO_VERSION 1.2]
[manpage_begin coroutine n [vset CORO_VERSION]]
[keywords after]
[keywords channel]
[keywords coroutine]
[keywords events]
[keywords exit]
[keywords gets]
[keywords global]
[keywords {green threads}]
[keywords read]
[keywords threads]
[keywords update]
[keywords vwait]
[copyright {2010-2015 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[moddesc   {Coroutine utilities}]
[category  Coroutine]
[titledesc {Coroutine based event and IO handling}]
[require Tcl 8.6]
[require coroutine [vset CORO_VERSION]]
[description]

The [package coroutine] package provides coroutine-aware
implementations of various event- and channel related commands. It can
be in multiple modes:

[list_begin enumerated]

[enum] Call the commands through their ensemble, in code which is
explicitly written for use within coroutines.

[enum] Import the commands into a namespace, either directly, or
through [cmd {namespace path}]. This allows the use from within code
which is not coroutine-aware per se and restricted to specific
namespaces.

[list_end]

A more agressive form of making code coroutine-oblivious than point 2
above is available through the package [package coroutine::auto],
which intercepts the relevant builtin commands and changes their
implementation dependending on the context they are run in, i.e.
inside or outside of a coroutine.

[section API]

All the commands listed below are synchronous with respect to the
coroutine invoking them, i.e. this coroutine blocks until the result
is available. The overall eventloop is not blocked however.

[list_begin definitions]

[call [cmd {coroutine::util after}] [arg delay]]

This command delays the coroutine invoking it by [arg delay]
milliseconds.

[call [cmd {coroutine::util await}] [arg varname]...]

This command is an extension form of the [cmd {coroutine::util vwait}]
command (see below) which waits on a write to one of many named
namespace variables.

[call [cmd {coroutine::util create}] [arg arg]...]

This command creates a new coroutine with an automatically assigned
name and causes it to run the code specified by the arguments.

[call [cmd {coroutine::util exit}] [opt [arg status]]]

This command exits the current coroutine, causing it to return
[arg status]. If no status was specified the default [arg 0] is
returned.

[call [cmd {coroutine::util gets}] [arg chan] [opt [arg varname]]]

This command reads a line from the channel [arg chan] and returns it
either as its result, or, if a [arg varname] was specified, writes it
to the named variable and returns the number of characters read.

[call [cmd {coroutine::util gets_safety}] [arg chan] [arg limit] [arg varname]]

This command reads a line from the channel [arg chan] up to size [arg limit]
and stores the result in [arg varname]. Of [arg limit] is reached before the
set first newline, an error is thrown. The command returns the number of
characters read.

[call [cmd {coroutine::util global}] [arg varname]...]

This command imports the named global variables of the coroutine into
the current scope. From the technical point of view these variables
reside in level [const #1] of the Tcl stack. I.e. these are not the
regular global variable in to the global namespace, and each coroutine
can have their own set, independent of all others.

[call [cmd {coroutine::util read}] [option -nonewline] [arg chan] [opt [arg n]]]

This command reads [arg n] characters from the channel [arg chan] and
returns them as its result. If [arg n] is not specified the command
will read the channel until EOF is reached.

[call [cmd {coroutine::util update}] [opt [const idletasks]]]

This command causes the coroutine invoking it to run pending events or
idle handlers before proceeding.

[call [cmd {coroutine::util vwait}] [arg varname]]

This command causes the coroutine calling it to wait for a write to
the named namespace variable [arg varname].

[list_end]

[vset CATEGORY coroutine]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 2.1]
[manpage_begin cron n [vset PACKAGE_VERSION]]
[keywords {cron}]
[keywords {odie}]
[copyright {2016-2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {cron}]
[titledesc {Tool for automating the period callback of commands}]
[category  System]
[require Tcl 8.6]
[require cron [opt [vset PACKAGE_VERSION]]]
[description]
[para]

The [package cron] package provides a Pure-tcl set of tools to allow
programs to schedule tasks to occur at regular intervals. Rather than
force each task to issue it's own call to the event loop, the cron
system mimics the cron utility in Unix: on task periodically checks to
see if something is to be done, and issues all commands for a given
time step at once.
[para]
Changes in version 2.0
[para]
While cron was originally designed to handle time scales > 1 second, the
latest version's internal understand time granularity down to the millisecond,
making it easier to integrate with other timed events.

Version 2.0 also understands how to properly integrate coroutines and objects.
It also adds a facility for an external (or script driven) clock. Note that vwait style events
won't work very well with an external clock.

[section Commands]
[list_begin definitions]

[call [cmd ::cron::at] [arg ?processname?] [arg timecode] [arg command]]

This command registers a [arg command] to be called at the time specified by [arg timecode].
If [arg timecode] is expressed as an integer, the timecode is assumed to be in unixtime. All
other inputs will be interpreted by [cmd {clock scan}] and converted to unix time.
This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

If [arg processname] is not given, one is generated and returned by the command.

[example_begin]
::cron::at start_coffee {Tomorrow at 9:00am}  {remote::exec::coffeepot power on}
::cron::at shutdown_coffee {Tomorrow at 12:00pm}  {remote::exec::coffeepot power off}
[example_end]

[call [cmd ::cron::cancel] [arg processname]]

This command unregisters the process [arg processname] and cancels any pending commands.
Note: processname can be a process created by either [cmd ::cron::at] or [cmd ::cron::every].

[example_begin]
::cron::cancel check_mail
[example_end]

[call [cmd ::cron::every] [arg processname] [arg frequency] [arg command]]

This command registers a [arg command] to be called at the interval of [arg frequency].
[arg frequency] is given in seconds. This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

[example_begin]
::cron::every check_mail 900  ::imap_client::check_mail
::cron::every backup_db  3600 {::backup_procedure ::mydb}
[example_end]

[call [cmd ::cron::in] [arg ?processname?] [arg timecode] [arg command]]

This command registers a [arg command] to be called after a delay of time specified by [arg timecode].
[arg timecode] is expressed as an seconds.
This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

If [arg processname] is not given, one is generated and returned by the command.

[call [cmd ::cron::object_coroutine] [arg object] [arg coroutine] [arg ?info?]]

This command registers a [arg coroutine], associated with [arg object] to be called
given the parameters of [arg info]. If now parameters are given, the coroutine is assumed
to be an idle task which will self-terminate. [arg info] can be given in any form compadible with
[cmd {::cron::task set}]

[call [cmd ::cron::sleep] [arg milliseconds]]

When run within a coroutine, this command will register the coroutine for a callback
at the appointed time, and immediately yield.
[para]
If the ::cron::time variable is > 0 this command will advance the internal time,
100ms at a time.
[para]
In all other cases this command will generate a fictious variable, generate an
after call, and vwait the variable:
[example {
set eventid [incr ::cron::eventcount]
set var ::cron::event_#$eventid
set $var 0
::after $ms "set $var 1"
::vwait $var
::unset $var
}]
[para]
Usage:
[example_begin]
::cron::sleep 250
[example_end]

[call [cmd {::cron::task delete}] [arg process]]
Delete the process specified the [arg process]

[call [cmd {::cron::task exists}] [arg process]]
Returns true if [arg process] is registered with cron.

[call [cmd {::cron::task info}] [arg process]]
Returns a dict describing [arg process]. See [cmd {::cron::task set}] for a description of the options.

[call [cmd {::cron::task set}] [arg process] [arg field] [arg value] [arg ?field...?] [arg ?value...?]]
[para]
If [arg process] does not exist, it is created. Options Include:
[list_begin definitions]
[cmd command]
If [cmd coroutine] is black, a global command which implements this process. If [cmd coroutine] is not
black, the command to invoke to create or recreate the coroutine.
[cmd coroutine]
The name of the coroutine (if any) which implements this process.
[cmd frequency]
If -1, this process is terminated after the next event. If 0 this process should be called during every
idle event. If positive, this process should generate events periodically. The frequency is an interger number
of milleseconds between events.

[cmd object]
The object associated with this process or coroutine.
[cmd scheduled]
If non-zero, the absolute time from the epoch (in milleseconds) that this process will trigger an event.
If zero, and the [cmd frequency] is also zero, this process is called every idle loop.
[cmd running]
A boolean flag. If true it indicates the process never returned or yielded during the event loop,
and will not be called again until it does so.
[list_end]
[call [cmd ::cron::wake] [arg ?who?]]

Wake up cron, and arrange for its event loop to be run during the next Idle cycle.

[example_begin]
::cron::wake {I just did something important}
[example_end]
[list_end]
[para]
Several utility commands are provided that are used internally within cron and for
testing cron, but may or may not be useful in the general cases.
[list_begin definitions]

[call [cmd ::cron::clock_step] [arg milleseconds]]
[para]
Return a clock time absolute to the epoch which falls on the next
border between one second and the next for the value of [arg milleseconds]

[call [cmd ::cron::clock_delay] [arg milleseconds]]
[para]
Return a clock time absolute to the epoch which falls on the next
border between one second and the next [arg milleseconds] in the future.

[call [cmd ::cron::clock_sleep] [arg seconds] [arg ?offset?]]
[para]
Return a clock time absolute to the epoch which falls exactly [arg seconds] in
the future. If offset is given it may be positive or negative, and will shift
the final time to before or after the second would flip.

[call [cmd ::cron::clock_set] [arg newtime]]
[para]
Sets the internal clock for cron. This command will advance the time in 100ms
increment, triggering events, until the internal time catches up with [arg newtime].
[para]
[arg newtime] is expressed in absolute milleseconds since the beginning of the epoch.


[list_end]
[para]
[vset CATEGORY odie]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

###
# This file implements a process table
# Instead of having individual components try to maintain their own timers
# we centrally manage how often tasks should be kicked off here.
###
#
# Author: Sean Woods (for T&E Solutions)
package require Tcl 8.6 ;# See coroutine
package require coroutine
package require dicttool
::namespace eval ::cron {}

proc ::cron::task {command args} {
  if {$::cron::trace > 1} {
    puts [list ::cron::task $command $args]
  }
  variable processTable
  switch $command {
    TEMPLATE {
      return [list object {} lastevent 0 lastrun 0 err 0 result {} \
        running 0 coroutine {} scheduled 0 frequency 0 command {}]
    }
    delete {
      unset -nocomplain ::cron::processTable([lindex $args 0])
    }
    exists {
      return [::info exists ::cron::processTable([lindex $args 0])]
    }
    info {
      set process [lindex $args 0]
      if {![::info exists ::cron::processTable($process)]} {
        error "Process $process does not exist"
      }
      return $::cron::processTable($process)
    }
    frequency {
      set process [lindex $args 0]
      set time [lindex $args 1]
      if {![info exists ::cron::processTable($process)]} return
      dict with ::cron::processTable($process) {
        set now [clock_step [current_time]]
        set frequency [expr {0+$time}]
        if {$scheduled>($now+$time)} {
          dict set ::cron::processTable($process) scheduled [expr {$now+$time}]
        }
      }
    }
    sleep {
      set process [lindex $args 0]
      set time [lindex $args 1]
      if {![info exists ::cron::processTable($process)]} return
      dict with ::cron::processTable($process) {
        set now [clock_step [current_time]]
        set frequency 0
        set scheduled [expr {$now+$time}]
      }
    }
    create -
    set {
      set process [lindex $args 0]
      if {![::info exists ::cron::processTable($process)]} {
        set ::cron::processTable($process) [task TEMPLATE]
      }
      if {[llength $args]==2} {
        foreach {field value} [lindex $args 1] {
          dict set ::cron::processTable($process) $field $value
        }
      } else {
        foreach {field value} [lrange $args 1 end] {
          dict set ::cron::processTable($process) $field $value
        }
      }
    }
  }
}

proc ::cron::at args {
  if {$::cron::trace > 1} {
    puts [list ::cron::at $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args timecode command
    }
    3 {
      lassign $args process timecode command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  variable processTable
  if {[string is integer -strict $timecode]} {
    set scheduled [expr {$timecode*1000}]
  } else {
    set scheduled [expr {[clock scan $timecode]*1000}]
  }
  ::cron::task set $process \
    frequency -1 \
    command $command \
    scheduled $scheduled \
    coroutine {}

  if {$::cron::trace > 1} {
    puts [list ::cron::task info $process - > [::cron::task info $process]]
  }
  ::cron::wake NEW
  return $process
}

proc ::cron::idle args {
  if {$::cron::trace > 1} {
    puts [list ::cron::idle $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args command
    }
    3 {
      lassign $args process command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  ::cron::task set $process \
    scheduled 0 \
    frequency 0 \
    command $command
  ::cron::wake NEW
  return $process
}

proc ::cron::in args {
  if {$::cron::trace > 1} {
    puts [list ::cron::in $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args timecode command
    }
    3 {
      lassign $args process timecode command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  set now [clock_step [current_time]]
  set scheduled [expr {$timecode*1000+$now}]
  ::cron::task set $process \
    frequency -1 \
    command $command \
    scheduled $scheduled
  ::cron::wake NEW
  return $process
}

proc ::cron::cancel {process} {
  if {$::cron::trace > 1} {
    puts [list ::cron::cancel $process]
  }
  ::cron::task delete $process
}

###
# topic: 0776dccd7e84530fa6412e507c02487c
###
proc ::cron::every {process frequency command} {
  if {$::cron::trace > 1} {
    puts [list ::cron::every $process $frequency $command]
  }
  variable processTable
  set mnow [clock_step [current_time]]
  set frequency [expr {$frequency*1000}]
  ::cron::task set $process \
    frequency $frequency \
    command $command \
    scheduled [expr {$mnow + $frequency}]
  ::cron::wake NEW
}


proc ::cron::object_coroutine {objname coroutine {info {}}} {
  if {$::cron::trace > 1} {
    puts [list ::cron::object_coroutine $objname $coroutine $info]
  }
  task set $coroutine \
    {*}$info \
    object $objname \
    coroutine $coroutine

  return $coroutine
}

# Notification that an object has been destroyed, and that
# it should give up any toys associated with events
proc ::cron::object_destroy {objname} {
  if {$::cron::trace > 1} {
    puts [list ::cron::object_destroy $objname]
  }
  variable processTable
  set dat [array get processTable]
  foreach {process info} $dat {
    if {[dict exists $info object] && [dict get $info object] eq $objname} {
      unset -nocomplain processTable($process)
    }
  }
}

###
# topic: 97015814408714af539f35856f85bce6
###
proc ::cron::run process {
  variable processTable
  set mnow [clock_step [current_time]]
  if {[dict exists processTable($process) scheduled] && [dict exists processTable($process) scheduled]>0} {
    dict set processTable($process) scheduled [expr {$mnow-1000}]
  } else {
    dict set processTable($process) lastrun 0
  }
  ::cron::wake PROCESS
}

proc ::cron::clock_step timecode {
  return [expr {$timecode-($timecode%1000)}]
}

proc ::cron::clock_delay {delay} {
  set now [current_time]
  set then [clock_step [expr {$delay+$now}]]
  return [expr {$then-$now}]
}

# Sleep for X seconds, wake up at the top
proc ::cron::clock_sleep {{sec 1} {offset 0}} {
  set now [current_time]
  set delay [expr {[clock_delay [expr {$sec*1000}]]+$offset}]
  sleep $delay
}

proc ::cron::current_time {} {
  if {$::cron::time < 0} {
    return [clock milliseconds]
  }
  return $::cron::time
}

proc ::cron::clock_set newtime {
  variable time
  for {} {$time < $newtime} {incr time 100} {
    uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
  }
  set time $newtime
  uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}

proc ::cron::once_in_a_while body {
  set script {set _eventid_ $::cron::current_event}
  append script $body
  # Add a safety to allow this while to only execute once per call
  append script {if {$_eventid_==$::cron::current_event} yield}
  uplevel 1 [list while 1 $script]
}

proc ::cron::sleep ms {
  if {$::cron::trace > 1} {
    puts [list ::cron::sleep $ms [info coroutine]]
  }

  set coro [info coroutine]
  # When the clock is being externally
  # controlled, advance the clock when
  # a sleep is called
  variable time
  if {$time >= 0 && $coro eq {}} {
    ::cron::clock_set [expr {$time+$ms}]
    return
  }
  if {$coro ne {}} {
    set mnow [current_time]
    set start $mnow
    set end [expr {$start+$ms}]
    set eventid $coro
    if {$::cron::trace} {
      puts "::cron::sleep $ms $coro"
    }
    # Mark as running
    task set $eventid scheduled $end coroutine $coro running 1
    ::cron::wake WAKE_IN_CORO
    yield 2
    while {$end >= $mnow} {
      if {$::cron::trace} {
        puts "::cron::sleep $ms $coro (loop)"
      }
      set mnow [current_time]
      yield 2
    }
    # Mark as not running to resume idle computation
    task set $eventid running 0
    if {$::cron::trace} {
      puts "/::cron::sleep $ms $coro"
    }
  } else {
    set eventid [incr ::cron::eventcount]
    set var ::cron::event_#$eventid
    set $var 0
    if {$::cron::trace} {
      puts "::cron::sleep $ms $eventid waiting for $var"
      ::after $ms "set $var 1 ; puts \"::cron::sleep - $eventid - FIRED\""
    } else {
      ::after $ms "set $var 1"
    }
    ::vwait $var
    if {$::cron::trace} {
      puts "/::cron::sleep $ms $eventid"
    }
    unset $var
  }
}

###
# topic: 21de7bb8db019f3a2fd5a6ae9b38fd55
# description:
#    Called once per second, and timed to ensure
#    we run in roughly realtime
###
proc ::cron::runTasksCoro {} {
  ###
  # Do this forever
  ###
  variable processTable
  variable processing
  variable all_coroutines
  variable coroutine_object
  variable coroutine_busy
  variable nextevent
  variable current_event

  while 1 {
    incr current_event
    set lastevent 0
    set now [current_time]
    # Wake me up in 5 minute intervals, just out of principle
    set nextevent [expr {$now-($now % 300000) + 300000}]
    set next_idle_event [expr {$now+250}]
    if {$::cron::trace > 1} {
      puts [list CRON TASK RUNNER nextevent $nextevent]
    }
    ###
    # Determine what tasks to run this timestep
    ###
    set tasks {}
    set cancellist {}
    set nexttask {}

    foreach {process} [lsort -dictionary [array names processTable]] {
      dict with processTable($process) {
        if {$::cron::trace > 1} {
          puts [list CRON TASK RUNNER process $process frequency: $frequency scheduled: $scheduled]
        }
        if {$scheduled==0 && $frequency==0} {
          set lastrun $now
          set lastevent $now
          lappend tasks $process
        } else {
          if { $scheduled <= $now } {
            lappend tasks $process
            if { $frequency < 0 } {
              lappend cancellist $process
            } elseif {$frequency==0} {
              set scheduled 0
              if {$::cron::trace > 1} {
                puts [list CRON TASK RUNNER process $process demoted to idle]
              }
            } else {
              set scheduled [clock_step [expr {$frequency+$lastrun}]]
              if { $scheduled <= $now } {
                set scheduled [clock_step [expr {$frequency+$now}]]
              }
              if {$::cron::trace > 1} {
                puts [list CRON TASK RUNNER process $process rescheduled to $scheduled]
              }
            }
            set lastrun $now
          }
          set lastevent $now
        }
      }
    }
    foreach task $tasks {
      dict set processTable($task) lastrun $now
      if {[dict exists processTable($task) foreground] && [dict set processTable($task) foreground]} continue
      if {[dict exists processTable($task) running] && [dict set processTable($task) running]} continue
      if {$::cron::trace > 2} {
        puts [list RUNNING $task [task info $task]]
      }
      set coro [dict getnull $processTable($task) coroutine]
      dict set processTable($task) running 1
      set command [dict getnull $processTable($task) command]
      if {$command eq {} && $coro eq {}} {
        # Task has nothing to do. Slot it for destruction
        lappend cancellist $task
      } elseif {$coro ne {}} {
        if {[info command $coro] eq {}} {
          set object [dict get $processTable($task) object]
          # Trigger coroutine again if a command was given
          # If this coroutine is associated with an object, ensure
          # the object still exists before invoking its method
          if {$command eq {} || ($object ne {} && [info command $object] eq {})} {
            lappend cancellist $task
            dict set processTable($task) running 0
            continue
          }
          if {$::cron::trace} {
            puts [list RESTARTING $task - coroutine $coro - with $command]
          }
          ::coroutine $coro {*}$command
        }
        try $coro on return {} {
          # Terminate the coroutine
          lappend cancellist $task
        } on break {} {
          # Terminate the coroutine
          lappend cancellist $task
        } on error {errtxt errdat} {
          # Coroutine encountered an error
          lappend cancellist $task
          puts "ERROR $coro"
          set errorinfo [dict get $errdat -errorinfo]
          if {[info exists coroutine_object($coro)] && $coroutine_object($coro) ne {}} {
            catch {
            puts "OBJECT: $coroutine_object($coro)"
            puts "CLASS: [info object class $coroutine_object($coro)]"
            }
          }
          puts "$errtxt"
          puts ***
          puts $errorinfo
        } on continue {result opts} {
          # Ignore continue
          if { $result eq "done" } {
            lappend cancellist $task
          }
        } on ok {result opts} {
          if { $result eq "done" } {
            lappend cancellist $task
          }
        }
      } else {
        dict with processTable($task) {
          set err [catch {uplevel #0 $command} result errdat]
          if $err {
            puts "CRON TASK FAILURE:"
            puts "PROCESS: $task"
            puts $result
            puts ***
            puts [dict get $errdat -errorinfo]
          }
        }
        yield 0
      }
      dict set processTable($task) running 0
    }
    foreach {task} $cancellist {
      unset -nocomplain processTable($task)
    }
    foreach {process} [lsort -dictionary [array names processTable]] {
      set scheduled 0
      set frequency 0
      dict with processTable($process) {
        if {$scheduled==0 && $frequency==0} {
          if {$next_idle_event < $nextevent} {
            set nexttask $task
            set nextevent $next_idle_event
          }
        } elseif {$scheduled < $nextevent} {
          set nexttask $process
          set nextevent $scheduled
        }
        set lastevent $now
      }
    }
    foreach {eventid msec} [array get ::cron::coro_sleep] {
      if {$msec < 0} continue
      if {$msec<$nextevent} {
        set nexttask "CORO $eventid"
        set nextevent $scheduled
      }
    }
    set delay [expr {$nextevent-$now}]
    if {$delay <= 0} {
      yield 0
    } else {
      if {$::cron::trace > 1} {
        puts "NEXT EVENT $delay - NEXT TASK $nexttask"
      }
      yield $delay
    }
  }
}

proc ::cron::wake {{who ???}} {
  ##
  # Only triggered by cron jobs kicking off other cron jobs within
  # the script body
  ##
  if {$::cron::trace} {
    puts "::cron::wake $who"
  }
  if {$::cron::busy} {
    return
  }
  after cancel $::cron::next_event
  set ::cron::next_event [after idle [list ::cron::do_one_event $who]]
}

proc ::cron::do_one_event {{who ???}} {
  if {$::cron::trace} {
    puts "::cron::do_one_event $who"
  }
  after cancel $::cron::next_event
  set now [current_time]
  set ::cron::busy 1
  while {$::cron::busy} {
    if {[info command ::cron::COROUTINE] eq {}} {
      ::coroutine ::cron::COROUTINE ::cron::runTasksCoro
    }
    set cron_delay [::cron::COROUTINE]
    if {$cron_delay==0} {
      if {[incr loops]>10} {
        if {$::cron::trace} {
          puts "Breaking out of 10 recursive loops"
        }
        set ::cron::wake_time 1000
        break
      }
      set ::cron::wake_time 0
      incr ::cron::loops(active)
    } else {
      set ::cron::busy 0
      incr ::cron::loops(idle)
    }
  }
  ###
  # Try to get the event to fire off on the border of the
  # nearest second
  ###
  if {$cron_delay < 10} {
    set cron_delay 250
  }
  set ctime [current_time]
  set next [expr {$ctime+$cron_delay}]
  set ::cron::wake_time [expr {$next/1000}]
  if {$::cron::trace} {
    puts [list EVENT LOOP WILL WAKE IN $cron_delay ms next: [clock format $::cron::wake_time -format "%H:%M:%S"] active: $::cron::loops(active) idle: $::cron::loops(idle) woken_by: $who]
  }
  set ::cron::next_event [after $cron_delay {::cron::do_one_event TIMER}]
}


proc ::cron::main {} {
  # Never launch from a coroutine
  if {[info coroutine] ne {}} {
    return
  }
  set ::cron::forever 1
  while {$::cron::forever} {
    ::after 120000 {set ::cron::forever 1}
    # Call an update just to give the rest of the event loop a chance
    incr ::cron::loops(main)
    ::after cancel $::cron::next_event
    set ::cron::next_event [::after idle {::cron::wake MAIN}]
    set ::cron::forever 1
    set ::cron::busy 0
    ::vwait ::cron::forever
    if {$::cron::trace} {
      puts "MAIN LOOP CYCLE $::cron::loops(main)"
    }
  }
}

###
# topic: 4a891d0caabc6e25fbec9514ea8104dd
# description:
#    This file implements a process table
#    Instead of having individual components try to maintain their own timers
#    we centrally manage how often tasks should be kicked off here.
###
namespace eval ::cron {
  variable lastcall 0
  variable processTable
  variable busy 0
  variable next_event {}
  variable trace 0
  variable current_event
  variable time -1
  if {![info exists current_event]} {
    set current_event 0
  }
  if {![info exists ::cron::loops]} {
    array set ::cron::loops {
      active 0
      main 0
      idle 0
      wake 0
    }
  }
}

::cron::wake STARTUP
package provide cron 2.1

# Tests for the cron module
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2016 by Sean Woods
# (Insert BSDish style "use at your own risk" license text)

source [file join \
    [file dirname [file dirname [file join [pwd] [info script]]]] \
    devtools testutilities.tcl]

package require tcltest
testsNeedTcl     8.6
testsNeedTcltest 1.0

support {
    use dicttool/dicttool.tcl   dicttool
}
testing {
    useLocal cron.tcl cron
}

###
# For the first part of our testing, control the clock
# via the test harness
###
set ::cron::trace 0
set ::cron::time [expr {[clock scan {2016-01-01}]*1000}]

foreach {val testval} {
  1000 1000
  11235 11000
  1241241 1241000
} {
  test cron-step-$val [list test clock_step function for $val] {
    ::cron::clock_step $val
  } $testval 
}

proc test_elapsed_time {start target} {
  set now [::cron::current_time]
  set value [expr {$now-$start}]
  if {$value < ($target-5)} {
    puts "ELAPSED TIME WAS SHORT: $value / $target"
    return 1
  }
  if {$value > ($target+250)} {
    puts "ELAPSED TIME WAS LONG: $value / $target"
    return 1
  }
  return 0
}


set start [::cron::current_time]
::cron::sleep 250
test cron-sleep-1 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 250
} 0

# Sleep until the top of the second
::cron::clock_sleep 1
set start [::cron::current_time]
::cron::clock_sleep 0 750
test cron-sleep-2 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 750
} 0
::cron::clock_sleep 1 0
test cron-sleep-3 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 1000
} 0
::cron::clock_sleep 1 0

###
# Object interaction tests
###
oo::class create CronTest {

  method coro_name {} {
    return [info object namespace [self]]::idle
  }
  method idle {} {
    set coro [my coro_name]
    ::cron::object_coroutine [self] $coro
    ::coroutine $coro {*}[namespace code {my IdleTask}]
  }

}

###
# This test is a mockup of typical Tk widget
# which has some portion of its startup that has to
# process after an idle loop has completed
###
oo::class create CronTest_3Pings {
  superclass CronTest
  constructor {} {
    set ::TESTOBJ([self]) 0
    my idle
  }
  method IdleTask {} {
    incr ::TESTOBJ([self])
    yield
    incr ::TESTOBJ([self])
    yield
    incr ::TESTOBJ([self])
  }
}
CronTest_3Pings create FOO
set coro [FOO coro_name]
###
# The coroutine for the object exist on startup
test cron-objects-1-1 {cron::every} {
  info commands $coro
} $coro
# And CRON knows about it
test cron-objects-1-2 {cron::every} {
  ::cron::task exists $coro
} 1
# The counter should be initialized to the value
# before the first yield
test cron-objects-1-3 {cron::every} {
  set ::TESTOBJ(::FOO)
} 1
::cron::clock_sleep 1

###
# The coroutine should have completed, and now ceases to exist
###
test cron-objects-1-4 {cron::every} {
  ::cron::task exists $coro
} 0
# The counter should be 3
test cron-objects-1-5 {cron::every} {
  set ::TESTOBJ(::FOO)
} 3

###
# Test that cron cleans up after a destroyed object
###
CronTest_3Pings create FOOBAR
set coro [FOOBAR coro_name]
###
# The coroutine for the object exist on startup
test cron-objects-2-1 {cron::every} {
  info commands $coro
} $coro
# However CRON knows about it
test cron-objects-2-2 {cron::every} {
  ::cron::task exists $coro
} 1
FOOBAR destroy

# The idle routine did parse up to the first yield
test cron-objects-2-3 {cron::every} {
  set ::TESTOBJ(::FOOBAR)
} 1

###
# The coroutine for the object exist on startup
test cron-objects-2-4 {cron::every} {
  info commands $coro
} {}
# However CRON knows about it
test cron-objects-2-5 {cron::every} {
  ::cron::task exists $coro
} 1

# Trigger the idle loop
::cron::do_one_event TEST
# The idle routine did parse up to the first yield
test cron-objects-2-6 {cron::every} {
  set ::TESTOBJ(::FOOBAR)
} 1
# The coroutine is still gone
test cron-objects-2-7 {cron::every} {
  info commands $coro
} {}
# And now cron has forgotten about the object
test cron-objects-2-8 {cron::every} {
  ::cron::task exists $coro
} 0

::cron::do_one_event TEST
test cron-objects-2-9 {cron::every} {
  info commands $coro
} {}
# However cron has forgotten about the object
test cron-objects-2-10 {cron::every} {
  ::cron::task exists $coro
} 0


oo::class create CronTest_Persistant_Coro {
  superclass CronTest
  constructor {} {
    set nspace [info object namespace [self]]
    set coro_do [my coro_name DoLoop]
    set ::TESTOBJ([self]) -1
    set now [::cron::current_time]
    set frequency 1000
    set scheduled [::cron::clock_step [expr {$now+$frequency}]]
    ::cron::object_coroutine [self] $coro_do [list frequency $frequency scheduled $scheduled command [namespace code {my DoLoop}]]
  }
  method coro_name {which} {
    return [info object namespace [self]]::${which}
  }
  method exit_loop {} {
    my variable doloop
    set doloop 0
    if {$::cron::trace} {
      puts [list [self] SIGNAL TO EXIT]
    }
  }
  
  method DoLoop {} {
    if {$::cron::trace} {
      puts "[self] CORO START"
    }
    my variable doloop
    set doloop 1
    set ::TESTOBJ([self]) 0
    yield
    while {$doloop} {
      if {$::cron::trace} {
        puts [list [self] LOOP $doloop]
      }
      incr ::TESTOBJ([self])
      yield
    }
    if {$::cron::trace} {
      puts "[self] CORO EXIT"
    }
  }
}

###
# This series of tests is built around a more complex case:
# an object wants a method invoked periodically. CRON
# will create a coroutine (based on the name given by the object)
# and invoke that coroutine at the frequency requested
#
# If the coroutine exits (or throws an error) It will be restarted
###
set ::cron::trace 0
::cron::clock_sleep 1

CronTest_Persistant_Coro create IRONBAR
set coro [IRONBAR coro_name DoLoop]
test cron-objects-3-1 {
The actual coroutine should not exist yet
} {
  info commands $coro
} {}
# And CRON knows about it
test cron-objects-3-2 {
CRON should be aware of the task
} {
  ::cron::task exists $coro
} 1

test cron-objects-3-3 {
The counter should be initialized to the value
before the first yield
} {
  set ::TESTOBJ(::IRONBAR)
} -1

set start [::cron::current_time]
::cron::clock_sleep 1

test cron-objects-3-4 {The coroutine for the object exists} {
  info commands $coro
} $coro
test cron-objects-3-5 {Cron should know about the task} {
  ::cron::task exists $coro
} 1
test cron-objects-3-6 {The counter should have incremented} {
  set ::TESTOBJ(::IRONBAR)
} 1

::cron::clock_sleep 0 500
test cron-objects-3-7 {The counter should have incremented} {
  set ::TESTOBJ(::IRONBAR)
} 1
::cron::clock_sleep 1

# Test a graceful exit of the coroutine
::IRONBAR exit_loop
::cron::clock_sleep 1
set coro [IRONBAR coro_name DoLoop]
test cron-objects-3-8 {
The actual coroutine should now exit
} {
  info commands $coro
} {}
test cron-objects-3-9 {
CRON should still be aware of the tast
} {
  ::cron::task exists $coro
} 1
test cron-objects-3-10 {The counter hasn't reset} {
  set ::TESTOBJ(::IRONBAR)
} 2
::cron::clock_sleep 1
test cron-objects-3-11 {The should have reset when the coroutine restarted} {
  set ::TESTOBJ(::IRONBAR)
} 1
#::cron::object_destroy ::IRONBAR
::IRONBAR destroy

set ::cron::trace 0
proc my_coro {} {
  if {$::cron::trace} {
    puts "START MY CORO"
  }
  set ::my_coro_progress 0
  set ::my_coro_start [::cron::current_time]
  if {$::cron::trace} {
    puts "SLEEP MY CORO"
  }
  ::cron::sleep 1250
  if {$::cron::trace} {
    puts "/SLEEP MY CORO"
  }
  set ::my_coro_end [::cron::current_time]
  set ::my_coro_progress 1
  if {$::cron::trace} {
    puts "END MY CORO"
  }
}

###
# Test that an otherwise inprepared coroutine
# which invokes "::cron::sleep" partipates in
# the ::cron event system
###
if {$::cron::trace} {
  puts "PRE-MY CORO"
}
coroutine ::TESTCORO my_coro
if {$::cron::trace} {
  puts "POST-MY CORO"
}
test cron-naive-corotine-1 {cron::coroutine sleep} {
  set ::my_coro_progress
} 0
::cron::clock_sleep 3
set ::cron::trace 0

test cron-naive-corotine-2 {cron::coroutine sleep} {
  set ::my_coro_progress
} 1

test cron-naive-corotine-3 {cron::coroutine sleep} {
  set delay [expr {($::my_coro_end - $::my_coro_start)}]
  if {$delay < 1000 || $delay > 2000} {
    puts "TIME DELAY OUT OF RANGE: $delay"
    return 1
  } else {
    return 0
  }
  
} 0

###
# Tests after this point test interactions with the Tcl event loop
# We need to be slaved to the real time clock to work properly
###
set ::cron::trace 0
set ::cron::time -1

###
# Test the clock sleep offset feature
###
# Reset to the top of a clock step
::cron::clock_sleep 1

set ::cron::trace 0
set start [::cron::current_time]
set ::FLAG -1
set time_0 [::cron::clock_delay 1000]
set time_1 [::cron::clock_delay 2000]

after $time_0 {set ::FLAG 0}
after $time_1 {set ::FLAG 1}
test cron-delay-1 {Prior to the first event the value should not have changed} {
  set ::FLAG
} -1

vwait ::FLAG
test cron-delay-3 {At the top of the second, we should have a new value for flag} {
  set ::FLAG
} 0
vwait ::FLAG
test cron-delay-5 {At the top of the second second, we should have a new value for flag} {
  set ::FLAG
} 1
set ::cron::trace 0

proc elapsed_time_coro {} {
  set ::start [::cron::current_time]
  while 1 {
    set now [::cron::current_time]
    set ::elapsed_time [expr {($now-$::start)/1000}]
    yield
  }
}

::cron::task set ::ELAPSED_TIME \
  coroutine ::ELAPSED_TIME \
  command elapsed_time_coro \
  frequency 1000

set timecounter 0
::cron::every timecounter 1 {incr timecounter}
set now [clock seconds]

# Test at
set timerevent 0
::cron::at timeevent1 [expr {$now + 5}] {set ::timerevent 1}
::cron::at timeevent2 [expr {$now + 6}] {set ::eventpause 0}
::cron::at timeevent3 [expr {$now + 10}] {set ::timerevent 2}
::cron::at timeevent4 [expr {$now + 11}] {set ::pause 0}

test cron-1.1 {cron::every} {
  set ::timecounter
} 0
test cron-1.2 {cron::at1} {
  set ::timerevent
} 0
vwait eventpause
test cron-1.3 {cron::at1} {
  set ::timerevent
} 1


###
# At this point 6 seconds should have passed
###
#test cron-1.elapsed-1 {Elapsed time} {
#  set ::elapsed_time
#} 5
# - Test removed - Was too unstable on a busy computer

vwait pause
###
# At this point 11 seconds should have passed
###
#test cron-1.elapsed-2 {Elapsed time} {
#  set ::elapsed_time
#} 10
# - Test removed - Was too unstable on a busy computer

# Test that in X seconds our timer
# was incremented X times
#test cron-1.4 {cron::every} {
#  set ::timecounter
#} $::elapsed_time
#
# - Test removed - Was too unstable on a busy computer

test cron-1.5 {cron::at2} {
  set ::timerevent
} 2

###
# Confirm cancel works
::cron::cancel timecounter
set timecounterfinal $::timecounter
::cron::clock_sleep 2
test cron-1.6 {cron::cancel} {
  set ::timecounter
} $::timecounterfinal

###
# Test the new IN command
###
set ::inevent 0
cron::in 5 {set ::inevent 1}

test cron-1.7 {cron::in} {
  set ::inevent
} 0
::cron::clock_sleep 6

test cron-1.8 {cron::in} {
  set ::inevent
} 1


set FAILED 0
after 10000 {set ::cron::forever 0 ; set FAILED 1}
::cron::in 5 {
  set ::cron::forever 0
test cron-1.12 {cron::main} {
  set ::cron::forever
} 0
}
::cron::wake TEST

###
# At this point 22 seconds should have passed
###
#test cron-1.elapsed-3 {Elapsed time} {
#  set ::elapsed_time
#} 21
#
# Test removed - it was too unstable on a real working computer

::cron::main

# If we get to this test, mission successful
test cron-1.13 {cron::main} {
  return 1
} 1

test cron-1.14 {cron::main} {
  set FAILED
} 0

testsuiteCleanup
return

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded cron 2.1 [list source [file join $dir cron.tcl]]

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin dicttool n 1.0]
[keywords dict]
[copyright {2017 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Extensions to the standard "dict" command}]
[category Utilites]
[titledesc {Dictionary Tools}]
[require Tcl 8.5]
[description]
[para]
The [package dicttool] package enhances the standard [emph dict] command with several new
commands. In addition, the package also defines several "creature comfort" list commands as well.
Each command checks to see if a command already exists of the same name before adding itself,
just in case any of these slip into the core.

[list_begin definitions]
[call [cmd ladd] [arg varname] [arg args]]

This command will add a new instance of each element in [arg args] to [arg varname], but only if that element
is not already present.

[call [cmd ldelete] [arg varname] [arg args]]

This command will add a delete all instances of each element in [arg args] from [arg varname].

[call [cmd {dict getnull}] [arg args]]

Operates like [cmd {dict get}], however if the key [arg args] does not exist, it returns an empty
list instead of throwing an error.

[call [cmd {dict print}] [arg dict]]

This command will produce a string representation of [arg dict], with each nested branch on
a newline, and indented with two spaces for every level.

[call [cmd {dict is_dict}] [arg value]]

This command will return true if [arg value] can be interpreted as a dict. The command operates in
such a way as to not force an existing dict representation to shimmer into another internal rep.

[call [cmd rmerge] [arg args]]

Return a dict which is the product of a recursive merge of all of the arguments. Unlike [cmd {dict merge}],
this command descends into all of the levels of a dict. Dict keys which end in a : indicate a leaf, which
will be interpreted as a literal value, and not descended into further.

[example {

set items [dict merge {
  option {color {default: green}}
} {
  option {fruit {default: mango}}
} {
  option {color {default: blue} fruit {widget: select values: {mango apple cherry grape}}}
}]
puts [dict print $items]
}]

Prints the following result:
[example {
option {
  color {
    default: blue
  }
  fruit {
    widget: select
    values: {mango apple cherry grape}
  }
}
}]

[list_end]

[vset CATEGORY dict]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

The dicttool Package
====================

The **dicttool** package enhances the standard *dict* command with several new
commands. In addition, the package also defines several "creature comfort" list commands as well.
Each command checks to see if a command already exists of the same name before adding itself,
just in case any of these slip into the core.

#### ladd *varname* *args*

This command will add a new instance of each element in *args* to *varname*,
but only if that element is not already present.

#### ldelete] *varname* *args*

This command will add a delete all instances of each element in *args* from *varname*.

#### dict getnull *args*

Operates like **dict get**, however if the key *args* does not exist, it returns an empty
list instead of throwing an error.

#### dict print *dict*

This command will produce a string representation of *dict*, with each nested branch on
a newline, and indented with two spaces for every level.

#### dict is_dict *value*

This command will return true if *value* can be interpreted as a dict. The command operates in
such a way as to not force an existing dict representation to shimmer into another internal rep.

#### dict rmerge *args*

Return a dict which is the product of a recursive merge of all of the arguments. Unlike **dict merge**,
this command descends into all of the levels of a dict. Dict keys which end in a : indicate a leaf, which
will be interpreted as a literal value, and not descended into further.

<pre><code>
set items [dict merge {
  option {color {default: green}}
} {
  option {fruit {default: mango}}
} {
  option {color {default: blue} fruit {widget: select values: {mango apple cherry grape}}}
}]
puts [dict print $items]
</code></pre>


Prints the following result:
<pre><code>
option {
  color {
    default: blue
  }
  fruit {
    widget: select
    values: {mango apple cherry grape}
  }
}
</pre></code>

###
# This package enhances the stock dict implementation with some
# creature comforts
###
if {[info commands ::ladd] eq {}} {
  proc ladd {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}
    }
    foreach item $args {
      if {$item in $var} continue
      lappend var $item
    }
    return $var
  }
}

if {[info command ::ldelete] eq {}} {
  proc ::ldelete {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        return
    }
    foreach item [lsort -unique $args] {
      while {[set i [lsearch $var $item]]>=0} {
        set var [lreplace $var $i $i]
      }
    }
    return $var
  }  
}

if {[::info commands ::tcl::dict::getnull] eq {}} {
  proc ::tcl::dict::getnull {dictionary args} {
    if {[exists $dictionary {*}$args]} {
      get $dictionary {*}$args
    }
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
}
if {[::info commands ::tcl::dict::print] eq {}} {
  ###
  # Test if element is a dict
  ###
  proc ::tcl::dict::_putb {buffervar indent field value} {
    ::upvar 1 $buffervar buffer
    ::append buffer \n [::string repeat " " $indent] [::list $field] " "
    if {[string index $field end] eq "/"} {
      ::incr indent 2
      ::append buffer "\{"
      foreach item $value {
        if [catch {
        if {![is_dict $item]} {
          ::append buffer \n [::string repeat " " $indent] [list $item]
        } else {
          ::append buffer \n "[::string repeat " " $indent]\{"
          ::incr indent 2
          foreach {sf sv} $item {
            _putb buffer $indent $sf $sv
          }
          ::incr indent -2
          ::append buffer \n "[::string repeat " " $indent]\}"          
        }
        } err] {
          puts [list FAILED $indent $field $item]
          puts $err
          puts "$::errorInfo"
        }
      }
      ::incr indent -2
      ::append buffer \n [::string repeat " " $indent] "\}"
    } elseif {[string index $field end] eq ":" || ![is_dict $value]} {
      ::append buffer [::list $value]
    } else {
      ::incr indent 2
      ::append buffer "\{"
      foreach {f v} $value {
        _putb buffer $indent $f $v
      }
      ::incr indent -2
      ::append buffer \n [::string repeat " " $indent] "\}"
    }
  }
  proc ::tcl::dict::print dict {
    ::set buffer {}
    ::foreach {field value} $dict {
      _putb buffer 0 $field $value
    }
    return $buffer
  }
  
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] print ::tcl::dict::print]
}
if {[::info commands ::tcl::dict::is_dict] eq {}} {
  ###
  # Test if element is a dict
  ###
  proc ::tcl::dict::is_dict { d } {
    # is it a dict, or can it be treated like one?
    if {[catch {dict size $d} err]} {
      #::set ::errorInfo {}
      return 0
    }
    return 1
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
}
if {[::info commands ::tcl::dict::rmerge] eq {}} {
  ###
  # title: A recursive form of dict merge
  # description:
  # A routine to recursively dig through dicts and merge
  # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/
  ###
  proc ::tcl::dict::rmerge {a args} {
    ::set result $a
    # Merge b into a, and handle nested dicts appropriately
    ::foreach b $args {
      for { k v } $b {
        if {[string index $k end] eq ":"} {
          # Element names that end in ":" are assumed to be literals
          set result $k $v
        } elseif { [dict exists $result $k] } {
          # key exists in a and b?  let's see if both values are dicts
          # both are dicts, so merge the dicts
          if { [is_dict [get $result $k]] && [is_dict $v] } {
            set result $k [rmerge [get $result $k] $v]
          } else {  
            set result $k $v
          }
        } else {
          set result $k $v
        }
      }
    }
    return $result
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
}

if {[::info commands ::tcl::dict::isnull] eq {}} {
  proc ::tcl::dict::isnull {dictionary args} {
    if {![exists $dictionary {*}$args]} {return 1}
    return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
  }
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
}

package provide dicttool 1.1

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded dicttool 1.1 [list source [file join $dir dicttool.tcl]]

set here [file dirname [file join [pwd] [info script]]]
set auto_path [linsert $auto_path 0 [file dirname $here]]

package require oo::meta
package require oo::dialect
oo::dialect::create tool

# Add a new keyword
proc ::tool::define::option {name def} {
  set class [current_class]
  oo::meta::info $class branchset option $name $def
}

# Override the "constructor" keyword
proc ::tool::define::constructor {arglist body} {
  set class [current_class]
  puts [list CONSTRUCTOR for $class]
  set prebody {
puts [list CREATED [self]]
my _optionInit
  }
  oo::define $class constructor $arglist "$prebody\n$body"
}

# Add functions to the core class
::tool::define ::tool::object {
  method _optionInit {} {
    my variable options meta
    if {![info exists meta]} {
      set meta {}
    }
    foreach {opt info} [my meta getnull option] {
      set options($opt) [dict getnull $info default:]
    }
  }
  method cget option {
    my variable options
    return $options($option)
  }
}

::tool::class create myclass {
  # Use our new option keyword
  option color {default: green}
  
  constructor {} {
    my variable meta
    set meta {}
  }
}

myclass create myobj
puts [myobj cget color]

source [file join $here .. tool dictobj.tcl]

::tool::define myclass {
  dictobj test test
}

myobj test set foo bar
puts [myobj test get foo]

The oo::dialect Package
=======================

*oo::dialect* is designed for building TclOO based domain specific languages. It does this
by providing:
* a meta class
* a core object
* A namespace in which to define additional keywords
* A "define" command to mirror the capabilties of *oo::define*

Example usage:
<pre>
<code>
package require oo::dialect
oo::dialect::create tool

# Add a new keyword
proc ::tool::define::option {name def} {
  set class [class_current]
  oo::meta::info $class branchset option $name $def
}

# Override the "constructor" keyword
proc ::tool::define::constructor {arglist body} {
  set class [class_current]
  set prebody {
my _optionInit
  }
  oo::define $class constructor $arglist "$prebody\n$body"
}

# Add functions to the core class
::tool::define ::tool::object {
  method _optionInit {} {
    my variable options
    foreach {opt info} [my meta getnull option] {
      set options($opt) [dict getnull $info default:]
    }
  }
  method cget option {
    my variable options
    return $options($option)
  }
}

</code>
</pre>

In practice, a new class of this dialect would look like:

<pre>
<code>
::tool::class create myclass {
  # Use our new option keyword
  option color {default: green}
}

myclass create myobj
puts [myobj cget color]
> green
</code>
</pre>

###
# oodialect.tcl
#
# Copyright (c) 2015-2018 Sean Woods
# Copyright (c) 2015 Donald K Fellows
#
# BSD License
###
# @@ Meta Begin
# Package oo::dialect 0.3.4
# Meta platform     tcl
# Meta summary      A utility for defining a domain specific language for TclOO systems
# Meta description  This package allows developers to generate
# Meta description  domain specific languages to describe TclOO
# Meta description  classes and objects.
# Meta category     TclOO
# Meta subject      oodialect
# Meta require      {Tcl 8.6}
# Meta author       Sean Woods
# Meta author       Donald K. Fellows
# Meta license      BSD
# @@ Meta End
namespace eval ::oo::dialect {
  namespace export create
}

# A stack of class names
proc ::oo::dialect::Push {class} {
  ::variable class_stack
  lappend class_stack $class
}
proc ::oo::dialect::Peek {} {
  ::variable class_stack
  return [lindex $class_stack end]
}
proc ::oo::dialect::Pop {} {
  ::variable class_stack
  set class_stack [lrange $class_stack 0 end-1]
}

###
# This proc will generate a namespace, a "mother of all classes", and a
# rudimentary set of policies for this dialect.
###
proc ::oo::dialect::create {name {parent ""}} {
  set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name]
  ::namespace eval $NSPACE {::namespace eval define {}}
  ###
  # Build the "define" namespace
  ###
  if {$parent eq ""} {
  	###
  	# With no "parent" language, begin with all of the keywords in
  	# oo::define
  	###
  	foreach command [info commands ::oo::define::*] {
	    set procname [namespace tail $command]
	    interp alias {} ${NSPACE}::define::$procname {} \
    		::oo::dialect::DefineThunk $procname
  	}
  	# Create an empty dynamic_methods proc
    proc ${NSPACE}::dynamic_methods {class} {}
    namespace eval $NSPACE {
      ::namespace export dynamic_methods
      ::namespace eval define {::namespace export *}
    }
    set ANCESTORS {}
  } else {
    ###
  	# If we have a parent language, that language already has the
  	# [oo::define] keywords as well as additional keywords and behaviors.
  	# We should begin with that
  	###
  	set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent]
    apply [list parent {
  	  ::namespace export dynamic_methods
  	  ::namespace import -force ${parent}::dynamic_methods
  	} $NSPACE] $pnspace

    apply [list parent {
  	  ::namespace import -force ${parent}::define::*
  	  ::namespace export *
  	} ${NSPACE}::define] $pnspace
      set ANCESTORS [list ${pnspace}::object]
  }
  ###
  # Build our dialect template functions
  ###
  proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] {
	###
	# To facilitate library reloading, allow
	# a dialect to create a class from DEFINE
	###
  set class [::oo::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass]
    if {[info commands $class] eq {}} {
	    %NSPACE%::class create $class {*}${args}
    } else {
	    ::oo::dialect::Define %NSPACE% $class {*}${args}
    }
}]
  interp alias {} ${NSPACE}::define::current_class {} \
    ::oo::dialect::Peek
  interp alias {} ${NSPACE}::define::aliases {} \
    ::oo::dialect::Aliases $NSPACE
  interp alias {} ${NSPACE}::define::superclass {} \
    ::oo::dialect::SuperClass $NSPACE

  if {[info command ${NSPACE}::class] ne {}} {
    ::rename ${NSPACE}::class {}
  }
  ###
  # Build the metaclass for our language
  ###
  ::oo::class create ${NSPACE}::class {
    superclass ::oo::dialect::MotherOfAllMetaClasses
  }
  # Wire up the create method to add in the extra argument we need; the
  # MotherOfAllMetaClasses will know what to do with it.
  ::oo::objdefine ${NSPACE}::class \
    method create {name {definitionScript ""}} \
      "next \$name [list ${NSPACE}::define] \$definitionScript"

  ###
  # Build the mother of all classes. Note that $ANCESTORS is already
  # guaranteed to be a list in canonical form.
  ###
  uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
    %NSPACE%::class create %NSPACE%::object {
     superclass %ANCESTORS%
      # Put MOACish stuff in here
    }
  }]
  if { "${NSPACE}::class" ni $::oo::dialect::core_classes } {
    lappend ::oo::dialect::core_classes "${NSPACE}::class"
  }
  if { "${NSPACE}::object" ni $::oo::dialect::core_classes } {
    lappend ::oo::dialect::core_classes "${NSPACE}::object"
  }
}

# Support commands; not intended to be called directly.
proc ::oo::dialect::NSNormalize {namespace qualname} {
  if {![string match ::* $qualname]} {
    set qualname ${namespace}::$qualname
  }
  regsub -all {::+} $qualname "::"
}

proc ::oo::dialect::DefineThunk {target args} {
  tailcall ::oo::define [Peek] $target {*}$args
}

proc ::oo::dialect::Canonical {namespace NSpace class} {
  namespace upvar $namespace cname cname
  #if {[string match ::* $class]} {
  #  return $class
  #}
  if {[info exists cname($class)]} {
    return $cname($class)
  }
  if {[info exists ::oo::dialect::cname($class)]} {
    return $::oo::dialect::cname($class)
  }
  if {[info exists ::oo::dialect::cname(${NSpace}::${class})]} {
    return $::oo::dialect::cname(${NSpace}::${class})
  }
  foreach item [list "${NSpace}::$class" "::$class"] {
    if {[info commands $item] ne {}} {
      return $item
    }
  }
  return ${NSpace}::$class
}

###
# Implementation of the languages' define command
###
proc ::oo::dialect::Define {namespace class args} {
  Push $class
  try {
  	if {[llength $args]==1} {
      namespace eval ${namespace}::define [lindex $args 0]
    } else {
      ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
    }
  	${namespace}::dynamic_methods $class
  } finally {
    Pop
  }
}

###
# Implementation of how we specify the other names that this class will answer
# to
###

proc ::oo::dialect::Aliases {namespace args} {
  set class [Peek]
  namespace upvar $namespace cname cname
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set cname($class) $class
  foreach name $args {
    set cname($name) $class
    #set alias $name
    set alias [NSNormalize $NSpace $name]
    # Add a local metaclass reference
    if {![info exists ::oo::dialect::cname($alias)]} {
      lappend ::oo::dialect::aliases($class) $alias
      ##
      # Add a global reference, first come, first served
      ##
      set ::oo::dialect::cname($alias) $class
    }
  }
}

###
# Implementation of a superclass keyword which will enforce the inheritance of
# our language's mother of all classes
###

proc ::oo::dialect::SuperClass {namespace args} {
  set class [Peek]
  namespace upvar $namespace class_info class_info
  dict set class_info($class) superclass 1
  set ::oo::dialect::cname($class) $class
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set unique {}
  foreach item $args {
    set Item [Canonical $namespace $NSpace $item]
    dict set unique $Item $item
  }
  set root ${namespace}::object
  if {$class ne $root} {
    dict set unique $root $root
  }
  tailcall ::oo::define $class superclass {*}[dict keys $unique]
}

###
# Implementation of the common portions of the the metaclass for our
# languages.
###

::oo::class create ::oo::dialect::MotherOfAllMetaClasses {
  superclass ::oo::class
  constructor {define definitionScript} {
    $define [self] {
      superclass
    }
    $define [self] $definitionScript
  }
  method aliases {} {
    if {[info exists ::oo::dialect::aliases([self])]} {
      return $::oo::dialect::aliases([self])
    }
  }
}

namespace eval ::oo::dialect {
  variable core_classes {::oo::class ::oo::object}
}

package provide oo::dialect 0.3.4

# tool.test - Copyright (c) 2015 Sean Woods
# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1

support {
    use dicttool/dicttool.tcl dicttool
    use oometa/oometa.tcl     oo::meta
}
testing {
    useLocal oodialect.tcl oo::dialect
}

# -------------------------------------------------------------------------

::oo::dialect::create ::alpha

proc ::alpha::define::is_alpha {} {
  dict set ::testinfo([current_class]) is_alpha 1
}

::alpha::define ::alpha::object {
  is_alpha
}

::oo::dialect::create ::bravo ::alpha

proc ::bravo::define::is_bravo {} {
  dict set ::testinfo([current_class]) is_bravo 1
}

::bravo::define ::bravo::object {
  is_bravo
}

::oo::dialect::create ::charlie ::bravo

proc ::charlie::define::is_charlie {} {
  dict set ::testinfo([current_class]) is_charlie 1
}

::charlie::define ::charlie::object {
  is_charlie
}

::oo::dialect::create ::delta ::charlie

proc ::delta::define::is_delta {} {
  dict set ::testinfo([current_class]) is_delta 1
}

::delta::define ::delta::object {
  is_delta
}

::delta::class create adam {
  is_alpha
  is_bravo
  is_charlie
  is_delta
}

test oodialect-keyword-001 {Testing keyword application} {
  set ::testinfo(::adam)
} {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1}

test oodialect-keyword-002 {Testing keyword application} {
  set ::testinfo(::alpha::object)
} {is_alpha 1}

test oodialect-keyword-003 {Testing keyword application} {
  set ::testinfo(::bravo::object)
} {is_bravo 1}

test oodialect-keyword-004 {Testing keyword application} {
  set ::testinfo(::charlie::object)
} {is_charlie 1}

test oodialect-keyword-005 {Testing keyword application} {
  set ::testinfo(::delta::object)
} {is_delta 1}

###
# Declare an object from a namespace
###
namespace eval ::test1 {
  ::alpha::class create a {
    aliases A
    is_alpha
  }
  ::alpha::define b {
    aliases B BEE
    is_alpha
  }
  ::alpha::class create ::c {
    aliases C
    is_alpha
  }
  ::alpha::define ::d {
    aliases D
    is_alpha
  }
}

test oodialect-naming-001 {Testing keyword application} {
  set ::testinfo(::test1::a)
} {is_alpha 1}

test oodialect-naming-002 {Testing keyword application} {
  set ::testinfo(::test1::b)
} {is_alpha 1}

test oodialect-naming-003 {Testing keyword application} {
  set ::testinfo(::c)
} {is_alpha 1}

test oodialect-naming-004 {Testing keyword application} {
  set ::testinfo(::d)
} {is_alpha 1}

test oodialect-aliasing-001 {Testing keyword application} {
namespace eval ::test1 {
    ::alpha::define e {
       superclass A
    }
}
} ::test1::e

test oodialect-aliasing-002 {Testing keyword application} {
namespace eval ::test1 {
    ::bravo::define f {
       superclass A
    }
}
} ::test1::f


test oodialect-aliasing-003 {Testing aliase method on class} {
  ::test1::a aliases
} {::test1::A}


test oodialect-ancestry-003 {Testing heritage} {
  ::oo::meta::ancestors ::test1::f
} {::oo::object ::alpha::object ::bravo::object ::test1::a ::test1::f}

test oodialect-ancestry-004 {Testing heritage} {
  ::oo::meta::ancestors ::alpha::object
} {::oo::object ::alpha::object}

test oodialect-ancestry-005 {Testing heritage} {
  ::oo::meta::ancestors ::delta::object
} {::oo::object ::alpha::object ::bravo::object ::charlie::object ::delta::object}

# -------------------------------------------------------------------------


testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

package ifneeded oo::dialect 0.3.4 [list source [file join $dir oodialect.tcl]]

source ../dicttool/dicttool.tcl
source oometa.tcl

oo::class create animal {
  meta set biodata animal: 1
}
oo::class create mammal {
  superclass animal
  meta set biodata mammal: 1
}
oo::class create cat {
  superclass mammal
  meta set biodata diet: carnivore
}

cat create felix
puts [felix meta get biodata]

felix meta set biodata likes: {birds mice}
puts [felix meta get biodata]

mammal meta set biodata metabolism: warm-blooded
puts [felix meta get biodata]

# Overwrite class info
felix meta set biodata mammal: yes
puts [felix meta get biodata]

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin oometa n 0.7.1]
[keywords TOOL]
[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Data registry for TclOO frameworks}]
[titledesc {oo::meta A data registry for classess}]
[category TclOO]
[keywords TclOO]
[description]

The [cmd oo::meta] package provides a data registry service for TclOO classes.

[section Usage]

[example {
oo::class create animal {
  meta set biodata animal: 1
}
oo::class create mammal {
  superclass animal
  meta set biodata mammal: 1
}
oo::class create cat {
  superclass mammal
  meta set biodata diet: carnivore
}

cat create felix
puts [felix meta dump biodata]
> animal: 1 mammal: 1 diet: carnivore

felix meta set biodata likes: {birds mice}
puts [felix meta get biodata]
> animal: 1 mammal: 1 diet: carnivore likes: {bird mice}

# Modify a class
mammal meta set biodata metabolism: warm-blooded
puts [felix meta get biodata]
> animal: 1 mammal: 1 metabolism: warm-blooded diet: carnivore likes: {birds mice}

# Overwrite class info
felix meta set biodata mammal: yes
puts [felix meta get biodata]
> animal: 1 mammal: yes metabolism: warm-blooded diet: carnivore likes: {birds mice}
}]
[section Concept]
The concept behind [cmd oo::meta] is that each class contributes a snippet of [emph local] data.
When [cmd oo::meta::metadata] is called, the system walks through the linear ancestry produced by
[cmd oo::meta::ancestors], and recursively combines all of that local data for all of a class'
ancestors into a single dict.

Instances of oo::object can also combine class data with a local dict stored in the [emph meta] variable.

[section COMMANDS]

[list_begin definitions]

[call [cmd oo::meta::info]]

[cmd oo::meta::info] is intended to work on the metadata of a class in a manner similar to if the aggregate
pieces where assembled into a single dict. The system mimics all of the standard dict commands, and addes
the following:

[call [cmd {oo::meta::info branchget}] [opt [arg key]] [opt ...]]

Returns a dict representation of the element at [emph args], but with any trailing : removed from field names.

[example {
::oo::meta::info $myclass set option color {default: green widget: colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
puts [::oo::meta::info $myclass branchget option color]
> {default green widget color}
}]

[call [cmd {oo::meta::info branchset}] [opt [arg key...]] [arg key] [arg value]]

Merges [emph dict] with any other information contaned at node [opt [arg key...]], and adding a trailing :
to all field names.

[example {
::oo::meta::info $myclass branchset option color {default green widget colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
}]

[call [cmd {oo::meta::info dump}] [arg class]]

Returns the complete snapshot of a class metadata, as producted by [cmd oo::meta::metadata]

[call [cmd oo::meta::info] [arg class] [cmd is] [arg type] [opt [arg args]]]

Returns a boolean true or false if the element [opt [arg args]] would match [cmd {string is}] [arg type] [arg value]

[example {
::oo::meta::info $myclass set constant mammal 1
puts [::oo::meta::info $myclass is true constant mammal]
> 1
}]

[call [cmd oo::meta::info] [arg class] [cmd merge] [opt [arg dict]] [opt [arg dict]] [opt [arg ...]]]

Combines all of the arguments into a single dict, which is then stored as the new
local representation for this class.

[call [cmd oo::meta::info] [arg class] [cmd rebuild]]

Forces the meta system to destroy any cached representation of a class' metadata before
the next access to [cmd oo::meta::metadata]

[call [cmd oo::meta::metadata] [arg class]]

Returns an aggregate picture of the metadata for [arg class], combining its [emph local] data
with the [emph local] data from its ancestors.

[call [cmd {oo::define meta}]]

The package injects a command [cmd oo::define::meta] which works to provide a class in the
process of definition access to [cmd oo::meta::info], but without having to look the name up.

[example {
oo::define myclass {
  meta set foo bar: baz
}
}]

[call [cmd {oo::class method meta}]]

The package injects a new method [cmd meta] into [cmd oo::class] which works to provide a class
instance access to [cmd oo::meta::info].

[call [cmd {oo::object method meta}]]

The package injects a new method [cmd meta] into [cmd oo::object]. [cmd oo::object] combines the data
for its class (as provided by [cmd oo::meta::metadata]), with a local variable [emph meta] to
produce a local picture of metadata.

This method provides the following additional commands:

[call [cmd {oo::object method meta cget}] [opt [arg field]] [opt [arg ...]] [arg field]]

Attempts to locate a singlar leaf, and return its value. For single option lookups, this
is faster than [cmd {my meta getnull}] [opt [arg field]] [opt [arg ...]] [arg field]], because
it performs a search instead directly instead of producing the recursive merge product
between the class metadata, the local [emph meta] variable, and THEN performing the search.

[list_end]

[vset CATEGORY tcloo]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

The oo::meta package
============

The *oo::meta* package provides a data registry service for TclOO classes. It works by
providing the following:

* The **oo::meta::info** command, providing data introspection and manipulation
* The **oo::meta::metadata** command, providing a snapshot of the data per class instance
* The **oo::meta::ancestors** command, providing a linear representation of a class's inheritance tree
* A **meta** keyword in *oo::define*, to provide easy access to the data from within class definition bodies.
* A **meta** method for *oo::class*, to provide easy access to the data from a class instance
* A **meta** method for *oo::object*, which combines data from the class with a local *meta* variable

## Usage
<pre><code>
oo::class create animal {
  meta set biodata animal: 1
}
oo::class create mammal {
  superclass animal
  meta set biodata mammal: 1
}
oo::class create cat {
  superclass mammal
  meta set biodata diet: carnivore
}

cat create felix
puts [felix meta dump biodata]
> animal: 1 mammal: 1 diet: carnivore

felix meta set biodata likes: {birds mice}
puts [felix meta get biodata]
> animal: 1 mammal: 1 diet: carnivore likes: {bird mice}

# Modify a class
mammal meta set biodata metabolism: warm-blooded
puts [felix meta get biodata]
> animal: 1 mammal: 1 metabolism: warm-blooded diet: carnivore likes: {birds mice}

# Overwrite class info
felix meta set biodata mammal: yes
puts [felix meta get biodata]
> animal: 1 mammal: yes metabolism: warm-blooded diet: carnivore likes: {birds mice}
</code></pre>

## Concept
The concept behind *oo::meta* is that each class contributes a snippet of *local* data. When
**oo::meta::metadata** is called, the system walks through the linear ancestry produced by
**oo::meta::ancestors**, and recursively combines all of that local data for all of a class'
ancestors into a single dict.

Instances of oo::object can also combine class data with a local dict stored in the *meta* variable.

### oo::meta::info
*oo::meta::info* is intended to work on the metadata of a class in a manner similar to if the aggregate
pieces where assembled into a single dict. The system mimics all of the standard dict commands, and addes
the following:

#### oo::meta::info *class* branchget *?key...?* key
Returns a dict representation of the element at *args*, but with any trailing : removed from field names.

<pre><code>
::oo::meta::info $myclass set option color {default: green widget: colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
puts [::oo::meta::info $myclass branchget option color]
> {default green widget color}
</code></pre>

#### oo::meta::info *class* branchset *?key...? key dict*
Merges *dict* with any other information contaned at node *?key...?*, and adding a trailing :
to all field names.

<pre><code>
::oo::meta::info $myclass branchset option color {default green widget colorselect}
puts [::oo::meta::info $myclass get option color]
> {default: green widget: color}
</code></pre>

#### oo::meta::dump *class*
Returns the complete snapshot of a class metadata, as producted by **oo::meta::metadata**

#### oo::meta::info *class* is *type* *args*
Returns a boolean true or false if the element *args* would match **string is *type* *value***
<pre><code>
::oo::meta::info $myclass set constant mammal 1
puts [::oo::meta::info $myclass is true constant mammal]
> 1
</code></pre>

#### oo::meta::info *class* merge *dict* *dict* ?*dict...*?
Combines all of the arguments into a single dict, which is then stored as the new
local representation for this class.

#### oo::meta::info *class* rebuild
Forces the meta system to destroy any cached representation of a class' metadata before
the next access to **oo::meta::metadata**

### oo::meta::metadata *class*
Returns an aggregate picture of the metadata for *class*, combining its *local* data
with the *local* data from every class it is descended from.

## **meta** keyword
The package injects a command **oo::define::meta** which works to provide a class in the
process of definition access to **oo::meta::info**, but without having to look the name up.

## **meta** keyword
The package injects a command **oo::define::meta** which works to provide a class in the
process of definition access to **oo::meta::info** *class*, but without having
to look the name up.

## oo::class method **meta**
The package injects a new method **meta** into *oo::class* which works to provide a class
instance access to **oo::meta::info**.

## oo::object method **meta**
The package injects a new method **meta** into *oo::object*. oo::object combines the data
for its class (as provided by **oo::meta::metadata**), with a local variable *meta* to
produce a local picture of metadata.

This method provides the following additional commands:

#### method meta cget *?field...? field*
Attempts to locate a singlar leaf, and return its value. For single option lookups, this
is faster than [my meta getnull *?field...? field*], because it performs a search instead
directly instead of producing the recursive merge product between the class metadata, the
local *meta* variable, and THEN performing the search.

###
# Author: Sean Woods, yoda@etoyoc.com
##
# TclOO routines to implement property tracking by class and object
###
package require Tcl 8.6 ;# tailcall
package require dicttool
package require oo::dialect
package provide oo::meta 0.7.2

namespace eval ::oo::meta {
  set dirty_classes {}
}

proc ::oo::meta::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

proc ::oo::meta::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimleft $var -] $val
  }
  return $result
}

proc ::oo::meta::ancestors class {
  set class [::oo::meta::normalize $class]
  set core_result {}
  set queue $class
  set result {}
  # Rig things such that that the top superclasses
  # are evaluated first
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      if {$qclass in $::oo::dialect::core_classes} {
        if {$qclass ni $core_result} {
          lappend core_result $qclass
        }
        continue
      }
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $core_result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
    }
    foreach item $tqueue {
      if {$item in $core_result} continue
      if { $item ni $result } {
        set result [linsert $result 0 $item]
      }
    }
  }
  # Handle core classes last
  set queue $core_result
  while {[llength $queue]} {
    set tqueue $queue
    set queue {}
    foreach qclass $tqueue {
      foreach aclass [::info class superclasses $qclass] {
        if { $aclass in $result } continue
        if { $aclass in $queue } continue
        lappend queue $aclass
      }
    }
    foreach item $tqueue {
      if { $item ni $result } {
        set result [linsert $result 0 $item]
      }
    }
  }
  return $result
}

proc oo::meta::info {class submethod args} {
  set class [::oo::meta::normalize $class]
  switch $submethod {
    cget {
      ###
      # submethod: cget
      # arguments: ?*path* ...? *field*
      # format: markdown
      # description:
      # Retrieve a value from the class' meta data. Values are searched in the
      # following order:
      # 1. From class meta data as const **path** **field:**
      # 2. From class meta data as const **path** **field**
      # 3. From class meta data as **path** **field:**
      # 4. From class meta data as **path** **field**
      ###
      set path [lrange $args 0 end-1]
      set field [string trimright [lindex $args end] :]
      foreach mclass [lreverse [::oo::meta::ancestors $class]] {
        if {![::info exists ::oo::meta::local_property($mclass)]} continue
        set class_metadata $::oo::meta::local_property($mclass)
        if {[dict exists $class_metadata const {*}$path $field:]} {
          return [dict get $class_metadata const {*}$path $field:]
        }
        if {[dict exists $class_metadata const {*}$path $field]} {
          return [dict get $class_metadata const {*}$path $field]
        }
        if {[dict exists $class_metadata {*}$path $field:]} {
          return [dict get $class_metadata {*}$path $field:]
        }
        if {[dict exists $class_metadata {*}$path $field]} {
          return [dict get $class_metadata {*}$path $field]
        }
      }
      return {}
    }
    rebuild {
      ::oo::meta::rebuild $class
    }
    is {
      set info [metadata $class]
      return [string is [lindex $args 0] -strict [dict getnull $info {*}[lrange $args 1 end]]]
    }
    for -
    map {
      set info [metadata $class]
      uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]
    }
    with {
      upvar 1 TEMPVAR info
      set info [metadata $class]
      return [uplevel 1 [list ::dict with TEMPVAR {*}$args]]
    }
    branchget {
      set info [metadata $class]
      set result {}
      foreach {field value} [dict getnull $info {*}$args] {
        dict set result [string trimright $field :] $value
      }
      return $result
    }
    branchset {
      ::oo::meta::rebuild $class
      foreach {field value} [lindex $args end] {
        ::dict set ::oo::meta::local_property($class) {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    leaf_add {
      if {[::info exists ::oo::meta::local_property($class)]} {
        set result [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]]
      }
      ladd result {*}[lrange $args 1 end]
      dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result
    }
    leaf_remove {
      if {![::info exists ::oo::meta::local_property($class)]} return
      set result {}
      forearch element [dict getnull $::oo::meta::local_property($class) {*}[lindex $args 0]] {
        if { $element in [lrange $args 1 end]} continue
        lappend result $element
      }
      dict set ::oo::meta::local_property($class) {*}[lindex $args 0] $result
    }
    append -
    incr -
    lappend -
    set -
    unset -
    update {
      ::oo::meta::rebuild $class
      ::dict $submethod ::oo::meta::local_property($class) {*}$args
    }
    merge {
      ::oo::meta::rebuild $class
      set ::oo::meta::local_property($class) [dict rmerge $::oo::meta::local_property($class) {*}$args]
    }
    dump {
      set info [metadata $class]
      return $info
    }
    default {
      set info [metadata $class]
      return [::dict $submethod $info {*}$args]
    }
  }
}

proc ::oo::meta::localdata {class args} {
  if {![::info exists ::oo::meta::local_property($class)]} {
    return {}
  }
  if {[::llength $args]==0} {
    return $::oo::meta::local_property($class)
  }
  return [::dict getnull $::oo::meta::local_property($class) {*}$args]
}

proc ::oo::meta::normalize class {
  set class ::[string trimleft $class :]
}

proc ::oo::meta::metadata {class {force 0}} {
  set class [::oo::meta::normalize $class]
  ###
  # Destroy the cache of all derivitive classes
  ###
  if {$force} {
    unset -nocomplain ::oo::meta::cached_property
    unset -nocomplain ::oo::meta::cached_hierarchy
  } else {
    variable dirty_classes
    foreach dclass $dirty_classes {
      foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
        if {$dclass in $cancestors} {
          unset -nocomplain ::oo::meta::cached_property($cclass)
          unset -nocomplain ::oo::meta::cached_hierarchy($cclass)
        }
      }
      if {![::info exists ::oo::meta::local_property($dclass)]} continue
      if {[dict getnull $::oo::meta::local_property($dclass) classinfo type:] eq "core"} {
        if {$dclass ni $::oo::dialect::core_classes} {
          lappend ::oo::dialect::core_classes $dclass
        }
      }
    }
    set dirty_classes {}
  }

  ###
  # If the cache is available, use it
  ###
  variable cached_property
  if {[::info exists cached_property($class)]} {
    return $cached_property($class)
  }
  ###
  # Build a cache of the hierarchy and the
  # aggregate metadata for this class and store
  # them for future use
  ###
  variable cached_hierarchy
  set metadata {}
  set stack {}
  variable local_property
  set cached_hierarchy($class) [::oo::meta::ancestors $class]
  foreach class $cached_hierarchy($class) {
    if {[::info exists local_property($class)]} {
      lappend metadata $local_property($class)
    }
  }
  #foreach aclass [lreverse [::info class superclasses $class]] {
  #  lappend metadata [::oo::meta::metadata $aclass]
  #}

  lappend metadata {classinfo {type: {}}}
  if {[::info exists local_property($class)]} {
    lappend metadata $local_property($class)
  }
  set metadata [dict rmerge {*}$metadata]
  set cached_property($class) $metadata
  return $metadata
}

proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
  }
}

proc ::oo::meta::search args {
  variable local_property

  set path [lrange $args 0 end-1]
  set value [lindex $args end]

  set result {}
  foreach {class info} [array get local_property] {
    if {[dict exists $info {*}$path:]} {
      if {[string match [dict get $info {*}$path:] $value]} {
        lappend result $class
      }
      continue
    }
    if {[dict exists $info {*}$path]} {
      if {[string match [dict get $info {*}$path] $value]} {
        lappend result $class
      }
    }
  }
  return $result
}

proc ::oo::define::meta {args} {
  set class [lindex [::info level -1] 1]
  if {[lindex $args 0] in "cget set branchset"} {
    ::oo::meta::info $class {*}$args
  } else {
    ::oo::meta::info $class set {*}$args
  }
}

oo::define oo::class {
  method meta {submethod args} {
    tailcall ::oo::meta::info [self] $submethod {*}$args
  }
}

oo::define oo::object {
  ###
  # title: Provide access to meta data
  # format: markdown
  # description:
  # The *meta* method allows an object access
  # to a combination of its own meta data as
  # well as to that of its class
  ###
  method meta {submethod args} {
    my variable meta MetaMixin
    if {![info exists MetaMixin]} {
      set MetaMixin {}
    }
    set class [::info object class [self object]]
    set classlist [list $class {*}$MetaMixin]
    switch $submethod {
      cget {
        ###
        # submethod: cget
        # arguments: ?*path* ...? *field*
        # format: markdown
        # description:
        # Retrieve a value from the local objects **meta** dict
        # or from the class' meta data. Values are searched in the
        # following order:
        # 0. (If path length==1) From the _config array
        # 1. From the local dict as **path** **field:**
        # 2. From the local dict as **path** **field**
        # 3. From class meta data as const **path** **field:**
        # 4. From class meta data as const **path** **field**
        # 5. From class meta data as **path** **field:**
        # 6. From class meta data as **path** **field**
        ###
        set path [lrange $args 0 end-1]
        set field [string trim [lindex $args end] :]
        if {[dict exists $meta {*}$path $field:]} {
          return [dict get $meta {*}$path $field:]
        }
        if {[dict exists $meta {*}$path $field]} {
          return [dict get $meta {*}$path $field]
        }
        foreach mclass [lreverse $classlist] {
          set class_metadata [::oo::meta::metadata $mclass]
          if {[dict exists $class_metadata const {*}$path $field:]} {
            return [dict get $class_metadata const {*}$path $field:]
          }
          if {[dict exists $class_metadata const {*}$path $field]} {
            return [dict get $class_metadata const {*}$path $field]
          }
          if {[dict exists $class_metadata {*}$path $field:]} {
            return [dict get $class_metadata {*}$path $field:]
          }
          if {[dict exists $class_metadata {*}$path $field]} {
            return [dict get $class_metadata {*}$path $field]
          }
        }
        return {}
      }
      is {
        set value [my meta cget {*}[lrange $args 1 end]]
        return [string is [lindex $args 0] -strict $value]
      }
      for -
      map {
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        set info [dict rmerge {*}$mdata $meta]
        uplevel 1 [list ::dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]
      }
      with {
        upvar 1 TEMPVAR info
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        set info [dict rmerge {*}$mdata $meta]
        return [uplevel 1 [list dict with TEMPVAR {*}$args]]
      }
      dump {
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        return [dict rmerge {*}$mdata $meta]
      }
      append -
      incr -
      lappend -
      set -
      unset -
      update {
        return [dict $submethod meta {*}$args]
      }
      branchset {
        foreach {field value} [lindex $args end] {
          dict set meta {*}[lrange $args 0 end-1] [string trimright $field :]: $value
        }
      }
      rmerge -
      merge {
        set meta [dict rmerge $meta {*}$args]
        return $meta
      }
      exists {
        foreach mclass $classlist {
          if {[dict exists [::oo::meta::metadata $mclass] {*}$args]} {
            return 1
          }
        }
        if {[dict exists $meta {*}$args]} {
          return 1
        }
        return 0
      }
      get -
      getnull {
        if {[string index [lindex $args end] end]==":"} {
          # Looking for a leaf node
          if {[dict exists $meta {*}$args]} {
            return [dict get $meta {*}$args]
          }
          foreach mclass [lreverse $classlist] {
            set mdata [::oo::meta::metadata $mclass]
            if {[dict exists $mdata {*}$args]} {
              return [dict get $mdata {*}$args]
            }
          }
          if {$submethod == "get"} {
            error "key \"$args\" not known in metadata"
          }
          return {}
        }
        # Looking for a branch node
        # So we need to composite the result
        set found 0
        foreach mclass $classlist {
          set mdata [::oo::meta::metadata $mclass]
          if {[dict exists $mdata {*}$args]} {
            set found 1
            lappend result [dict get $mdata {*}$args]
          }
        }
        if {[dict exists $meta {*}$args]} {
          set found 1
          lappend result [dict get $meta {*}$args]
        }
        if {!$found} {
          if {$submethod == "get"} {
            error "key \"$args\" not known in metadata"
          }
          return {}
        }
        return [dict rmerge {*}$result]
      }
      branchget {
        set result {}
        foreach mclass [lreverse $classlist] {
          foreach {field value} [dict getnull [::oo::meta::metadata $mclass] {*}$args] {
            dict set result [string trimright $field :] $value
          }
        }
        foreach {field value} [dict getnull $meta {*}$args] {
          dict set result [string trimright $field :] $value
        }
        return $result
      }
      mixin {
        foreach mclass $args {
          set mclass [::oo::meta::normalize $mclass]
          if {$mclass ni $MetaMixin} {
            lappend MetaMixin $mclass
          }
        }
      }
      mixout {
        foreach mclass $args {
          set mclass [::oo::meta::normalize $mclass]
          while {[set i [lsearch $MetaMixin $mclass]]>=0} {
            set MetaMixin [lreplace $MetaMixin $i $i]
          }
        }
      }
      default {
        foreach mclass $classlist {
          lappend mdata [::oo::meta::metadata $mclass]
        }
        set info [dict rmerge {*}$mdata $meta]
        return [dict $submethod $info {*}$args]
      }
    }
  }
}

# oometa.test - Copyright (c) 2016 Sean Woods

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.6 ;# tailcall in oo::meta
testsNeedTcltest 2
testsNeed        TclOO

testing {
  useLocal oometa.tcl   oo::meta
  useLocal oooption.tcl oo::option
}

# -------------------------------------------------------------------------
# Test properties

oo::class create foo {
  meta set const color: blue
  
  constructor args {
    my _staticInit
    my configure {*}$args
  }
}

oo::class create bar {
  superclass ::foo
  meta set const shape: oval
  option color {
    label Color
    default green
  }
}

test oo-class-meta-001 {Test accessing properties} {
  foo meta get const color:
} blue

test oo-class-meta-002 {Test accessing properties} {
  bar meta get const color:
} blue

test oo-class-meta-003 {Test accessing properties} {
  bar meta get const shape:
} oval

bar create cheers color pink
# Pulling the meta data from const will return
# the value specified in the class
test oo-object-meta-001 {Test accessing properties} {
  cheers meta get const color:
} blue

# Accessing the data via cget pulls from the local
# definition
test oo-object-meta-001a {Test accessing properties} {
  cheers meta cget color
} green
# pink - Meta CGET is no longer connected to the local object's config

# With or without the trailing :
test oo-object-meta-001b {Test accessing properties} {
  cheers meta cget color:
} green
# pink - Meta CGET is no longer connected to the local object's config

# And using the local cget
test oo-object-meta-001c {Test accessing properties} {
  cheers cget color
} pink

test  oo-object-meta-002 {Test accessing properties} {
  cheers meta get const shape:
} oval

test  oo-object-meta-003 {Test accessing properties} {
  cheers cget color
} pink

bar create moes
test  oo-object-meta-004 {Test accessing properties} {
  moes meta get const color:
} blue

test  oo-object-meta-004a {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-004a {Test accessing properties} {
  moes cget color:
} green

test  oo-object-meta-005 {Test accessing properties} {
  moes meta get const shape:
} oval

test  oo-object-meta-006 {Test accessing properties} {
  moes cget color
} green

test  oo-object-meta-007 {Test the CGET retrieves a property if an option doesn't exist} {
  moes cget shape
} oval

###
# Test altering a property
###

#oo::define ::foo property woozle whoop
::foo meta set const woozle: whoop

test oo-modclass-meta-001 {Test accessing properties of an altered class} {
  foo meta get const woozle:
} whoop

test oo-modclass-meta-002 {Test accessing properties of the descendent of an altered class} {
  bar meta get const woozle:
} whoop

test oo-modobject-meta-001 {Test the accessing of properties of an instance of an altered class} {
  moes meta get const woozle:
} whoop

test obj-meta-for-001 {Test object meta for} {
  set output {}
  moes meta for {key value} option {
    lappend output $key $value
  }
  set output
} {color {label: Color default: green}}

test obj-meta-with-001 {Test object meta with} {
  set result {}
  moes meta with option {}
  set color
} {label: Color default: green}

test class-meta-for-001 {Test class meta for} {
  set output {}
  bar meta for {key value} option {
    lappend output $key $value
  }
  set output
} {color {label: Color default: green}}

test class-meta-with-001 {Test class meta with} {
  set result {}
  bar meta with option {}
  set color
} {label: Color default: green}

# -------------------------------------------------------------------------

# Test of recursive dicts

oo::class create baz {
  superclass ::bar
  meta set option color default: purple  
}

test obj-meta-recursive-1 {Test that meta set works with recursive dicts} {
  set result {}
  baz meta get option color default:
} {purple}

test obj-meta-recursive-2 {Test that meta set works with recursive dicts} {
  set result {}
  baz meta get option color label:
} {Color}


###
# New test, of mixins
###
oo::class create mixin-test-A {
  meta set const color: blue
  meta set field {
    pkey {name: {Primary Key} type: integer}
    name {name: {Unit Name} type: string}
    typefield {name: {Type Field} type: integer}
  }
  constructor args {
    my _staticInit
    my configure {*}$args
  }
}

oo::class create mixin-test-B {
  meta set const shape: oval
  meta set field {
    location {name: {Location} type: vector}
    typefield {name: {Type Field} type: custom}
  }
  option color {
    label Color
    default green
  }
  constructor args {
    my _staticInit
    my configure {*}$args
  }
}

mixin-test-B create MTB

test obj-mixin-001 {Test that meta prior to meta mixin we don't have a color} {
  MTB meta exists const color:
} 0

MTB meta mixin mixin-test-A
test obj-mixin-002 {Test that prior to meta mixin we don't have a color} {
  MTB meta exists const color:
} 1
test obj-mixin-002 {Test that after meta mixin we do have a color} {
  MTB meta get const color:
} blue
test obj-mixin-003 {Test that after meta mixin we can access the field dict} {
  MTB meta get field pkey name:
} {Primary Key}
test obj-mixin-004 {Test that after meta mixin we can access the field dict's local only value} {
  MTB meta get field location type:
} vector
test obj-mixin-005 {Test that mixed in data overrides conflicting local data} {
  MTB meta get field typefield type:
} integer
testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

###
# Option handling for TclOO
###
package require Tcl 8.6 ;# due oo::meta
package require oo::meta 0.4

proc ::oo::define::option {field argdict} {
  set class [lindex [::info level -1] 1]
  foreach {prop value} $argdict {
    ::oo::meta::info $class set option $field [string trim $prop :]: $value
  }
}

oo::define oo::object {
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method _staticInit {} {
    my variable meta
    if {![info exists meta]} {
      set meta {}
    }
    set dat [my meta getnull option]
    foreach {var info} $dat {
      if {[dict exists $info set-command:]} {
        if {[catch {my cget $var} value]} {
          dict set meta $var [my cget $var default:]
        } else {
          if { $value eq {} } {
            dict set meta $var [my cget $var default:]
          }
        }
      }
      if {![dict exists $meta $var]} {
        dict set meta $var [my cget $var default:]
      }
    }
    foreach {var info} [my meta getnull variable] {
      if { $var eq "meta" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default:]} {
          set $var [dict get $info default:]
        } else {
          set $var {}
        }
      }
    }
    foreach {var info} [my meta getnull array] {
      if { $var eq "meta" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default:]} {
          array set $var [dict get $info default:]
        } else {
          array set $var {}
        }
      }
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget {field {default {}}} {
    my variable _config
    set field [string trimleft $field -]
    set dat [my meta getnull option]
  
    if {[my meta is true const options_strict:] && ![dict exists $dat $field]} {
      error "Invalid option -$field. Valid: [dict keys $dat]"
    }
    set info [dict getnull $dat $field]    
    if {$default eq "default"} {
      set getcmd [dict getnull $info default-command:]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        return [dict getnull $info default:]
      }
    }
    if {[dict exists $dat $field]} {
      set getcmd [dict getnull $info get-command:]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      }
      if {![info exists _config($field)]} {
        set getcmd [dict getnull $info default-command:]
        if {$getcmd ne {}} {
          set _config($field) [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
        } else {
          set _config($field) [dict getnull $info default:]
        }
      }
      if {$default eq "varname"} {
        set varname [my varname _config]
        return "${varname}($field)"
      }
      return $_config($field)
    }
    return [my meta cget $field]
  }
  
  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    my configurelist $dictargs
    my configurelist_triggers $dictargs
  }

  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method configurelist dictargs {
    my variable _config
    set dat [my meta getnull option]
    if {[my meta is true const options_strict:]} {
      foreach {field val} $dictargs {
        if {![dict exists $dat $field]} {
          error "Invalid option $field. Valid: [dict keys $dat]"
        }
      }
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    array set _config $dictargs
  }

  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method configurelist_triggers dictargs {
    set dat [my meta getnull option]
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
}
package provide oo::option 0.3.1

#checker -scope global exclude warnUndefinedVar
# var in question is 'dir'.
if {![package vsatisfies [package provide Tcl] 8.6]} {
    # PRAGMA: returnok
    return
}
package ifneeded oo::meta   0.7.2 [list source [file join $dir oometa.tcl]]
package ifneeded oo::option 0.3.1 [list source [file join $dir oooption.tcl]]

    }
}

# For now ... just wrap it
proc ::tao::combobox args {
  tailcall ::combobox::combobox {*}$args
}

set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.7
set module [file tail $moddir]

set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version

puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide %module% %version%
namespace eval ::%module% {}
}]
if {$module ne "tool"} {
  puts $fout [string map $map {::tool::module push %module%}]
}

# Track what files we have included so far
set loaded {}
lappend loaded build.tcl

# These files must be loaded in a particular order
foreach file {
  core.tcl
  uuid.tcl
  ensemble.tcl
  metaclass.tcl
  option.tcl
  event.tcl
  pipeline.tcl
} {
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [lsort -dictionary [glob [file join $srcdir *.tcl]]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin
  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
  namespace export *
}
}]
close $fout

###
# Build our pkgIndex.tcl file
###
set fout [open [file join $moddir pkgIndex.tcl] w]
puts $fout [string map $map {# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout

package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
#package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0

proc ::tool::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::tool::module {cmd args} {
  ::variable moduleStack
  ::variable module

  switch $cmd {
    push {
      set module [lindex $args 0]
      lappend moduleStack $module
      return $module
    }
    pop {
      set priormodule      [lindex $moduleStack end]
      set moduleStack [lrange $moduleStack 0 end-1]
      set module [lindex $moduleStack end]
      return $priormodule
    }
    peek {
      set module      [lindex $moduleStack end]
      return $module
    }
    default {
      error "Invalid command \"$cmd\". Valid: peek, pop, push"
    }
  }
}
::tool::module push core

proc ::tool::pathload {path {order {}} {skip {}}} {
  ###
  # On windows while running under a VFS, the system sometimes
  # gets confused about the volume we are running under
  ###
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string range $path 1 6] eq ":/zvfs"} {
      set path [string range $path 2 end]
    }
  }
  set loaded {pkgIndex.tcl index.tcl}
  foreach item $skip {
    lappend loaded [file tail $skip]
  }
  if {[file exists [file join $path metaclass.tcl]]} {
    lappend loaded metaclass.tcl
    uplevel #0 [list source [file join $path metaclass.tcl]]
  }
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $order {
    set file [file tail $file]
    if {$file in $loaded} continue
    if {![file exists [file join $path $file]]} {
      puts "WARNING [file join $path $file] does not exist in [info script]"
    } else {
      uplevel #0 [list source [file join $path $file]]
    }
    lappend loaded $file
  }
  foreach file [lsort -dictionary [glob -nocomplain [file join $path *.tcl]]] {
    if {[file tail $file] in $loaded} continue
    uplevel #0 [list source $file]
    lappend loaded [file tail $file]
  }
}

proc ::tool::define::coroutine {name corobody} {
  set class [current_class]
  ::oo::meta::info $class set method_ensemble ${name} _preamble: [list {} [string map [list %coroname% $name] {
    my variable coro_queue coro_lock
    set coro %coroname%
    set coroname [info object namespace [self]]::%coroname%
  }]]
  ::oo::meta::info $class set method_ensemble ${name} coroutine: {{} {
    return $coroutine
  }}
  ::oo::meta::info $class set method_ensemble ${name} restart: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
    set coro_lock($coroname) 0
    ::coroutine $coroname {*}[namespace code [list my $coro main]]
    ::cron::object_coroutine [self] $coroname
  }}
  ::oo::meta::info $class set method_ensemble ${name} kill: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
  }}

  ::oo::meta::info $class set method_ensemble ${name} main: [list {} $corobody]

  ::oo::meta::info $class set method_ensemble ${name} clear: {{} {
    set coro_queue($coroname) {}
  }}
  ::oo::meta::info $class set method_ensemble ${name} next: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    set coro_queue($coroname) [lrange $coro_queue($coroname) 1 end]
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} peek: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    return 0
  }}

  ::oo::meta::info $class set method_ensemble ${name} running: {{} {
    if {[info commands $coroname] eq {}} {
      return 0
    }
    if {[::cron::task exists $coroname]} {
      set info [::cron::task info $coroname]
      if {[dict exists $info running]} {
        return [dict get $info running]
      }
    }
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} send: {args {
    lappend coro_queue($coroname) $args
    if {[info coroutine] eq $coroname} {
      return
    }
    if {[info commands $coroname] eq {}} {
      ::coroutine $coroname {*}[namespace code [list my $coro main]]
      ::cron::object_coroutine [self] $coroname
    }
    if {[info coroutine] eq {}} {
      ::cron::do_one_event $coroname
    } else {
      yield
    }
  }}
  ::oo::meta::info $class set method_ensemble ${name} default: {args {my [self method] send $method {*}$args}}

}

::namespace eval ::tool::define {}

if {![info exists ::tool::dirty_classes]} {
  set ::tool::dirty_classes {}
}

###
# Monkey patch oometa's rebuild function to
# include a notifier to tool
###
proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}

proc ::tool::ensemble_build_map args {
  set emap {}
  foreach thisclass $args {
    foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
      foreach {submethod subinfo} $einfo {
        dict set emap $ensemble $submethod $subinfo
      }
    }
  }
  return $emap
}

proc ::tool::ensemble_methods emap {
  set result {}
  foreach {ensemble einfo} $emap {
    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]
      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      set default $body
      dict unset einfo default:
    }
    set methodlist {}
    foreach item [dict keys $einfo] {
      lappend methodlist [string trimright $item :]
    }
    set methodlist  [lsort -dictionary -unique $methodlist]
    foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
      if {$submethod in {"_preamble:" "default:"}} continue
      set submethod [string trimright $submethod :]
      lassign $esubmethodinfo arglist realbody
      if {[string length [string trim $realbody]] eq {}} {
        dict set eswitch $submethod {}
      } else {
        if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
          set body {}
        } else {
          set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
        }
        append body "\n      " [string trim $realbody] "      \n"
        dict set eswitch $submethod $body
      }
    }
    if {![dict exists $eswitch <list>]} {
      dict set eswitch <list> {return $methodlist}
    }
    if {$default=="standard"} {
      set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
    }
    dict set eswitch default $default
    set mbody {}    
    if {[dict exists $einfo _preamble:]} {
      append mbody [lindex [dict get $einfo _preamble:] 1] \n
    }
    append mbody \n [list set methodlist $methodlist]
    append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append mbody \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $mbody]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tool::dynamic_object_ensembles {thisobject thisclass} {
  variable trace
  set ensembledict {}
  foreach dclass $::tool::dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::tool::obj_ensemble_cache($cclass)
      }
    }
  }
  set ::tool::dirty_classes {}
  ###
  # Only go through the motions for classes that have a locally defined
  # ensemble method implementation
  ###
  foreach aclass [::oo::meta::ancestors $thisclass] {
    if {[info exists ::tool::obj_ensemble_cache($aclass)]} continue
    set emap [::tool::ensemble_build_map $aclass]
    set body [::tool::ensemble_methods $emap]
    oo::define $aclass $body
    # Define a property for this ensemble for introspection
    foreach {ensemble einfo} $emap {
      ::oo::meta::info $aclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
    }
    set ::tool::obj_ensemble_cache($aclass) 1
  }
}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tool::define::method {rawmethod args} {
  set class [current_class]
  set mlist [split $rawmethod "::"]
  if {[llength $mlist]==1} {
    ###
    # Simple method, needs no parsing
    ###
    set method $rawmethod
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  set ensemble [lindex $mlist 0]
  set method [join [lrange $mlist 2 end] "::"]
  switch [llength $args] {
    1 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: [list dictargs [lindex $args 0]]
    }
    2 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: $args
    }
    default {
      error "Usage: method NAME ARGLIST BODY"
    }
  }
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal dict
###
proc ::tool::define::dictobj args {
  dict_ensemble {*}$args
}
proc ::tool::define::dict_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  set initial [dict getnull $cases initialize]
  variable $varname $initial
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  }
  set template [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      dict set %VARNAME% $field $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      dict set %VARNAME% $field $result
    }
    initial {} {
      return [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
    }
    reset {} {
      set %VARNAME% [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
      return $%VARNAME%
    }
    dump {} {
      return $%VARNAME%
    }
    append args {
      return [dict $method %VARNAME% {*}$args]
    }
    incr args {
      return [dict $method %VARNAME% {*}$args]
    }
    lappend args {
      return [dict $method %VARNAME% {*}$args]
    }
    set args {
      return [dict $method %VARNAME% {*}$args]
    }
    unset args {
      return [dict $method %VARNAME% {*}$args]
    }
    update args {
      return [dict $method %VARNAME% {*}$args]
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        dict set %VARNAME% {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    rmerge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%  
    }
    merge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%
    }
    replace args {
      set %VARNAME% [dict rmerge $%VARNAME% {%INITIAL%} {*}$args]
    }
    default args {
      return [dict $method $%VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

proc ::tool::define::arrayobj args {
  array_ensemble {*}$args
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal array
###
proc ::tool::define::array_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  set initial [dict getnull $cases initialize]
  array $varname $initial

  set map [list %CLASS% $class %METHOD% $methodname %VARNAME% $varname %CASES% $CASES %INITIAL% $initial]

  ::oo::define $class method _${methodname}Get {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return $%VARNAME%($field)
    }
    return [my meta getnull %VARNAME% $field:]
  }]
  ::oo::define $class method _${methodname}Exists {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return 1
    }
    return [my meta exists %VARNAME% $field:]
  }]
  set methoddata [::oo::meta::info $class set array_ensemble $methodname: $varname]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  } 
  set template  [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    reset {} {
      ::array unset %VARNAME% *
      foreach {field value} [my meta getnull %VARNAME%] {
        set %VARNAME%([string trimright $field :]) $value
      }
      ::array set %VARNAME% {%INITIAL%}
      return [array get %VARNAME%]
    }
    ni value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value ni $data}]
    }
    in value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value in $data}]
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      set %VARNAME%($field) $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      set %VARNAME%($field) $result
    }
    dump {} {
      set result {}
      foreach {var val} [my meta getnull %VARNAME%] {
        dict set result [string trimright $var :] $val
      }
      foreach {var val} [lsort -dictionary -stride 2 [array get %VARNAME%]] {
        dict set result [string trimright $var :] $val
      }
      return $result
    }
    exists args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Exists $field]
    }
    getnull args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]      
    }
    get field {
      set field [string trimright $field :]
      set data [my _%METHOD%Get $field]
    }
    set args {
      set field [string trimright [lindex $args 0] :]
      ::set %VARNAME%($field) {*}[lrange $args 1 end]        
    }
    append args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      ::append data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    incr args {
      set field [string trimright [lindex $args 0] :]
      ::incr %VARNAME%($field) {*}[lrange $args 1 end]
    }
    lappend args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      $method data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        set %VARNAME%([string trimright $field :]) $value
      }
    }
    rmerge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    merge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    default args {
      return [array $method %VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

###
# This file implements the Tool event manager
###

::namespace eval ::tool {}

::namespace eval ::tool::event {}

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tool::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
#    Generate an event
#    Adds a subscription mechanism for objects
#    to see who has recieved this event and prevent
#    spamming or infinite recursion
###
proc ::tool::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::tool::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::tool::event::notify $who $self $event $info}
  }
}

###
# topic: 891289a24b8cc52b6c228f6edb169959
# title: Return a unique event handle
###
proc ::tool::event::nextid {} {
  return "event#[format %0.8x [incr ::tool::event_count]]"
}

###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::tool::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::tool::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}

###
# topic: b4b12f6aed69f74529be10966afd81da
###
proc ::tool::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return 
  if {$::tool::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tool::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tool::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::tool::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
}

proc ::tool::event::sleep msec {
  ::cron::sleep $msec
}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tool::event::subscribe {self who event} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue      
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}

###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::tool::event::unsubscribe {self args} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }  
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the 
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

::tool::define ::tool::object {
  ###
  # topic: 20b4a97617b2b969b96997e7b241a98a
  ###
  method event {submethod args} {
    ::tool::event::$submethod [self] {*}$args
  }
}

###
# topic: 37e7bd0be3ca7297996da2abdf5a85c7
# description: The event manager for Tool
###
namespace eval ::tool::event {
  variable nextevent {}
  variable nexteventtime 0
}

#-------------------------------------------------------------------------
# TITLE: 
#    tool.tcl
#
# PROJECT:
#    tool: TclOO Helper Library
#
# DESCRIPTION:
#    tool(n): Implementation File
#
#-------------------------------------------------------------------------

namespace eval ::tool {}

###
# New OO Keywords for TOOL
###
namespace eval ::tool::define {}
proc ::tool::define::array {name {values {}}} {
  set class [current_class]
  set name [string trimright $name :]:
  if {![::oo::meta::info $class exists array $name]} {
    ::oo::meta::info $class set array $name {}
  }
  foreach {var val} $values {
    ::oo::meta::info $class set array $name: $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::tool::define::component {name info} {
  set class [current_class]
  ::oo::meta::info $class branchset component $name $info
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tool::define::constructor {arglist rawbody} {
  set body {
::tool::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  append body {
# Run "initialize"
my initialize
  }
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
# topic: 7a5c7e04989704eef117ff3c9dd88823
# title: Specify the a method for the class object itself, instead of for objects of the class
###
proc ::tool::define::class_method {name arglist body} {
  set class [current_class]
  ::oo::meta::info $class set class_typemethod $name: [list $arglist $body]
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tool::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::tool::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

###
# topic: 8bcae430f1eda4ccdb96daedeeea3bd409c6bb7a
# description: Add properties and option handling
###
proc ::tool::define::property args {
  set class [current_class]
  switch [llength $args] {
    2 {
      set type const
      set property [string trimleft [lindex $args 0] :]
      set value [lindex $args 1]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    3 {
      set type     [lindex $args 0]
      set property [string trimleft [lindex $args 1] :]
      set value    [lindex $args 2]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    default {
      error "Usage:
property name type valuedict
OR property name value"
    }
  }
  ::oo::meta::info $class set {*}$args
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::tool::define::variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :]
  ::oo::meta::info $class set variable $name: $default
  ::oo::define $class variable $name
}

###
# Utility Procedures
###

# topic: 643efabec4303b20b66b760a1ad279bf
###
proc ::tool::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

###
# topic: b40970b0d9a2525990b9105ec8c96d3d
###
proc ::tool::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimright [string trimleft $var -] :] $val
  }
  return $result
}

###
# topic: a92cd258900010f656f4c6e7dbffae57
###
proc ::tool::dynamic_methods class {
  ::oo::meta::rebuild $class
  set metadata [::oo::meta::metadata $class]
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class $metadata
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tool::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of tool
      ###
      set dictargs [::tool::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}

###
# topic: b88add196bb63abccc44639db5e5eae1
###
proc ::tool::dynamic_methods_class {thisclass metadata} {
  foreach {method info} [dict getnull $metadata class_typemethod] {
    lassign $info arglist body
    set method [string trimright $method :]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tool::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::tool::object_create {objname {class {}}} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    set ${varname}($objname) {}
  }
  if {$class eq {}} {
    set class [info object class $objname]
  }
   set object_info($objname) [list class $class]
  if {$class ne {}} {
    $objname graft class $class
    foreach command [info commands [namespace current]::dynamic_object_*] {
      $command $objname $class
    }
  }
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    if {[info exists ${varname}($object)]} {
      set ${varname}($newname) [set ${varname}($object)]
      unset ${varname}($object)
    }
  }
  variable coroutine_object
  foreach {coro coro_objname} [array get coroutine_object] {
    if { $object eq $coro_objname } {
      set coroutine_object($coro) $newname
    }
  }
  rename $object ::[string trimleft $newname]
  ::tool::event::generate $object object_rename [list newname $newname]
}

proc ::tool::object_destroy objname {
  ::tool::event::generate $objname object_destroy [list objname $objname]
  ::tool::event::cancel $objname *
  ::cron::object_destroy $objname
  variable coroutine_object
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    unset -nocomplain ${varname}($objname)
  }
}

#-------------------------------------------------------------------------
# Option Handling Mother of all Classes

# tool::object
#
# This class is inherited by all classes that have options.
#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  variable mixinmap {}
  variable DestroyEvent 0

  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    
  method ancestors {{reverse 0}} {
    set result [::oo::meta::ancestors [info object class [self]]]
    if {$reverse} {
      return [lreverse $result]
    }
    return $result
  }
  
  method DestroyEvent {} {
    my variable DestroyEvent
    return $DestroyEvent
  }
  
  ###
  # title: Forward a method
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }
  
  ###
  # title: Direct a series of sub-functions to a seperate object
  ###
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      if {$stub eq "class"} {
        # Force class to always track the object's current class
        set obj [info object class [self]]
      }
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }
  
  # Called after all options and public variables are initialized
  method initialize {} {}
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method InitializePublic {} {
    my variable config meta
    if {![info exists meta]} {
      set meta {}
    }
    if {![info exists config]} {
      set config {}
    }
    my ClassPublicApply {}
  }
  
  class_method info {which} {
    my variable cache
    if {![info exists cache($which)]} {
      set cache($which) {}
      switch $which {
        public {
          dict set cache(public) variable [my meta branchget variable]
          dict set cache(public) array [my meta branchget array]
          set optinfo [my meta getnull option]
          dict set cache(public) option_info $optinfo
          foreach {var info} [dict getnull $cache(public) option_info] {
            if {[dict exists $info aliases:]} {
              foreach alias [dict exists $info aliases:] {
                dict set cache(public) option_canonical $alias $var
              }
            }
            set getcmd [dict getnull $info default-command:]
            if {$getcmd ne {}} {
              dict set cache(public) option_default_command $var $getcmd
            } else {
              dict set cache(public) option_default_value $var [dict getnull $info default:]
            }
            dict set cache(public) option_canonical $var $var
          }
        }
      }
    }
    return $cache($which)
  }
  
  ###
  # Incorporate the class's variables, arrays, and options
  ###
  method ClassPublicApply class {
    my variable config
    set integrate 0
    if {$class eq {}} {
      set class [info object class [self]]      
    } else {
      set integrate 1
    }
    set public [$class info public]
    foreach {var value} [dict getnull $public variable] {
      if { $var in {meta config} } continue
      my variable $var
      if {![info exists $var]} {
        set $var $value
      }
    }
    foreach {var value} [dict getnull $public array] {
      if { $var eq {meta config} } continue
      my variable $var
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          set ${var}($f) $v
        }
      }
    }
    set dat [dict getnull $public option_info]
    if {$integrate} {
      my meta rmerge [list option $dat]
    }
    my variable option_canonical
    array set option_canonical [dict getnull $public option_canonical]
    set dictargs {}
    foreach {var getcmd} [dict getnull $public option_default_command] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var [{*}[string map [list %field% $var %self% [namespace which my]] $getcmd]]
    }
    foreach {var value} [dict getnull $public option_default_value] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var $value
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      if {[dict exists $config $field]} continue
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set prior $mixins

    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      if {$class ni $prior} {
        my meta mixin $class
      }
      my ClassPublicApply $class
    }
    foreach class $prior {
      if {$class ni $mixins } { 
        my meta mixout $class
      }
    }
  }

  method mixinmap args { 
    my variable mixinmap
    set priorlist {}
    foreach {slot classes} $args {
      if {[dict exists $mixinmap $slot]} {
        lappend priorlist {*}[dict get $mixinmap $slot]  
        foreach class [dict get $mixinmap $slot] {
          if {$class ni $classes && [$class meta exists mixin unmap-script:]} {
            if {[catch [$class meta get mixin unmap-script:] err errdat]} {
              puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
            }
          }
        }
      }
      dict set mixinmap $slot $classes
    }
    my Recompute_Mixins
    foreach {slot classes} $args {
      foreach class $classes {
        if {$class ni $priorlist && [$class meta exists mixin map-script:]} {
          if {[catch [$class meta get mixin map-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
    foreach {slot classes} $mixinmap {
      foreach class $classes {
        if {[$class meta exists mixin react-script:]} {
          if {[catch [$class meta get mixin react-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR REACTING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
  }

  method debug_mixinmap {} {
    my variable mixinmap
    return $mixinmap
  }

  method Recompute_Mixins {} {
    my variable mixinmap
    set classlist {}
    foreach {item class} $mixinmap {
      if {$class ne {}} {
        lappend classlist $class
      }
    }
    my mixin {*}$classlist
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      my Morph_leave
      my variable mixins
      oo::objdefine [self] class ::${newclass}
      my graft class ::${newclass}
      # Reapply mixins
      my mixin {*}$mixins
      my InitializePublic
      my Morph_enter
    }
  }

  ###
  # Commands to perform as this object transitions out of the present class
  ###
  method Morph_leave {} {}
  ###
  # Commands to perform as this object transitions into this class as a new class
  ###
  method Morph_enter {} {}
  
  ###
  # title: List which objects are forwarded as organs
  ###
  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }
}

###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tool::define::option {name args} {
  set class [current_class]
  set dictargs {default: {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimright [string trimleft $var -] :]: $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class:]
  if {$optclass ne {}} {
    foreach {f v} [::oo::meta::info $class getnull option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default:]
    }
  }
  ::oo::meta::info $class branchset option $name $dictargs
}

###
# topic: 827a3a331a2e212a6e301f59c1eead59
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::tool::define::option_class {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  ::oo::meta::info $class branchset option_class $name $dictargs
}

::tool::define ::tool::object {
  property options_strict 0
  variable organs {}

  option_class organ {
    widget label
    set-command {my graft %field% %value%}
    get-command {my organ %field%}
  }

  option_class variable {
    widget entry
    set-command {my variable %field% ; set %field% %value%}
    get-command {my variable %field% ; set %field%}
  }
  
  dict_ensemble config config {
    get {
      return [my Config_get {*}$args]
    }
    merge {
      return [my Config_merge {*}$args]
    }
    set {
      my Config_set {*}$args
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget args {
    return [my Config_get {*}$args]
  }

  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }

  method Config_get {field args} {
    my variable config option_canonical option_getcmd
    set field [string trimleft $field -]
    if {[info exists option_canonical($field)]} {
      set field $option_canonical($field)
    }
    if {[info exists option_getcmd($field)]} {
      return [eval $option_getcmd($field)]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    if {[llength $args]} {
      return [lindex $args 0]
    }
    return [my meta cget $field] 
  }
  
  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method Config_merge dictargs {
    my variable config option_canonical
    set rawlist $dictargs
    set dictargs {}
    set dat [my meta getnull option]
    foreach {field val} $rawlist {
      set field [string trimleft $field -]
      set field [string trimright $field :]
      if {[info exists option_canonical($field)]} {
        set field $option_canonical($field)
      }
      dict set dictargs $field $val
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    return $dictargs
  }
  
  method Config_set args {
    set dictargs [::tool::args_to_options {*}$args]
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }
  
  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method Config_triggers dictargs {
    set dat [my meta getnull option]
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field post-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }

  method Option_Default field {
    set info [my meta getnull option $field]
    set getcmd [dict getnull $info default-command:]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
    } else {
      return [dict getnull $info default:]
    }
  }
}

package provide tool::option 0.1

###
# A special class of objects that
# stores no meta data of its own
# Instead it vampires off of the master object
###
tool::class create ::tool::organelle {
  
  constructor {master} {
    my entangle $master
    set final_class [my select]
    if {[info commands $final_class] ne {}} {
      # Safe to switch class here, we haven't initialized anything
      oo::objdefine [self] class $final_class
    }
    my initialize
  }

  method entangle {master} {
    my graft master $master
    my forward meta $master meta
    foreach {stub organ} [$master organ] {
      my graft $stub $organ
    }
    foreach {methodname variable} [my meta branchget array_ensemble] {
      my forward $methodname $master $methodname
    }
  }
  
  method select {} {
    return {}
  }
}

::namespace eval ::tool::signal {}
::namespace eval ::tao {}

# Provide a backward compatible hook
proc ::tool::main {} {
  ::cron::main
}

proc ::tool::do_events {} {
  ::cron::do_events
}

proc ::tao::do_events {} {
  ::cron::do_events
}

proc ::tao::main {} {
  ::cron::main
}


package provide tool::pipeline 0.1

###
# Add configure by script facilities to TOOL
###
::tool::define ::tool::object {

  ###
  # Allows for a constructor to accept a psuedo-code
  # initialization script which exercise the object's methods
  # sans "my" in front of every command
  ###
  method Eval_Script script {
    set buffer {}
    set thisline {}
    foreach line [split $script \n] {
      append thisline $line
      if {![info complete $thisline]} {
        append thisline \n
        continue
      }
      set thisline [string trim $thisline]
      if {[string index $thisline 0] eq "#"} continue
      if {[string length $thisline]==0} continue
      if {[lindex $thisline 0] eq "my"} {
        # Line already calls out "my", accept verbatim
        append buffer $thisline \n
      } elseif {[string range $thisline 0 2] eq "::"} {
        # Fully qualified commands accepted verbatim
        append buffer $thisline \n
      } elseif {
        append buffer "my $thisline" \n
      }
      set thisline {}
    }
    eval $buffer
  }
}

::namespace eval ::tool {}

proc ::tool::is_null value {
  return [expr {$value in {{} NULL}}]
}


proc ::tool::uuid_seed args {
  if {[llength $args]==0 || ([llength $args]==1 && [is_null [lindex $args 0]])} {
    if {[info exists ::env(USERNAME)]} {
      set user $::env(USERNAME)
    } elseif {[info exists ::env(USER)]} {
      set user $::env(USER)
    } else {
      set user $::env(user)
    }
    incr ::tool::nextuuid $::tool::globaluuid
    set ::tool::UUID_Seed [list user@[info hostname] [clock format [clock seconds]]]
  } else {
    incr ::tool::globaluuid $::tool::nextuuid
    set ::tool::nextuuid 0
    set ::tool::UUID_Seed $args
  }
}

###
# topic: 0a19b0bfb98162a8a37c1d3bbfb8bc3d
# description:
#    Because the tcllib version of uuid generate requires
#    network port access (which can be slow), here's a fast
#    and dirty rendition
###
proc ::tool::uuid_generate args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [::sha1::sha1 -hex [join $block ""]]
}

###
# topic: ee3ec43cc2cc2c7d6cf9a4ef1c345c19
###
proc ::tool::uuid_short args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [string range [::sha1::sha1 -hex [join $block ""]] 0 16]
}

###
# topic: b14c505537274904578340ec1bc12af1
# description:
#    Implementation the uses a compiled in ::md5 implementation
#    commonly used by embedded application developers
###
namespace eval ::tool {
  namespace export *
}
###
# Cache the bits of the UUID seed that aren't likely to change
# once the software is loaded, but which can be expensive to
# generate
###
set ::tool::nextuuid 0
set ::tool::globaluuid 0
::tool::uuid_seed

[comment {-*- tcl -*- doctools manpage}]
[vset OOUTIL_VERSION 1.2.2]
[manpage_begin oo::util n [vset OOUTIL_VERSION]]
[see_also snit(n)]
[keywords callback]
[keywords {class methods}]
[keywords {class variables}]
[keywords {command prefix}]
[keywords currying]
[keywords {method reference}]
[keywords {my method}]
[keywords singleton]
[keywords TclOO]
[copyright {2011-2015 Andreas Kupries, BSD licensed}]
[moddesc {Utility commands for TclOO}]
[titledesc {Utility commands for TclOO}]
[category  Utility]
[require Tcl 8.5]
[require TclOO]
[require oo::util [opt [vset OOUTIL_VERSION]]]
[description]
[para]

This package provides a convenience command for the easy specification
of instance methods as callback commands, like timers, file events, Tk
bindings, etc.

[section {COMMANDS}]

[list_begin definitions]
[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd mymethod] [arg method] [opt [arg arg]...]]

This command is available within instance methods. It takes a method
name and, possibly, arguments for the method and returns a command
prefix which, when executed, will invoke the named method of the
object we are in, with the provided arguments, and any others supplied
at the time of actual invokation.

[para] Note: The command is equivalent to and named after the command
provided by the OO package [package snit] for the same purpose.

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd classmethod] [arg name] [arg arguments] [arg body]]

This command is available within class definitions. It takes a method
name and, possibly, arguments for the method and creates a method on the
class, available to a user of the class and of derived classes.

[para] Note: The command is equivalent to the command [cmd typemethod]
provided by the OO package [package snit] for the same purpose.

[para] Example
[example {
oo::class create ActiveRecord {
    classmethod find args { puts "[self] called with arguments: $args" }
}
oo::class create Table {
    superclass ActiveRecord
}
puts [Table find foo bar]
# ======
# which will write
# ======
# ::Table called with arguments: foo bar
}]

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd classvariable] [opt [arg arg]...]]

This command is available within instance methods. It takes a series
of variable names and makes them available in the method's scope. The
originating scope for the variables is the class (instance) the object
instance belongs to. In other words, the referenced variables are shared
between all instances of their class.

[para] Note: The command is roughly equivalent to the command
[cmd typevariable] provided by the OO package [package snit] for the
same purpose. The difference is that it cannot be used in the class
definition itself.

[para] Example:
[example {
% oo::class create Foo {
    method bar {z} {
        classvariable x y
        return [incr x $z],[incr y]
    }
}
::Foo
% Foo create a
::a
% Foo create b
::b
% a bar 2
2,1
% a bar 3
5,2
% b bar 7
12,3
% b bar -1
11,4
% a bar 0
11,5
}]

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd link] [arg method]...]
[call [cmd link] "{[arg alias] [arg method]}..."]

This command is available within instance methods. It takes a list of
method names and/or pairs of alias- and method-name and makes the
named methods available to all instance methods without requiring the
[cmd my] command.

[para] The alias name under which the method becomes available defaults
to the method name, except where explicitly specified through an
alias/method pair.

[para] Examples:
[example {
    link foo
    # The method foo is now directly accessible as foo instead of my foo.

    link {bar foo}
    # The method foo is now directly accessible as bar.

    link a b c
    # The methods a, b, and c all become directly acessible under their
    # own names.
}]

The main use of this command is expected to be in instance constructors,
for convenience, or to set up some methods for use in a mini DSL.

[comment {- - -- --- ----- -------- ------------- ---------------------}]
[call [cmd ooutil::singleton] [opt [arg arg]...]]

This command is a meta-class, i.e. a variant of the builtin
[cmd oo::class] which ensures that it creates only a single
instance of the classes defined with it.

[para] Syntax and results are like for [cmd oo::class].

[para] Example:
[example {
% oo::class create example {
   self mixin singleton
   method foo {} {self}
}
::example
% [example new] foo
::oo::Obj22
% [example new] foo
::oo::Obj22
}]

[list_end]

[section AUTHORS]
Donal Fellows, Andreas Kupries

[vset CATEGORY oo::util]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

my shed set name: tool
my shed set origin: http://fossil.etoyoc.com/fossil/tool
my shed set description: {
The base of the TOOL framework
}
foreach file [glob -nocomplain [file join $dir *]] {
  my scan $file {class: source}
}

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool 0.7 [list source [file join $dir tool.tcl]]

set here [file dirname [file join [pwd] [info script]]]
puts LOADING
source [file join $here .. oodialect oodialect.tcl]
source [file join $here .. dicttool dicttool.tcl]
source [file join $here .. oometa oometa.tcl]
source [file join $here .. sha1 sha1.tcl]

source [file join $here index.tcl]

tool::class create foo {
  option color {default blue}
}

puts "START DEMO"
foo create bar
puts [bar cget color]
bar configure color green
puts [bar cget color]


tool::class create car {
  option color {
    default: white
  }
  variable location home
  array physics {
    speed 0
    accel 0
    position {0 0}
  }

  method physics {field args} {
    my variable physics
    if {[llength $args]} {
      set physics($field) $args
    }
    return $physics($field)
  }
  method location {} {
    my variable location
    return $location
  }
  method move newloc {
    my variable location
    set location $newloc
  }
}

car create car1 color green
car1 cget color
#> green
car create car2
car2 cget color
#> white

car1 location
#> home
car1 move work
car1 location
#> work
puts [car1 physics speed]
#> 0
car1 physics speed 10
puts [car1 physics speed]
#> 10

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tool n 0.4.2]
[keywords TOOL]
[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Standardized OO Framework for development}]
[titledesc {TclOO Library (TOOL) Framework}]
[category TclOO]
[keywords TclOO]
[keywords framework]
[require Tcl 8.6]
[require sha1]
[require dicttool]
[require oo::meta]
[require oo::dialect]
[description]
[para]
This module implements the Tcl Object Oriented Library framework, or [emph TOOL]. It is
intended to be a general purpose framework that is useable in its own right, and
easily extensible.
[para]
TOOL defines a metaclass with provides several additional keywords to the TclOO
description langauge, default behaviors for its consituent objects, and
top-down integration with the capabilities provided by the [package oo::meta] package.
[para]
The TOOL metaclass was build with the [package oo::dialect] package, and thus can
be used as the basis for additional metaclasses. As a metaclass, TOOL has it's own
"class" class, "object" class, and define namespace.
[example {
package require tool

# tool::class workds just like oo::class
tool::class create myclass {
}

# tool::define works just like oo::define
tool::define myclass method noop {} {}

# tool::define and tool::class understand additional keywords
tool::define myclass array_ensemble mysettings mysettings {}

# And tool interoperates with oo::define
oo::define myclass method do_something {} { return something }

# TOOL and TclOO objects are interchangeable
oo::class create myooclass {
  superclass myclass
}
}]
[para]
Several manual pages go into more detail about specific keywords and methods.
[list_begin definitions]
[def [package tool::array_ensemble]]
[def [package tool::dict_ensemble]]
[def [package tool::method_ensemble]]
[def [package tool::object]]
[def [package tool::option_handling]]
[list_end]

[section Keywords]
TOOL adds new (or modifies) keywords used in the definitions of classes. However,
the new keywords are only available via calls to [emph {tool::class create}] or [emph tool::define]

[list_begin definitions]

[call tool::define [cmd class_method] [arg arglist] [arg body]]
Defines a method for the class object itself. This method will be passed on to descendents of the class,
unlike [cmd {self method}].

[call tool::define [cmd array] [arg name] [arg contents]]

Declares a variable [arg name] which will be initialized as an array, populated with [arg contents] for objects of this class, as well as any
objects for classes which are descendents of this class.

[call tool::define [cmd array_ensemble] [arg methodname] [arg varname] [opt cases]]

Declares a method ensemble [arg methodname] which will control access to variable
[arg varname]. Cases are a key/value list of method names and bodies which will be
overlaid on top of the standard template. See [package tool::array_ensemble].
[para]
One method name is reserved: [cmd initialize]. [cmd initialize] Declares the initial values to be populated in the array, as a key/value list,
and will not be expressed as a method for the ensemble.

[call tool::define [cmd dict_ensemble] [arg methodname] [arg varname] [opt cases]]

Declares a method ensemble [arg methodname] which will control access to variable
[arg varname]. Cases are a key/value list of method names and bodies which will be
overlaid on top of the standard template. See [package tool::dict_ensemble].
[para]
One method name is reserved: [cmd initialize]. [cmd initialize] Declares the initial values to be populated in the array, as a key/value list,
and will not be expressed as a method for the ensemble.

[call tool::define [cmd method] [arg methodname] [arg arglist] [arg body]]

If [arg methodname] contains ::, the method is considered to be
part of a method ensemble. See [package tool::method_ensembles]. Otherwise
this command behaves exactly like the standard [namespace oo::define] [cmd method]
command.


[call tool::define [cmd option] [arg name] [arg dictopts]]

Declares an option. [arg dictopts] is a key/value list defining parameters for the option. See [package tool::option_handling].

[example {
tool::class create myclass {
  option color {
    post-command: {puts [list %self%'s %field% is now %value%]}
    default: green
  }
}
myclass create foo
foo configure color purple
> foo's color is now purple
}]

[call tool::define [cmd property] [opt branch] [arg field] [arg value]]

Defines a new leaf in the class metadata tree. With no branch, the
leaf will appear in the [emph const] section, accessible by either the
object's [cmd property] method, or via [cmd oo::meta::info] [emph class] [cmd {get const}] [emph field]:

[call tool::define [cmd variable] [arg name] [arg value]]

Declares a variable [arg name] which will be initialized with the value [arg value] for objects of this class, as well as any
objects for classes which are descendents of this class.

[list_end]

[section {Public Object Methods}]

The TOOL object mother of all classes defines several methods to enforces consistent
behavior throughout the framework.

[list_begin definitions]

[call [emph object] [cmd cget] [arg option]]

Return the value of this object's option [arg option]. If the [cmd {property options_strict}] is true
for this class, calling an option which was not declared by the [cmd option] keyword will throw
an error. In all other cases if the value is present in the object's [emph options] array that
value is returned. If it does not exist, the object will attempt to retrieve a property of the same
name.

[call [emph object] [cmd configure] [opt keyvaluelist]]
[call [emph object] [cmd configure] [arg field] [arg value] [opt field] [opt value] [opt ...]]

This command will inject new values into the objects [emph options] array, according to the rules
as set forth by the option descriptions. See [package tool::option_handling] for details.

[cmd configure] will strip leading -'s off of field names, allowing it to behave in a quasi-backward
compatible manner to tk options.

[call [emph object] [cmd configurelist] [opt keyvaluelist]]

This command will inject new values into the objects [emph options] array, according to the rules
as set forth by the option descriptions. This command will perform validation and alternate storage
rules. It will not invoke trigger rules. See [package tool::option_handling] for details.

[call [emph object] [cmd forward] [arg stub] [arg forward]]

A passthrough to [cmd {oo:objdefine [self] forward}]

[call [emph object] [cmd graft] [arg stub] [arg forward]]

Delegates the [arg <stub>] method to the object or command designated by [arg forward]

[example {
tool::object create A
tool::object create B
A graft buddy B
A configure color red
B configure color blue
A cget color
> red
A <buddy> cget color
> blue
}]

[list_end]

[section {Private Object Methods}]
[list_begin definitions]
[call [emph object] [cmd InitializePublic]]
Consults the metadata for the class to ensure every array, option, and variable
which has been declared but not initialized is initialized with the default value.

This method is called by the constructor and the morph method. It is safe to
invoke multiple times.

[call [emph object] [cmd Eval_Script] [opt script]]
Executes a block of text within the namespace of the object. Lines that
begin with a # are ignored as comments. Commands
that begin with :: are interpreted as calling a global command. All other
Tcl commands that lack a "my" prefix are given one, to allow the script
to exercise internal methods. This method is intended for configuration scripts,
where the object's methods are intepreting a domain specific language.

[example {
tool::class myclass {
  constructor script {
    my Eval_Script $script
  }
  method node {nodename info} {
    my variable node
    dict set node $nodename $info
  }
  method get {args} {
    my variable node
    return [dict get $node $args]
  }
}
myclass create movies {
  # This block of code is executed by the object
  node {The Day the Earth Stood Still} {
    date: 1952
    characters: {GORT Klatoo}
  }
}
movies get {The Day the Earth Stood Still} date:
> 1952
}]

[call [emph object] [cmd Option_Default] [arg field]]

Computes the default value for an option. See [package tool::option_handling].

[list_end]

[section AUTHORS]
Sean Woods

[vset CATEGORY tcloo]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Module: TOOL
============

TOOL is the Tcl Object Oriented Library, a standard object framework. TOOL
implements common design patterns in a standardized, tested, and documented
manner. 

# Major Concepts

* Metadata Interitance
* Variable and Array Initialization
* Option handling
* Delegation
* Method Ensembles

## Using TOOL

Tool is accessed from the "tool" package:

<pre><code>
package require tool
</code></pre>

## Metadata Interitance

TOOL builds on the oo::meta package to allow data and configuration to be
passed along to descendents in the same way methods are.

<pre><code>tool::class create fruit {
  property taste sweet
}
tool::class create fruit.apple {
  property color red
}
tool::class create fruit.orange {
  property color orange
}
fruit.orange create cutie
cutie property color
> orange
cutie property taste
> sweet
</code></pre>

## Variable and Array Initialization

TOOL modifies the *variable* keyword and adds and *array* keyword. Using
either will cause a variable of the given name to be initialized with the
given value for this class AND any descendents.

<pre><code>tool::class create car {
  option color {
    default: white
  }
  variable location home
  array physics {
    speed 0
    accel 0
    position {0 0}
  }

  method physics {field args} {
    my variable physics
    if {[llength $args]} {
      set physics($field) $args
    }
    return $physics($field)
  }
  method location {} {
    my variable location
    return $location
  }
  method move newloc {
    my variable location
    set location $newloc
  }
}

car create car1 color green
car1 cget color
> green
car create car2
car2 cget color
> white

car1 location
> home
car1 move work
car1 location
> work
car1 physics speed
> 0
car1 physics speed 10
car1 physics speed
> 10
</code></pre>

## Delegation

TOOL is built around objects delegating functions to other objects. To
keep track of which object is handling what function, TOOL provides
two methods *graft* and *organ*.

<pre><code>tool::class create human {}

human create bob name Robert
car1 graft driver bob
bob graft car car1
bob &lt;car&gt; physics speed
> 10
car1 &lt;driver&gt; cget name
> Robert
car1 organ driver
> bob
bob organ car
> car1
</code></pre>

## Method Ensembles

TOOL also introduces the concept of a method ensemble. To declare an ensemble
use a :: delimter in the name of the method.

<pre><code>tool::class create special {

  method foo::bar {} {
    return bar
  }
  method foo::baz {} {
    return baz
  }
  method foo::bat {} {
    return bat
  }
}

special create blah
bah foo <list>
> bar bat baz
bah foo bar
> bar
bar foo bing
> ERROR: Invalid command "bing", Valid: bar, bat, baz
</code></pre>

Keep in mind that everything is changeable on demand in TOOL,
and if you define a *default* method that will override the standard
unknown reply:

<pre><code>tool::define special {
  method foo::default args {
    return [list $method $args]  
  }
}
bar foo bing
> bing
</code></pre>

###
# Amalgamated package for tool
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package provide tool 0.7
namespace eval ::tool {}

###
# START: core.tcl
###
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
#package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0

proc ::tool::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::tool::module {cmd args} {
  ::variable moduleStack
  ::variable module

  switch $cmd {
    push {
      set module [lindex $args 0]
      lappend moduleStack $module
      return $module
    }
    pop {
      set priormodule      [lindex $moduleStack end]
      set moduleStack [lrange $moduleStack 0 end-1]
      set module [lindex $moduleStack end]
      return $priormodule
    }
    peek {
      set module      [lindex $moduleStack end]
      return $module
    }
    default {
      error "Invalid command \"$cmd\". Valid: peek, pop, push"
    }
  }
}
::tool::module push core

proc ::tool::pathload {path {order {}} {skip {}}} {
  ###
  # On windows while running under a VFS, the system sometimes
  # gets confused about the volume we are running under
  ###
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string range $path 1 6] eq ":/zvfs"} {
      set path [string range $path 2 end]
    }
  }
  set loaded {pkgIndex.tcl index.tcl}
  foreach item $skip {
    lappend loaded [file tail $skip]
  }
  if {[file exists [file join $path metaclass.tcl]]} {
    lappend loaded metaclass.tcl
    uplevel #0 [list source [file join $path metaclass.tcl]]
  }
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $order {
    set file [file tail $file]
    if {$file in $loaded} continue
    if {![file exists [file join $path $file]]} {
      puts "WARNING [file join $path $file] does not exist in [info script]"
    } else {
      uplevel #0 [list source [file join $path $file]]
    }
    lappend loaded $file
  }
  foreach file [lsort -dictionary [glob -nocomplain [file join $path *.tcl]]] {
    if {[file tail $file] in $loaded} continue
    uplevel #0 [list source $file]
    lappend loaded [file tail $file]
  }
}

###
# END: core.tcl
###
###
# START: uuid.tcl
###
::namespace eval ::tool {}

proc ::tool::is_null value {
  return [expr {$value in {{} NULL}}]
}


proc ::tool::uuid_seed args {
  if {[llength $args]==0 || ([llength $args]==1 && [is_null [lindex $args 0]])} {
    if {[info exists ::env(USERNAME)]} {
      set user $::env(USERNAME)
    } elseif {[info exists ::env(USER)]} {
      set user $::env(USER)
    } else {
      set user $::env(user)
    }
    incr ::tool::nextuuid $::tool::globaluuid
    set ::tool::UUID_Seed [list user@[info hostname] [clock format [clock seconds]]]
  } else {
    incr ::tool::globaluuid $::tool::nextuuid
    set ::tool::nextuuid 0
    set ::tool::UUID_Seed $args
  }
}

###
# topic: 0a19b0bfb98162a8a37c1d3bbfb8bc3d
# description:
#    Because the tcllib version of uuid generate requires
#    network port access (which can be slow), here's a fast
#    and dirty rendition
###
proc ::tool::uuid_generate args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [::sha1::sha1 -hex [join $block ""]]
}

###
# topic: ee3ec43cc2cc2c7d6cf9a4ef1c345c19
###
proc ::tool::uuid_short args {
  if {![llength $args]} {
    set block [list [incr ::tool::nextuuid] {*}$::tool::UUID_Seed]
  } else {
    set block $args
  }
  return [string range [::sha1::sha1 -hex [join $block ""]] 0 16]
}

###
# topic: b14c505537274904578340ec1bc12af1
# description:
#    Implementation the uses a compiled in ::md5 implementation
#    commonly used by embedded application developers
###
namespace eval ::tool {
  namespace export *
}
###
# Cache the bits of the UUID seed that aren't likely to change
# once the software is loaded, but which can be expensive to
# generate
###
set ::tool::nextuuid 0
set ::tool::globaluuid 0
::tool::uuid_seed

###
# END: uuid.tcl
###
###
# START: ensemble.tcl
###
::namespace eval ::tool::define {}

if {![info exists ::tool::dirty_classes]} {
  set ::tool::dirty_classes {}
}

###
# Monkey patch oometa's rebuild function to
# include a notifier to tool
###
proc ::oo::meta::rebuild args {
  foreach class $args {
    if {$class ni $::oo::meta::dirty_classes} {
      lappend ::oo::meta::dirty_classes $class
    }
    if {$class ni $::tool::dirty_classes} {
      lappend ::tool::dirty_classes $class
    }
  }
}

proc ::tool::ensemble_build_map args {
  set emap {}
  foreach thisclass $args {
    foreach {ensemble einfo} [::oo::meta::info $thisclass getnull method_ensemble] {
      foreach {submethod subinfo} $einfo {
        dict set emap $ensemble $submethod $subinfo
      }
    }
  }
  return $emap
}

proc ::tool::ensemble_methods emap {
  set result {}
  foreach {ensemble einfo} $emap {
    #set einfo [dict getnull $einfo method_ensemble $ensemble]
    set eswitch {}
    set default standard
    if {[dict exists $einfo default:]} {
      set emethodinfo [dict get $einfo default:]
      set arglist     [lindex $emethodinfo 0]
      set realbody    [lindex $emethodinfo 1]
      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      set default $body
      dict unset einfo default:
    }
    set methodlist {}
    foreach item [dict keys $einfo] {
      lappend methodlist [string trimright $item :]
    }
    set methodlist  [lsort -dictionary -unique $methodlist]
    foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
      if {$submethod in {"_preamble:" "default:"}} continue
      set submethod [string trimright $submethod :]
      lassign $esubmethodinfo arglist realbody
      if {[string length [string trim $realbody]] eq {}} {
        dict set eswitch $submethod {}
      } else {
        if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
          set body {}
        } else {
          set body "\n      ::tool::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
        }
        append body "\n      " [string trim $realbody] "      \n"
        dict set eswitch $submethod $body
      }
    }
    if {![dict exists $eswitch <list>]} {
      dict set eswitch <list> {return $methodlist}
    }
    if {$default=="standard"} {
      set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
    }
    dict set eswitch default $default
    set mbody {}    
    if {[dict exists $einfo _preamble:]} {
      append mbody [lindex [dict get $einfo _preamble:] 1] \n
    }
    append mbody \n [list set methodlist $methodlist]
    append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
    append mbody \n {return -options $opts $result}
    append result \n [list method $ensemble {{method default} args} $mbody]    
  }
  return $result
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tool::dynamic_object_ensembles {thisobject thisclass} {
  variable trace
  set ensembledict {}
  foreach dclass $::tool::dirty_classes {
    foreach {cclass cancestors} [array get ::oo::meta::cached_hierarchy] {
      if {$dclass in $cancestors} {
        unset -nocomplain ::tool::obj_ensemble_cache($cclass)
      }
    }
  }
  set ::tool::dirty_classes {}
  ###
  # Only go through the motions for classes that have a locally defined
  # ensemble method implementation
  ###
  foreach aclass [::oo::meta::ancestors $thisclass] {
    if {[info exists ::tool::obj_ensemble_cache($aclass)]} continue
    set emap [::tool::ensemble_build_map $aclass]
    set body [::tool::ensemble_methods $emap]
    oo::define $aclass $body
    # Define a property for this ensemble for introspection
    foreach {ensemble einfo} $emap {
      ::oo::meta::info $aclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
    }
    set ::tool::obj_ensemble_cache($aclass) 1
  }
}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tool::define::method {rawmethod args} {
  set class [current_class]
  set mlist [split $rawmethod "::"]
  if {[llength $mlist]==1} {
    ###
    # Simple method, needs no parsing
    ###
    set method $rawmethod
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  set ensemble [lindex $mlist 0]
  set method [join [lrange $mlist 2 end] "::"]
  switch [llength $args] {
    1 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: [list dictargs [lindex $args 0]]
    }
    2 {
      ::oo::meta::info $class set method_ensemble $ensemble $method: $args
    }
    default {
      error "Usage: method NAME ARGLIST BODY"
    }
  }
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal dict
###
proc ::tool::define::dictobj args {
  dict_ensemble {*}$args
}
proc ::tool::define::dict_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  set initial [dict getnull $cases initialize]
  variable $varname $initial
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  }
  set template [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      dict set %VARNAME% $field $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [dict getnull $%VARNAME% $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      dict set %VARNAME% $field $result
    }
    initial {} {
      return [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
    }
    reset {} {
      set %VARNAME% [dict rmerge [my meta branchget %VARNAME%] {%INITIAL%}]
      return $%VARNAME%
    }
    dump {} {
      return $%VARNAME%
    }
    append args {
      return [dict $method %VARNAME% {*}$args]
    }
    incr args {
      return [dict $method %VARNAME% {*}$args]
    }
    lappend args {
      return [dict $method %VARNAME% {*}$args]
    }
    set args {
      return [dict $method %VARNAME% {*}$args]
    }
    unset args {
      return [dict $method %VARNAME% {*}$args]
    }
    update args {
      return [dict $method %VARNAME% {*}$args]
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        dict set %VARNAME% {*}[lrange $args 0 end-1] [string trimright $field :]: $value
      }
    }
    rmerge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%  
    }
    merge args {
      set %VARNAME% [dict rmerge $%VARNAME% {*}$args]
      return $%VARNAME%
    }
    replace args {
      set %VARNAME% [dict rmerge $%VARNAME% {%INITIAL%} {*}$args]
    }
    default args {
      return [dict $method $%VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}

proc ::tool::define::arrayobj args {
  array_ensemble {*}$args
}

###
# topic: 354490e9e9708425a6662239f2058401946e41a1
# description: Creates a method which exports access to an internal array
###
proc ::tool::define::array_ensemble {methodname varname {cases {}}} {
  set class [current_class]
  set CASES [string map [list %METHOD% $methodname %VARNAME% $varname] $cases]
  set initial [dict getnull $cases initialize]
  array $varname $initial

  set map [list %CLASS% $class %METHOD% $methodname %VARNAME% $varname %CASES% $CASES %INITIAL% $initial]

  ::oo::define $class method _${methodname}Get {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return $%VARNAME%($field)
    }
    return [my meta getnull %VARNAME% $field:]
  }]
  ::oo::define $class method _${methodname}Exists {field} [string map $map {
    my variable %VARNAME%
    if {[info exists %VARNAME%($field)]} {
      return 1
    }
    return [my meta exists %VARNAME% $field:]
  }]
  set methoddata [::oo::meta::info $class set array_ensemble $methodname: $varname]
  
  set methoddata [::oo::meta::info $class getnull method_ensemble $methodname]
  foreach {name body} $CASES {
    dict set methoddata $name: [list args $body]
  } 
  set template  [string map [list %CLASS% $class %INITIAL% $initial %METHOD% $methodname %VARNAME% $varname] {
    _preamble {} {
      my variable %VARNAME%
    }
    reset {} {
      ::array unset %VARNAME% *
      foreach {field value} [my meta getnull %VARNAME%] {
        set %VARNAME%([string trimright $field :]) $value
      }
      ::array set %VARNAME% {%INITIAL%}
      return [array get %VARNAME%]
    }
    ni value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value ni $data}]
    }
    in value {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      return [expr {$value in $data}]
    }
    add args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      foreach item [lrange $args 1 end] {
        if {$item ni $data} {
          lappend data $item
        }
      }
      set %VARNAME%($field) $data
    }
    remove args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      set result {}
      foreach item $data {
        if {$item in $args} continue
        lappend result $item
      }
      set %VARNAME%($field) $result
    }
    dump {} {
      set result {}
      foreach {var val} [my meta getnull %VARNAME%] {
        dict set result [string trimright $var :] $val
      }
      foreach {var val} [lsort -dictionary -stride 2 [array get %VARNAME%]] {
        dict set result [string trimright $var :] $val
      }
      return $result
    }
    exists args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Exists $field]
    }
    getnull args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]      
    }
    get field {
      set field [string trimright $field :]
      set data [my _%METHOD%Get $field]
    }
    set args {
      set field [string trimright [lindex $args 0] :]
      ::set %VARNAME%($field) {*}[lrange $args 1 end]        
    }
    append args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      ::append data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    incr args {
      set field [string trimright [lindex $args 0] :]
      ::incr %VARNAME%($field) {*}[lrange $args 1 end]
    }
    lappend args {
      set field [string trimright [lindex $args 0] :]
      set data [my _%METHOD%Get $field]
      $method data {*}[lrange $args 1 end]
      set %VARNAME%($field) $data
    }
    branchset args {
      foreach {field value} [lindex $args end] {
        set %VARNAME%([string trimright $field :]) $value
      }
    }
    rmerge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    merge args {
      foreach arg $args {
        my %VARNAME% branchset $arg
      }
    }
    default args {
      return [array $method %VARNAME% {*}$args]
    }
  }]
  foreach {name arglist body} $template {
    if {[dict exists $methoddata $name:]} continue
    dict set methoddata $name: [list $arglist $body]
  }
  ::oo::meta::info $class set method_ensemble $methodname $methoddata
}


###
# END: ensemble.tcl
###
###
# START: metaclass.tcl
###
#-------------------------------------------------------------------------
# TITLE: 
#    tool.tcl
#
# PROJECT:
#    tool: TclOO Helper Library
#
# DESCRIPTION:
#    tool(n): Implementation File
#
#-------------------------------------------------------------------------

namespace eval ::tool {}

###
# New OO Keywords for TOOL
###
namespace eval ::tool::define {}
proc ::tool::define::array {name {values {}}} {
  set class [current_class]
  set name [string trimright $name :]:
  if {![::oo::meta::info $class exists array $name]} {
    ::oo::meta::info $class set array $name {}
  }
  foreach {var val} $values {
    ::oo::meta::info $class set array $name: $var $val
  }
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::tool::define::component {name info} {
  set class [current_class]
  ::oo::meta::info $class branchset component $name $info
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tool::define::constructor {arglist rawbody} {
  set body {
::tool::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  append body {
# Run "initialize"
my initialize
  }
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
# topic: 7a5c7e04989704eef117ff3c9dd88823
# title: Specify the a method for the class object itself, instead of for objects of the class
###
proc ::tool::define::class_method {name arglist body} {
  set class [current_class]
  ::oo::meta::info $class set class_typemethod $name: [list $arglist $body]
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tool::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::tool::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

###
# topic: 8bcae430f1eda4ccdb96daedeeea3bd409c6bb7a
# description: Add properties and option handling
###
proc ::tool::define::property args {
  set class [current_class]
  switch [llength $args] {
    2 {
      set type const
      set property [string trimleft [lindex $args 0] :]
      set value [lindex $args 1]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    3 {
      set type     [lindex $args 0]
      set property [string trimleft [lindex $args 1] :]
      set value    [lindex $args 2]
      ::oo::meta::info $class set $type $property: $value
      return
    }
    default {
      error "Usage:
property name type valuedict
OR property name value"
    }
  }
  ::oo::meta::info $class set {*}$args
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::tool::define::variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :]
  ::oo::meta::info $class set variable $name: $default
  ::oo::define $class variable $name
}

###
# Utility Procedures
###

# topic: 643efabec4303b20b66b760a1ad279bf
###
proc ::tool::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

###
# topic: b40970b0d9a2525990b9105ec8c96d3d
###
proc ::tool::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trimright [string trimleft $var -] :] $val
  }
  return $result
}

###
# topic: a92cd258900010f656f4c6e7dbffae57
###
proc ::tool::dynamic_methods class {
  ::oo::meta::rebuild $class
  set metadata [::oo::meta::metadata $class]
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class $metadata
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tool::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of tool
      ###
      set dictargs [::tool::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}

###
# topic: b88add196bb63abccc44639db5e5eae1
###
proc ::tool::dynamic_methods_class {thisclass metadata} {
  foreach {method info} [dict getnull $metadata class_typemethod] {
    lassign $info arglist body
    set method [string trimright $method :]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tool::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::tool::object_create {objname {class {}}} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    set ${varname}($objname) {}
  }
  if {$class eq {}} {
    set class [info object class $objname]
  }
   set object_info($objname) [list class $class]
  if {$class ne {}} {
    $objname graft class $class
    foreach command [info commands [namespace current]::dynamic_object_*] {
      $command $objname $class
    }
  }
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    if {[info exists ${varname}($object)]} {
      set ${varname}($newname) [set ${varname}($object)]
      unset ${varname}($object)
    }
  }
  variable coroutine_object
  foreach {coro coro_objname} [array get coroutine_object] {
    if { $object eq $coro_objname } {
      set coroutine_object($coro) $newname
    }
  }
  rename $object ::[string trimleft $newname]
  ::tool::event::generate $object object_rename [list newname $newname]
}

proc ::tool::object_destroy objname {
  ::tool::event::generate $objname object_destroy [list objname $objname]
  ::tool::event::cancel $objname *
  ::cron::object_destroy $objname
  variable coroutine_object
  foreach varname {
    object_info
    object_signal
    object_subscribe
  } {
    variable $varname
    unset -nocomplain ${varname}($objname)
  }
}

#-------------------------------------------------------------------------
# Option Handling Mother of all Classes

# tool::object
#
# This class is inherited by all classes that have options.
#

::tool::define ::tool::object {
  # Put MOACish stuff in here
  variable signals_pending create
  variable organs {}
  variable mixins {}
  variable mixinmap {}
  variable DestroyEvent 0

  constructor args {
    my Config_merge [::tool::args_to_options {*}$args]
  }
  
  destructor {}
    
  method ancestors {{reverse 0}} {
    set result [::oo::meta::ancestors [info object class [self]]]
    if {$reverse} {
      return [lreverse $result]
    }
    return $result
  }
  
  method DestroyEvent {} {
    my variable DestroyEvent
    return $DestroyEvent
  }
  
  ###
  # title: Forward a method
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }
  
  ###
  # title: Direct a series of sub-functions to a seperate object
  ###
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      if {$stub eq "class"} {
        # Force class to always track the object's current class
        set obj [info object class [self]]
      }
      dict set organs $stub $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }
  
  # Called after all options and public variables are initialized
  method initialize {} {}
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method InitializePublic {} {
    my variable config meta
    if {![info exists meta]} {
      set meta {}
    }
    if {![info exists config]} {
      set config {}
    }
    my ClassPublicApply {}
  }
  
  class_method info {which} {
    my variable cache
    if {![info exists cache($which)]} {
      set cache($which) {}
      switch $which {
        public {
          dict set cache(public) variable [my meta branchget variable]
          dict set cache(public) array [my meta branchget array]
          set optinfo [my meta getnull option]
          dict set cache(public) option_info $optinfo
          foreach {var info} [dict getnull $cache(public) option_info] {
            if {[dict exists $info aliases:]} {
              foreach alias [dict exists $info aliases:] {
                dict set cache(public) option_canonical $alias $var
              }
            }
            set getcmd [dict getnull $info default-command:]
            if {$getcmd ne {}} {
              dict set cache(public) option_default_command $var $getcmd
            } else {
              dict set cache(public) option_default_value $var [dict getnull $info default:]
            }
            dict set cache(public) option_canonical $var $var
          }
        }
      }
    }
    return $cache($which)
  }
  
  ###
  # Incorporate the class's variables, arrays, and options
  ###
  method ClassPublicApply class {
    my variable config
    set integrate 0
    if {$class eq {}} {
      set class [info object class [self]]      
    } else {
      set integrate 1
    }
    set public [$class info public]
    foreach {var value} [dict getnull $public variable] {
      if { $var in {meta config} } continue
      my variable $var
      if {![info exists $var]} {
        set $var $value
      }
    }
    foreach {var value} [dict getnull $public array] {
      if { $var eq {meta config} } continue
      my variable $var
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          set ${var}($f) $v
        }
      }
    }
    set dat [dict getnull $public option_info]
    if {$integrate} {
      my meta rmerge [list option $dat]
    }
    my variable option_canonical
    array set option_canonical [dict getnull $public option_canonical]
    set dictargs {}
    foreach {var getcmd} [dict getnull $public option_default_command] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var [{*}[string map [list %field% $var %self% [namespace which my]] $getcmd]]
    }
    foreach {var value} [dict getnull $public option_default_value] {
      if {[dict getnull $dat $var class:] eq "organ"} {
        if {[my organ $var] ne {}} continue
      }
      if {[dict exists $config $var]} continue
      dict set dictargs $var $value
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      if {[dict exists $config $field]} continue
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }
  
  ###
  # topic: 3c4893b65a1c79b2549b9ee88f23c9e3
  # description:
  #    Provide a default value for all options and
  #    publically declared variables, and locks the
  #    pipeline mutex to prevent signal processing
  #    while the contructor is still running.
  #    Note, by default an odie object will ignore
  #    signals until a later call to <i>my lock remove pipeline</i>
  ###
  method mixin args {
    ###
    # Mix in the class
    ###
    my variable mixins
    set prior $mixins

    set mixins $args
    ::oo::objdefine [self] mixin {*}$args
    ###
    # Build a compsite map of all ensembles defined by the object's current
    # class as well as all of the classes being mixed in
    ###
    set emap [::tool::ensemble_build_map [::info object class [self]] {*}[lreverse $args]]
    set body [::tool::ensemble_methods $emap]
    oo::objdefine [self] $body
    foreach class $args {
      if {$class ni $prior} {
        my meta mixin $class
      }
      my ClassPublicApply $class
    }
    foreach class $prior {
      if {$class ni $mixins } { 
        my meta mixout $class
      }
    }
  }

  method mixinmap args { 
    my variable mixinmap
    set priorlist {}
    foreach {slot classes} $args {
      if {[dict exists $mixinmap $slot]} {
        lappend priorlist {*}[dict get $mixinmap $slot]  
        foreach class [dict get $mixinmap $slot] {
          if {$class ni $classes && [$class meta exists mixin unmap-script:]} {
            if {[catch [$class meta get mixin unmap-script:] err errdat]} {
              puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
            }
          }
        }
      }
      dict set mixinmap $slot $classes
    }
    my Recompute_Mixins
    foreach {slot classes} $args {
      foreach class $classes {
        if {$class ni $priorlist && [$class meta exists mixin map-script:]} {
          if {[catch [$class meta get mixin map-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
    foreach {slot classes} $mixinmap {
      foreach class $classes {
        if {[$class meta exists mixin react-script:]} {
          if {[catch [$class meta get mixin react-script:] err errdat]} {
            puts stderr "[self] MIXIN ERROR REACTING $class:\n[dict get $errdat -errorinfo]"
          }
        }
      }
    }
  }

  method debug_mixinmap {} {
    my variable mixinmap
    return $mixinmap
  }

  method Recompute_Mixins {} {
    my variable mixinmap
    set classlist {}
    foreach {item class} $mixinmap {
      if {$class ne {}} {
        lappend classlist $class
      }
    }
    my mixin {*}$classlist
  }
  
  method morph newclass {
    if {$newclass eq {}} return
    set class [string trimleft [info object class [self]]]
    set newclass [string trimleft $newclass :]
    if {[info command ::$newclass] eq {}} {
      error "Class $newclass does not exist"
    }
    if { $class ne $newclass } {
      my Morph_leave
      my variable mixins
      oo::objdefine [self] class ::${newclass}
      my graft class ::${newclass}
      # Reapply mixins
      my mixin {*}$mixins
      my InitializePublic
      my Morph_enter
    }
  }

  ###
  # Commands to perform as this object transitions out of the present class
  ###
  method Morph_leave {} {}
  ###
  # Commands to perform as this object transitions into this class as a new class
  ###
  method Morph_enter {} {}
  
  ###
  # title: List which objects are forwarded as organs
  ###
  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }
}



###
# END: metaclass.tcl
###
###
# START: option.tcl
###
###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tool::define::option {name args} {
  set class [current_class]
  set dictargs {default: {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimright [string trimleft $var -] :]: $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class:]
  if {$optclass ne {}} {
    foreach {f v} [::oo::meta::info $class getnull option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default:]
    }
  }
  ::oo::meta::info $class branchset option $name $dictargs
}

###
# topic: 827a3a331a2e212a6e301f59c1eead59
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::tool::define::option_class {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::oo::meta::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  ::oo::meta::info $class branchset option_class $name $dictargs
}

::tool::define ::tool::object {
  property options_strict 0
  variable organs {}

  option_class organ {
    widget label
    set-command {my graft %field% %value%}
    get-command {my organ %field%}
  }

  option_class variable {
    widget entry
    set-command {my variable %field% ; set %field% %value%}
    get-command {my variable %field% ; set %field%}
  }
  
  dict_ensemble config config {
    get {
      return [my Config_get {*}$args]
    }
    merge {
      return [my Config_merge {*}$args]
    }
    set {
      my Config_set {*}$args
    }
  }

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget args {
    return [my Config_get {*}$args]
  }

  ###
  # topic: 73e2566466b836cc4535f1a437c391b0
  ###
  method configure args {
    # Will be removed at the end of "configurelist_triggers"
    set dictargs [::oo::meta::args_to_options {*}$args]
    if {[llength $dictargs] == 1} {
      return [my cget [lindex $dictargs 0]]
    }
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }

  method Config_get {field args} {
    my variable config option_canonical option_getcmd
    set field [string trimleft $field -]
    if {[info exists option_canonical($field)]} {
      set field $option_canonical($field)
    }
    if {[info exists option_getcmd($field)]} {
      return [eval $option_getcmd($field)]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    if {[llength $args]} {
      return [lindex $args 0]
    }
    return [my meta cget $field] 
  }
  
  ###
  # topic: dc9fba12ec23a3ad000c66aea17135a5
  ###
  method Config_merge dictargs {
    my variable config option_canonical
    set rawlist $dictargs
    set dictargs {}
    set dat [my meta getnull option]
    foreach {field val} $rawlist {
      set field [string trimleft $field -]
      set field [string trimright $field :]
      if {[info exists option_canonical($field)]} {
        set field $option_canonical($field)
      }
      dict set dictargs $field $val
    }
    ###
    # Validate all inputs
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field validate-command:]
      if {$script ne {}} {
        dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
      }
    }
    ###
    # Apply all inputs with special rules
    ###
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field set-command:]
      dict set config $field $val
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
    return $dictargs
  }
  
  method Config_set args {
    set dictargs [::tool::args_to_options {*}$args]
    set dat [my Config_merge $dictargs]
    my Config_triggers $dat
  }
  
  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method Config_triggers dictargs {
    set dat [my meta getnull option]
    foreach {field val} $dictargs {
      set script [dict getnull $dat $field post-command:]
      if {$script ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
      }
    }
  }

  method Option_Default field {
    set info [my meta getnull option $field]
    set getcmd [dict getnull $info default-command:]
    if {$getcmd ne {}} {
      return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
    } else {
      return [dict getnull $info default:]
    }
  }
}

package provide tool::option 0.1

###
# END: option.tcl
###
###
# START: event.tcl
###
###
# This file implements the Tool event manager
###

::namespace eval ::tool {}

::namespace eval ::tool::event {}

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tool::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# topic: 8ec32f6b6ba78eaf980524f8dec55b49
# description:
#    Generate an event
#    Adds a subscription mechanism for objects
#    to see who has recieved this event and prevent
#    spamming or infinite recursion
###
proc ::tool::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::tool::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::tool::event::notify $who $self $event $info}
  }
}

###
# topic: 891289a24b8cc52b6c228f6edb169959
# title: Return a unique event handle
###
proc ::tool::event::nextid {} {
  return "event#[format %0.8x [incr ::tool::event_count]]"
}

###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::tool::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::tool::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}

###
# topic: b4b12f6aed69f74529be10966afd81da
###
proc ::tool::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return 
  if {$::tool::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tool::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tool::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::tool::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
}

proc ::tool::event::sleep msec {
  ::cron::sleep $msec
}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tool::event::subscribe {self who event} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue      
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}

###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::tool::event::unsubscribe {self args} {
  upvar #0 ::tool::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }  
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the 
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

::tool::define ::tool::object {
  ###
  # topic: 20b4a97617b2b969b96997e7b241a98a
  ###
  method event {submethod args} {
    ::tool::event::$submethod [self] {*}$args
  }
}

###
# topic: 37e7bd0be3ca7297996da2abdf5a85c7
# description: The event manager for Tool
###
namespace eval ::tool::event {
  variable nextevent {}
  variable nexteventtime 0
}


###
# END: event.tcl
###
###
# START: pipeline.tcl
###
::namespace eval ::tool::signal {}
::namespace eval ::tao {}

# Provide a backward compatible hook
proc ::tool::main {} {
  ::cron::main
}

proc ::tool::do_events {} {
  ::cron::do_events
}

proc ::tao::do_events {} {
  ::cron::do_events
}

proc ::tao::main {} {
  ::cron::main
}


package provide tool::pipeline 0.1


###
# END: pipeline.tcl
###
###
# START: coroutine.tcl
###
proc ::tool::define::coroutine {name corobody} {
  set class [current_class]
  ::oo::meta::info $class set method_ensemble ${name} _preamble: [list {} [string map [list %coroname% $name] {
    my variable coro_queue coro_lock
    set coro %coroname%
    set coroname [info object namespace [self]]::%coroname%
  }]]
  ::oo::meta::info $class set method_ensemble ${name} coroutine: {{} {
    return $coroutine
  }}
  ::oo::meta::info $class set method_ensemble ${name} restart: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
    set coro_lock($coroname) 0
    ::coroutine $coroname {*}[namespace code [list my $coro main]]
    ::cron::object_coroutine [self] $coroname
  }}
  ::oo::meta::info $class set method_ensemble ${name} kill: {{} {
    # Don't allow a coroutine to kill itself
    if {[info coroutine] eq $coroname} return
    if {[info commands $coroname] ne {}} {
      rename $coroname {}
    }
  }}

  ::oo::meta::info $class set method_ensemble ${name} main: [list {} $corobody]

  ::oo::meta::info $class set method_ensemble ${name} clear: {{} {
    set coro_queue($coroname) {}
  }}
  ::oo::meta::info $class set method_ensemble ${name} next: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    set coro_queue($coroname) [lrange $coro_queue($coroname) 1 end]
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} peek: {{eventvar} {
    upvar 1 [lindex $args 0] event
    if {![info exists coro_queue($coroname)]} {
      return 1
    }
    if {[llength $coro_queue($coroname)] == 0} {
      return 1
    }
    set event [lindex $coro_queue($coroname) 0]
    return 0
  }}

  ::oo::meta::info $class set method_ensemble ${name} running: {{} {
    if {[info commands $coroname] eq {}} {
      return 0
    }
    if {[::cron::task exists $coroname]} {
      set info [::cron::task info $coroname]
      if {[dict exists $info running]} {
        return [dict get $info running]
      }
    }
    return 0
  }}
  
  ::oo::meta::info $class set method_ensemble ${name} send: {args {
    lappend coro_queue($coroname) $args
    if {[info coroutine] eq $coroname} {
      return
    }
    if {[info commands $coroname] eq {}} {
      ::coroutine $coroname {*}[namespace code [list my $coro main]]
      ::cron::object_coroutine [self] $coroname
    }
    if {[info coroutine] eq {}} {
      ::cron::do_one_event $coroname
    } else {
      yield
    }
  }}
  ::oo::meta::info $class set method_ensemble ${name} default: {args {my [self method] send $method {*}$args}}

}

###
# END: coroutine.tcl
###
###
# START: organ.tcl
###
###
# A special class of objects that
# stores no meta data of its own
# Instead it vampires off of the master object
###
tool::class create ::tool::organelle {
  
  constructor {master} {
    my entangle $master
    set final_class [my select]
    if {[info commands $final_class] ne {}} {
      # Safe to switch class here, we haven't initialized anything
      oo::objdefine [self] class $final_class
    }
    my initialize
  }

  method entangle {master} {
    my graft master $master
    my forward meta $master meta
    foreach {stub organ} [$master organ] {
      my graft $stub $organ
    }
    foreach {methodname variable} [my meta branchget array_ensemble] {
      my forward $methodname $master $methodname
    }
  }
  
  method select {} {
    return {}
  }
}

###
# END: organ.tcl
###
###
# START: script.tcl
###
###
# Add configure by script facilities to TOOL
###
::tool::define ::tool::object {

  ###
  # Allows for a constructor to accept a psuedo-code
  # initialization script which exercise the object's methods
  # sans "my" in front of every command
  ###
  method Eval_Script script {
    set buffer {}
    set thisline {}
    foreach line [split $script \n] {
      append thisline $line
      if {![info complete $thisline]} {
        append thisline \n
        continue
      }
      set thisline [string trim $thisline]
      if {[string index $thisline 0] eq "#"} continue
      if {[string length $thisline]==0} continue
      if {[lindex $thisline 0] eq "my"} {
        # Line already calls out "my", accept verbatim
        append buffer $thisline \n
      } elseif {[string range $thisline 0 2] eq "::"} {
        # Fully qualified commands accepted verbatim
        append buffer $thisline \n
      } elseif {
        append buffer "my $thisline" \n
      }
      set thisline {}
    }
    eval $buffer
  }
}
###
# END: script.tcl
###

namespace eval ::tool {
  namespace export *
}