summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/tool
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:39:39 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:39:39 (GMT)
commitea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch)
tree6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/tool
parentb5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff)
parent7c621da28f07e449ad90c387344f07a453927569 (diff)
downloadblt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip
blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz
blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/tool')
-rw-r--r--tcllib/modules/tool/ensemble.tcl343
-rw-r--r--tcllib/modules/tool/event.tcl163
-rw-r--r--tcllib/modules/tool/index.tcl59
-rw-r--r--tcllib/modules/tool/meta.man165
-rw-r--r--tcllib/modules/tool/metaclass.tcl525
-rw-r--r--tcllib/modules/tool/module.shed8
-rw-r--r--tcllib/modules/tool/option.tcl168
-rw-r--r--tcllib/modules/tool/organ.tcl32
-rw-r--r--tcllib/modules/tool/pipeline.tcl174
-rw-r--r--tcllib/modules/tool/pkgIndex.tcl12
-rw-r--r--tcllib/modules/tool/script.tcl36
-rw-r--r--tcllib/modules/tool/tool.demo65
-rw-r--r--tcllib/modules/tool/tool.man233
-rw-r--r--tcllib/modules/tool/tool.md149
-rw-r--r--tcllib/modules/tool/tool.test339
-rw-r--r--tcllib/modules/tool/tool_dict_ensemble.man34
-rw-r--r--tcllib/modules/tool/uuid.tcl58
17 files changed, 2563 insertions, 0 deletions
diff --git a/tcllib/modules/tool/ensemble.tcl b/tcllib/modules/tool/ensemble.tcl
new file mode 100644
index 0000000..38dfeac
--- /dev/null
+++ b/tcllib/modules/tool/ensemble.tcl
@@ -0,0 +1,343 @@
+::namespace eval ::tool::define {}
+
+###
+# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
+###
+proc ::tool::dynamic_methods_ensembles {thisclass metadata} {
+ variable trace
+ set ensembledict {}
+ if {$trace} { puts "dynamic_methods_ensembles $thisclass"}
+ ###
+ # Only go through the motions for classes that have a locally defined
+ # ensemble method implementation
+ ###
+ set local_ensembles [dict keys [::oo::meta::localdata $thisclass method_ensemble]]
+ foreach ensemble $local_ensembles {
+ set einfo [dict getnull $metadata 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 {$arglist in {args {}}} {
+ set body {}
+ } else {
+ set body "\n ::tool::dynamic_arguments [list $arglist] {*}\$args"
+ }
+ append body "\n " [string trim $realbody] " \n"
+ set default $body
+ dict unset einfo default:
+ }
+ set eswitch \n
+ append eswitch "\n [list <list> [list return [lsort -dictionary [dict keys $einfo]]]]" \n
+ foreach {submethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
+ if {$submethod eq "_preamble:"} continue
+ set submethod [string trimright $submethod :]
+ lassign $esubmethodinfo arglist realbody
+ if {[string length [string trim $realbody]] eq {}} {
+ append eswitch " [list $submethod {}]" \n
+ } else {
+ if {$arglist in {args {}}} {
+ set body {}
+ } else {
+ set body "\n ::tool::dynamic_arguments [list $arglist] {*}\$args"
+ }
+ append body "\n " [string trim $realbody] " \n"
+ append eswitch " [list $submethod $body]" \n
+ }
+ }
+ if {$default=="standard"} {
+ set default "error \"unknown method $ensemble \$method. Valid: [lsort -dictionary [dict keys $eswitch]]\""
+ }
+ append eswitch [list default $default] \n
+ if {[dict exists $einfo _preamble:]} {
+ set body [lindex [dict get $einfo _preamble:] 1]
+ } else {
+ set body {}
+ }
+ append body \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
+
+ #if { $ensemble == "action" } {
+ # append body \n { if {$code == 0} { my event generate event $method {*}$dictargs}}
+ #}
+ append body \n {return -options $opts $result}
+ oo::define $thisclass method $ensemble {{method default} args} $body
+ # Define a property for this ensemble for introspection
+ ::oo::meta::info $thisclass set ensemble_methods $ensemble: [lsort -dictionary [dict keys $einfo]]
+ }
+ if {$trace} { puts "/dynamic_methods_ensembles $thisclass"}
+}
+
+###
+# 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
+}
+
diff --git a/tcllib/modules/tool/event.tcl b/tcllib/modules/tool/event.tcl
new file mode 100644
index 0000000..6900d89
--- /dev/null
+++ b/tcllib/modules/tool/event.tcl
@@ -0,0 +1,163 @@
+###
+# 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
+ foreach {id event} [array get timer_event $self:$task] {
+ ::after cancel $event
+ set timer_event($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
+ foreach pattern $patternlist {
+ lassign $pattern objpat eventpat
+ if {![string match $objpat $self]} continue
+ if {![string match $eventpat $event]} continue
+ lappend notify_list $obj
+ break
+ }
+ }
+ 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
+ array unset timer_event $self:$handle
+ set err [catch {uplevel #0 $script} result]
+ if $err {
+ puts "BGError: $self $handle $script
+ERR: $result"
+ }
+}
+
+###
+# topic: eba686cffe18cd141ac9b4accfc634bb
+# description: Schedule an event to occur later
+###
+proc ::tool::event::schedule {self handle interval script} {
+ variable timer_event
+
+ if {$::tool::trace} {
+ puts [list $self schedule $handle $interval]
+ }
+ if {[info exists timer_event($self:$handle)]} {
+ ::after cancel $timer_event($self:$handle)
+ }
+ set timer_event($self:$handle) [::after $interval [list ::tool::event::process $self $handle $script]]
+}
+
+###
+# topic: e64cff024027ee93403edddd5dd9fdde
+###
+proc ::tool::event::subscribe {self who event} {
+ lappend ::tool::object_subscribe($self) [list $who $event]
+}
+
+###
+# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
+###
+proc ::tool::event::unsubscribe {self args} {
+ if {![info exists ::tool::object_subscribe($self)]} continue
+ switch {[llength $args]} {
+ 0 {
+ set ::tool::object_subscribe($self) {}
+ }
+ 1 {
+ set event [lindex $args 0]
+ set oldlist $::tool::object_subscribe($self)
+ set newlist {}
+ foreach pattern $oldlist {
+ lassign $pattern objpat eventpat
+ if {[string match $eventpat $event]} continue
+ lappend newlist $pattern
+ }
+ set ::tool::object_subscribe($self) $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
+}
+
diff --git a/tcllib/modules/tool/index.tcl b/tcllib/modules/tool/index.tcl
new file mode 100644
index 0000000..ead02f4
--- /dev/null
+++ b/tcllib/modules/tool/index.tcl
@@ -0,0 +1,59 @@
+package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
+package require dicttool
+package require TclOO
+package require sha1
+package require oo::meta 0.4.1
+package require oo::dialect
+
+::oo::dialect::create ::tool
+::namespace eval ::tool {}
+set ::tool::trace 0
+###
+# topic: 27196ce57a9fd09198a0b277aabdb0a96b432cb9
+###
+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
+ 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]
+ }
+}
+
+set idxfile [file join [pwd] [info script]]
+set cwd [file dirname $idxfile]
+set ::tool::tool_root [file dirname $cwd]
+::tool::pathload $cwd {
+ uuid.tcl
+ ensemble.tcl
+ metaclass.tcl
+ event.tcl
+} $idxfile
+package provide tool 0.5
+
diff --git a/tcllib/modules/tool/meta.man b/tcllib/modules/tool/meta.man
new file mode 100644
index 0000000..72415ff
--- /dev/null
+++ b/tcllib/modules/tool/meta.man
@@ -0,0 +1,165 @@
+[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]
diff --git a/tcllib/modules/tool/metaclass.tcl b/tcllib/modules/tool/metaclass.tcl
new file mode 100644
index 0000000..30768ef
--- /dev/null
+++ b/tcllib/modules/tool/metaclass.tcl
@@ -0,0 +1,525 @@
+#-------------------------------------------------------------------------
+# 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]
+# 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 {
+::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 trimleft $var -] $val
+ }
+ return $result
+}
+
+###
+# topic: a92cd258900010f656f4c6e7dbffae57
+###
+proc ::tool::dynamic_methods class {
+ set metadata [::oo::meta::metadata $class]
+ foreach command [info commands ::tool::dynamic_methods_*] {
+ $command $class $metadata
+ }
+}
+
+###
+# topic: 4969d897a83d91a230a17f166dbcaede
+###
+proc ::tool::dynamic_arguments {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}} {
+ set string [dynamic_wrongargs_message $arglist]
+ error $string
+ }
+ }
+ 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} {
+ set string [dynamic_wrongargs_message $arglist]
+ error $string
+ } 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 "Wrong # args: should be:"
+ 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 {
+ foreach varname {
+ object_info
+ object_subscribe
+ } {
+ variable $varname
+ set ${varname}($objname) {}
+ }
+ set object_info($objname) [list class [info object class $objname]]
+}
+
+proc ::tool::object_destroy objname {
+ ::tool::event::generate $objname object_destroy [list objname $objname]
+ foreach varname {
+ object_info
+ 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 {}
+
+ 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
+ }
+
+ ###
+ # 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 {
+ 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]
+ }
+ #set field [my cget field]
+ 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 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 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 class {
+ ###
+ # Mix in the class
+ ###
+ ::oo::objdefine [self] mixin $class
+ my ClassPublicApply $class
+ }
+
+ 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
+ oo::objdefine [self] class ::${newclass}
+ 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]
+ }
+
+ class_method property args {
+ if {[my meta exists {*}$args]} {
+ return [my meta get {*}$args]
+ }
+ set field [string trimright [lindex $args end] :]:
+ if {[my meta exists {*}[lrange $args 0 end-1] $field]} {
+ return [my meta get {*}[lrange $args 0 end-1] $field]
+ }
+ if {[my meta exists const {*}[lrange $args 0 end-1] $field]} {
+ return [my meta get const {*}[lrange $args 0 end-1] $field]
+ }
+ return {}
+ }
+
+ method property args {
+ if {[my meta exists {*}$args]} {
+ return [my meta get {*}$args]
+ }
+ set field [string trimright [lindex $args end] :]:
+ if {[my meta exists {*}[lrange $args 0 end-1] $field]} {
+ return [my meta get {*}[lrange $args 0 end-1] $field]
+ }
+ if {[my meta exists const {*}[lrange $args 0 end-1] $field]} {
+ return [my meta get const {*}[lrange $args 0 end-1] $field]
+ }
+ return {}
+ }
+}
+
+
diff --git a/tcllib/modules/tool/module.shed b/tcllib/modules/tool/module.shed
new file mode 100644
index 0000000..36bf17c
--- /dev/null
+++ b/tcllib/modules/tool/module.shed
@@ -0,0 +1,8 @@
+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}
+}
diff --git a/tcllib/modules/tool/option.tcl b/tcllib/modules/tool/option.tcl
new file mode 100644
index 0000000..02ebaea
--- /dev/null
+++ b/tcllib/modules/tool/option.tcl
@@ -0,0 +1,168 @@
+###
+# 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
+ }
+ }
+ }
+ ::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
+
+ 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 [linded $args 0]
+ }
+ return [my property $field]
+ }
+
+ method config::set args {
+ set dictargs [::oo::meta::args_to_options {*}$args]
+ set dat [my config merge $dictargs]
+ my config triggers $dat
+ }
+
+ ###
+ # 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
+ }
+
+ ###
+ # 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
+ }
+
+ ###
+ # 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
diff --git a/tcllib/modules/tool/organ.tcl b/tcllib/modules/tool/organ.tcl
new file mode 100644
index 0000000..7e53c29
--- /dev/null
+++ b/tcllib/modules/tool/organ.tcl
@@ -0,0 +1,32 @@
+###
+# 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 {}
+ }
+}
diff --git a/tcllib/modules/tool/pipeline.tcl b/tcllib/modules/tool/pipeline.tcl
new file mode 100644
index 0000000..477ec8c
--- /dev/null
+++ b/tcllib/modules/tool/pipeline.tcl
@@ -0,0 +1,174 @@
+::namespace eval ::tool::signal {}
+
+proc ::tool::coroutine_register {objname coroutine} {
+ variable all_coroutines
+ variable object_coroutines
+ variable coroutine_object
+ # Wake a sleeping main loop
+ set ::tool::wake_up 2
+ if {$coroutine in $all_coroutines} {
+ return 1
+ }
+
+ lappend all_coroutines $coroutine
+ lappend object_coroutines($objname) $coroutine
+ set coroutine_object($coroutine) $objname
+ return 0
+}
+
+proc ::tool::coroutine_unregister {coroutine} {
+ variable all_coroutines
+ variable object_coroutines
+ variable coroutine_object
+ ldelete all_coroutines $coroutine
+ if {[info exists coroutine_object($coroutine)]} {
+ set objname $coroutine_object($coroutine)
+ ldelete object_coroutines($objname) $coroutine
+ unset coroutine_object($coroutine)
+ }
+}
+
+
+proc ::tool::do_events {} {
+ # Process coroutines
+ variable all_coroutines
+ variable coroutine_object
+ set count 0
+ foreach coro $all_coroutines {
+ if {[info command $coro] eq {}} {
+ #puts "$coro quit"
+ coroutine_unregister $coro
+ continue
+ }
+ #puts [list RUN $coro]
+ try $coro on return {} {
+ # Terminate the coroutine
+ coroutine_unregister $coro
+ } on break {} {
+ # Terminate the coroutine
+ coroutine_unregister $coro
+ } on error {errtxt errdat} {
+ # Coroutine encountered an error
+ coroutine_unregister $coro
+ puts "ERROR $coro"
+ set errorinfo $::errorInfo
+ 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" } {
+ incr count
+ coroutine_unregister $coro
+ }
+ } on ok {result opts} {
+ if { $result eq "done" } {
+ coroutine_unregister $coro
+ } else {
+ incr count
+ }
+ }
+ }
+ return $count
+}
+
+proc ::tool::main {} {
+ package require cron 1.2
+ ###
+ # Have the cron::wake procedure wake up an idle loop instead
+ # of it's normal run commands in the background
+ ###
+ proc ::cron::wake {} {
+ set ::tool::wake_up 1
+ }
+
+ set ::forever 1
+ while {$::forever} {
+ incr ::tool::loops(all)
+ if {[info command ::CRON] eq {}} {
+ coroutine ::CRON ::cron::runTasksCoro
+ }
+ set cron_delay [::CRON]
+ set tool_running [::tool::do_events]
+ if {$cron_delay==0 || $tool_running>0} {
+ incr ::tool::loops(active)
+ update
+ } else {
+ incr ::tool::loops(idle)
+ set ::tool::wake_up 0
+ after [expr {$cron_delay*1000}] {set ::tool::wake_up 1}
+ vwait ::tool::wake_up
+ }
+ }
+}
+
+proc ::tool::object_create objname {
+ foreach varname {
+ object_info
+ object_signal
+ object_subscribe
+ object_coroutine
+ } {
+ variable $varname
+ set ${varname}($objname) {}
+ }
+ set object_info($objname) [list class [info object class $objname]]
+}
+
+proc ::tool::object_rename {object newname} {
+ foreach varname {
+ object_info
+ object_signal
+ object_subscribe
+ object_coroutine
+ } {
+ 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]
+
+ variable coroutine_object
+ foreach {coro coro_objname} [array get coroutine_object] {
+ if { $objname eq $coro_objname } {
+ coroutine_unregister $coro
+ }
+ }
+ foreach varname {
+ object_info
+ object_signal
+ object_subscribe
+ object_coroutine
+ } {
+ variable $varname
+ unset -nocomplain ${varname}($objname)
+ }
+}
+
+namespace eval ::tool {
+ variable trace 0
+ variable all_coroutines
+ if {![info exists all_coroutines]} {
+ set all_coroutines {}
+ }
+}
+
+package provide tool::pipeline 0.1
+
diff --git a/tcllib/modules/tool/pkgIndex.tcl b/tcllib/modules/tool/pkgIndex.tcl
new file mode 100644
index 0000000..4792358
--- /dev/null
+++ b/tcllib/modules/tool/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# 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.5 [list source [file join $dir index.tcl]]
diff --git a/tcllib/modules/tool/script.tcl b/tcllib/modules/tool/script.tcl
new file mode 100644
index 0000000..8be1181
--- /dev/null
+++ b/tcllib/modules/tool/script.tcl
@@ -0,0 +1,36 @@
+###
+# 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
+ }
+} \ No newline at end of file
diff --git a/tcllib/modules/tool/tool.demo b/tcllib/modules/tool/tool.demo
new file mode 100644
index 0000000..4e62fb4
--- /dev/null
+++ b/tcllib/modules/tool/tool.demo
@@ -0,0 +1,65 @@
+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
diff --git a/tcllib/modules/tool/tool.man b/tcllib/modules/tool/tool.man
new file mode 100644
index 0000000..1f65a88
--- /dev/null
+++ b/tcllib/modules/tool/tool.man
@@ -0,0 +1,233 @@
+[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 {Dictionary Tools}]
+[category Utility]
+[keywords TclOO]
+[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 {
+# 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 tool]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
+
+
diff --git a/tcllib/modules/tool/tool.md b/tcllib/modules/tool/tool.md
new file mode 100644
index 0000000..9040323
--- /dev/null
+++ b/tcllib/modules/tool/tool.md
@@ -0,0 +1,149 @@
+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
+
+## 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>
diff --git a/tcllib/modules/tool/tool.test b/tcllib/modules/tool/tool.test
new file mode 100644
index 0000000..6a55fc4
--- /dev/null
+++ b/tcllib/modules/tool/tool.test
@@ -0,0 +1,339 @@
+# 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 oodialect/oodialect.tcl oo::dialect
+ use dicttool/dicttool.tcl dicttool
+ use oometa/oometa.tcl oo::meta
+ use sha1/sha1.tcl sha1
+}
+testing {
+ useLocal index.tcl tool
+}
+
+# -------------------------------------------------------------------------
+
+tool::class create OptionClass {
+ property color green
+ property mass 1200kg
+ option bodystyle {default: sedan}
+ option master {class organ default ::noop}
+}
+
+tool::class create OptionClass2 {
+ superclass OptionClass
+ property mass 1400kg
+ option color {default: blue}
+}
+
+OptionClass create ObjectOptionTest1
+OptionClass create ObjectOptionTest2 bodystyle wagon transmission standard
+OptionClass2 create ObjectOptionTest3
+OptionClass2 create ObjectOptionTest4 bodystyle SUV transmission cvt color white
+
+###
+# Property ignores options
+###
+test tool-options-001 {Simple property queries} {
+ ObjectOptionTest1 property color
+} green
+
+test tool-options-002 {Simple property queries} {
+ ObjectOptionTest2 property color
+} green
+
+test tool-options-003 {Simple property queries} {
+ ObjectOptionTest3 property color
+} green
+
+test tool-options-004 {Simple property queries} {
+ ObjectOptionTest4 property color
+} green
+
+###
+# Cget consults the options
+###
+test tool-options-005 {Simple property queries} {
+ ObjectOptionTest1 cget color
+} green
+
+test tool-options-006 {Simple property queries} {
+ ObjectOptionTest2 cget color
+} green
+
+test tool-options-007 {Simple property queries} {
+ ObjectOptionTest3 cget color
+} blue
+
+test tool-options-008 {Simple property queries} {
+ ObjectOptionTest4 cget color
+} white
+
+###
+# Tests with options in an object changing class
+###
+test tool-options-009 {Simple property queries} {
+ ObjectOptionTest3 property mass
+} 1400kg
+
+ObjectOptionTest3 morph OptionClass
+# The option for color was already set. It should remain
+test tool-options-010 {Simple property queries} {
+ ObjectOptionTest3 cget color
+} blue
+# The "color" property on the other hand should revert
+test tool-options-011 {Simple property queries} {
+ ObjectOptionTest3 property color
+} green
+# The "mass" property on the other hand should revert
+test tool-options-012 {Simple property queries} {
+ ObjectOptionTest3 property mass
+} 1200kg
+
+# Change a OptionClass to a OptionClass2
+
+test tool-options-013 {Simple property queries} {
+ ObjectOptionTest2 property mass
+} 1200kg
+
+ObjectOptionTest2 morph OptionClass2
+# When entering OptionClass2, the object will get any new options
+test tool-options-014 {Simple property queries} {
+ ObjectOptionTest2 cget color
+} blue
+
+test tool-options-015 {Simple property queries} {
+ ObjectOptionTest2 property mass
+} 1400kg
+
+# When changing back, the set option remains
+ObjectOptionTest2 morph OptionClass
+test tool-options-016 {Simple property queries} {
+ ObjectOptionTest2 cget color
+} blue
+
+test tool-options-017 {Simple property queries} {
+ ObjectOptionTest2 property mass
+} 1200kg
+
+
+tool::class create ArrayEnsembleClass {
+ # Burned in defaults
+ meta branchset define {
+ color: pink
+ }
+
+ array_ensemble define define {
+ initialize {
+ foo bar
+ }
+ custom {
+ return custom
+ }
+ true {
+ return true
+ }
+ false {
+ return false
+ }
+ }
+}
+
+ArrayEnsembleClass create ArrayEnsembleObject
+
+test tool-ensemble-001 {Test Array Ensemble} {
+ ArrayEnsembleObject define true
+} true
+test tool-ensemble-002 {Test Array Ensemble} {
+ ArrayEnsembleObject define false
+} false
+test tool-ensemble-003 {Test Array Ensemble retrieve initial value} {
+ ArrayEnsembleObject define get foo
+} bar
+test tool-ensemble-004 {Test Array Ensemble Store a value} {
+ ArrayEnsembleObject define set cc /usr/bin/cc
+ ArrayEnsembleObject define get cc
+} /usr/bin/cc
+
+test tool-ensemble-005 {Test array add} {
+ ArrayEnsembleObject define add path /bin
+ ArrayEnsembleObject define get path
+} /bin
+
+test tool-ensemble-005 {Test array add} {
+ ArrayEnsembleObject define add path /usr/bin
+ ArrayEnsembleObject define get path
+} {/bin /usr/bin}
+
+test tool-ensemble-006 {Test array add (again)} {
+ ArrayEnsembleObject define add path /usr/bin
+ ArrayEnsembleObject define get path
+} {/bin /usr/bin}
+
+
+test tool-ensemble-007 {Test array lappend} {
+ ArrayEnsembleObject define lappend path /usr/bin
+ ArrayEnsembleObject define get path
+} {/bin /usr/bin /usr/bin}
+
+test tool-ensemble-008 {Test array remove} {
+ ArrayEnsembleObject define remove path /usr/bin
+ ArrayEnsembleObject define get path
+} {/bin}
+
+test tool-ensemble-009 {Test array exists} {
+ ArrayEnsembleObject define exists counter
+} 0
+
+test tool-ensemble-010 {Test array incr} {
+ ArrayEnsembleObject define incr counter
+ ArrayEnsembleObject define get counter
+} 1
+
+test tool-ensemble-011 {Test array incr} {
+ ArrayEnsembleObject define incr counter
+ ArrayEnsembleObject define get counter
+} 2
+
+test tool-ensemble-012 {Test array exists} {
+ ArrayEnsembleObject define exists counter
+} 1
+
+test tool-ensemble-013 {Test array reset} {
+ ArrayEnsembleObject define reset
+ lsort -stride 2 [ArrayEnsembleObject define dump]
+} {color pink foo bar}
+
+tool::class create DictEnsembleClass {
+ # Burned in defaults
+ meta branchset define {
+ color: pink
+ }
+
+ dict_ensemble define define {
+ initialize {
+ foo bar
+ }
+ custom {
+ return custom
+ }
+ true {
+ return true
+ }
+ false {
+ return false
+ }
+ }
+}
+
+DictEnsembleClass create DictEnsembleObject
+
+test tool-ensemble-001 {Test Array Ensemble} {
+ DictEnsembleObject define true
+} true
+test tool-ensemble-002 {Test Array Ensemble} {
+ DictEnsembleObject define false
+} false
+test tool-ensemble-003 {Test Array Ensemble retrieve initial value} {
+ DictEnsembleObject define get foo
+} bar
+test tool-ensemble-004 {Test Array Ensemble Store a value} {
+ DictEnsembleObject define set cc /usr/bin/cc
+ DictEnsembleObject define get cc
+} /usr/bin/cc
+
+test tool-ensemble-005 {Test array add} {
+ DictEnsembleObject define add path /bin
+ DictEnsembleObject define get path
+} /bin
+
+test tool-ensemble-005 {Test array add} {
+ DictEnsembleObject define add path /usr/bin
+ DictEnsembleObject define get path
+} {/bin /usr/bin}
+
+test tool-ensemble-006 {Test array add (again)} {
+ DictEnsembleObject define add path /usr/bin
+ DictEnsembleObject define get path
+} {/bin /usr/bin}
+
+
+test tool-ensemble-007 {Test array lappend} {
+ DictEnsembleObject define lappend path /usr/bin
+ DictEnsembleObject define get path
+} {/bin /usr/bin /usr/bin}
+
+test tool-ensemble-008 {Test array remove} {
+ DictEnsembleObject define remove path /usr/bin
+ DictEnsembleObject define get path
+} {/bin}
+
+test tool-ensemble-009 {Test array exists} {
+ DictEnsembleObject define exists counter
+} 0
+
+test tool-ensemble-010 {Test array incr} {
+ DictEnsembleObject define incr counter
+ DictEnsembleObject define get counter
+} 1
+
+test tool-ensemble-011 {Test array incr} {
+ DictEnsembleObject define incr counter
+ DictEnsembleObject define get counter
+} 2
+
+test tool-ensemble-012 {Test array exists} {
+ DictEnsembleObject define exists counter
+} 1
+
+test tool-ensemble-013 {Test array reset} {
+ DictEnsembleObject define reset
+ lsort -stride 2 [DictEnsembleObject define dump]
+} {color pink foo bar}
+
+
+
+
+test tool-option_class-001 {Test option class} {
+ ObjectOptionTest1 meta get option master
+} {default: ::noop class: organ widget: label set-command: {my graft %field% %value%} get-command: {my organ %field%}}
+
+proc GNDN args {
+ return $args
+}
+
+ObjectOptionTest1 configure master GNDN
+test tool-option_class-002 {Test option class} {
+ ObjectOptionTest1 organ master
+} GNDN
+
+test tool-option_class-003 {Test option class} {
+ ObjectOptionTest1 <master> puts FOO
+} {puts FOO}
+
+OptionClass2 create ObjectOptionTest5 bodystyle SUV transmission cvt color white master GNDN
+
+test tool-option_class-002 {Test option class} {
+ ObjectOptionTest5 organ master
+} GNDN
+
+test tool-option_class-003 {Test option class} {
+ ObjectOptionTest5 <master> puts FOO
+} {puts FOO}
+# -------------------------------------------------------------------------
+
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/tool/tool_dict_ensemble.man b/tcllib/modules/tool/tool_dict_ensemble.man
new file mode 100644
index 0000000..e13dfcd
--- /dev/null
+++ b/tcllib/modules/tool/tool_dict_ensemble.man
@@ -0,0 +1,34 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin tool::dict_ensemble n 0.4.2]
+[keywords TOOL]
+[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
+[moddesc {Standardized OO Framework for development}]
+[titledesc {Dictionary Tools}]
+[category Utility]
+[keywords TclOO]
+[keywords TOOL]
+[require tool [opt 0.4.2]]
+[description]
+[para]
+The [cmd dict_ensemble] command is a keyword added by [package tool]. It defines
+a public variable (stored as a dict), and an access function to manipulated and
+access the values stored in that dict.
+[list_begin definitions]
+
+[call [emph object] [arg ensemble] [cmd add] [arg field]]] [arg value] [arg {value ...}]]
+
+Adds elements to a list maintained with the [arg field] leaf of the dict maintained
+my this ensemble.
+
+
+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.
+
+[list_end]
+
+[section AUTHORS]
+Sean Woods
+
+[vset CATEGORY tool]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end] \ No newline at end of file
diff --git a/tcllib/modules/tool/uuid.tcl b/tcllib/modules/tool/uuid.tcl
new file mode 100644
index 0000000..e0b87de
--- /dev/null
+++ b/tcllib/modules/tool/uuid.tcl
@@ -0,0 +1,58 @@
+::namespace eval ::tool {}
+
+proc ::tool::uuid_seed args {
+ if {$args eq {} } {
+ incr ::tool::nextuuid $::tool::globaluuid
+ set ::tool::UUID_Seed [list [info hostname] [get env(USER)] [get env(user)] [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 {}
generated by cgit v0.12 at 2024-10-14 00:15:03 (GMT)