can't find package oo::meta 0.5.1
    while executing
"package require oo::meta 0.5.1"
    (in namespace eval "::request" script line 17)
    invoked from within
"namespace eval ::request $script"
    ("::try" body line 12)

OUTPUT BUFFER:

### # 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 ]} { dict set eswitch {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 my lock remove pipeline ### ### # 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 my lock remove pipeline ### 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 my lock remove pipeline ### 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 * }