tclhttpd

###
# Facilities for user, group, and community management
###
package require httpd::directoo
package require sqlite3
package require tao
package require tao-sqlite
package require md5 2
package require sha1 2


package require httpd::cookie	;# Cookie_GetSock Cookie_Make
package require httpd::doc	;# Doc_Root
package require httpd::utils	;# Stderr file iscommand randomx

tao::class httpd.taourl {
  superclass httpd.meta

  property options_strict 0

  constructor {virtual {localopts {}} args} {
    my configurelist [list virtual $virtual {*}$localopts]
    ::Url_PrefixInstall $virtual [namespace code {my httpdDirect}] {*}$args
    my initialize
  }
}

tao::class httpd.community {  
  superclass httpd.taourl taodb::yggdrasil
  
  option virtual {}
  option dbfile {}

  method initialize {} {

###
# Facilities for user, group, and community management
###
package require tao
package require sqlite3

package require tao-sqlite
package require md5 2
package require sha1 2

package require httpd::taourl
package require httpd::cookie	;# Cookie_GetSock Cookie_Make
package require httpd::doc	;# Doc_Root
package require httpd::utils	;# Stderr file iscommand randomx













tao::class httpd.community {  
  superclass httpd.taourl taodb::yggdrasil
  
  option virtual {}
  option dbfile {}

  method initialize {} {

# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded httpd::community 0.1 [list source [file join $dir community.tcl]]

# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded httpd::community 0.1 [list source [file join $dir community.tcl]]
package ifneeded httpd::acl 0.1 [list source [file join $dir acl.tcl]]

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

package ifneeded httpd::directoo 0.1 [list source [file join $dir directoo.tcl]]
package ifneeded httpd::taourl 0.1 [list source [file join $dir taourl.tcl]]

package require tao
package require httpd::directoo


tao::class httpd.taourl {
  superclass httpd.meta

  property options_strict 0

  constructor {virtual {localopts {}} args} {
    my configurelist [list virtual $virtual {*}$localopts]
    ::Url_PrefixInstall $virtual [namespace code {my httpdDirect}] {*}$args
    my initialize
  }
}

package provide httpd::taourl 0.1

###
# topic: 62313463-3530-3535-3337-3237343930343
###

foreach varname {
  ::tao::info::class
  ::tao::info::object
} {
  if {![info exists $varname]} {
    set $varname {}
  }
}


if {[info command ::tao::db] eq {}} {
  package require sqlite3
  sqlite3 ::tao::db :memory:
  # Build the schema
  ::tao::db function string_match {string match}
  
  ::tao::db eval {
create table class (
  name string primary key,
  package string,
  superclass list default '::tao::moac',
  regenerate integer default 0
);

create table class_property (
  class string references class,
  type  string default const,
  property string,
  dict text,
  primary key (class,type,property) on conflict replace
);

create table class_ensemble (
  class string references class,
  ensemble string,
  method string,
  arglist string,
  body text,
  primary key (class,ensemble,method) on conflict replace
);

create table class_typemethod (
  class string references class,
  method string,
  arglist string,
  body text,
  primary key (class,method) on conflict replace
);

create table class_alias (
  cname string references class,
  alias string references class
);

create table class_ancestor (
  class string references class,
  direct integer default 0,
  seq integer,
  ancestor string references class,
  primary key (class,ancestor) on conflict ignore
);

create table object (
  name string primary key,
  package string,
  regen integer default 0
);

create table object_alias (
  cname string references object,
  alias string references object
);

create table object_bind (
  object string references object,
  event  string,
  script blob,
  primary key (object,event) on conflict replace
);

create table object_schedule (
  object string references object,
  event  string,
  time   integer,
  eventorder  integer default 0,
  script string,
  primary key (object,event) on conflict replace
);

create table object_subscribers (
  sender   string references object,
  receiver string references object,
  event string,
  primary key (sender,receiver,event) on conflict ignore
);
  }
}

###
# topic: b14c505537274904578340ec1bc12af1
###
namespace eval ::tao {
  variable trace 0
}

::namespace eval ::tao {}

###
# topic: 9f2e173840e3307fb6bd47e72e3d2451
# title: Generate a graphviz diagram of the current object hierarchy
###
proc ::tao::diagram {base filename {ignorefunct ::tao::diagram_ignore}} {
  set fout [open $filename w]
  puts $fout {
/*
* @command = dot
*
*/
  }
  puts $fout "digraph g \{"
  puts $fout {
rankdir = LR;
compound=true;

  }
#layout = dot
#compound = true  
#  
  set direct 1
  set classlist {}
  if { $base in {* all}} {
    ::tao::db eval {select name from class order by name} {
      if {[$ignorefunct $name]} continue
      lappend classlist $name
    }
  } else {
    foreach b $base {
      ::tao::db eval {select name from class where package=:b order by name} {
        if {[$ignorefunct $name]} continue
        lappend classlist $name
        ::tao::db eval {select class from class_ancestor where ancestor=:name and direct=1} {
          if { $class in $classlist } continue
          lappend classlist $class
        }
      }
    }
  }
  ::tao::db eval "select * from class where name in ('[join $classlist ',']')" {
    ladd modules($package) $name
    dict set classinfo $name display [diagram_name $name]
    dict set classinfo $name module  $package
    dict set classinfo $name connections [::tao::db eval "select ancestor from class_ancestor where (class=:name and direct=1) order by seq desc;"]
  }
  set graphid 0
  foreach {module mclasses} [lsort -dictionary -stride 2 [array get modules]] {
    puts $fout "  subgraph \"module[incr graphid]\" \{"
    set includes {}
    foreach class $mclasses {
      if {[$ignorefunct $class]} continue
      lappend includes [diagram_name $class]
      set links [dict get $classinfo $class connections]
      foreach {link direct} $links {
        if { $link eq $class } continue
        if {[$ignorefunct $link]} continue
        if {[string is true -strict $direct] } {
          lappend indirect([diagram_name $link]) [diagram_name $class]           
        } elseif { $link in $mclasses } {
          puts $fout "  [diagram_name $link]->[diagram_name $class]\;"
        } else {
          lappend extlinks([diagram_name $link]) [diagram_name $class] 
        }
      }
    }
    #puts $fout "    rank=same; [join $includes \;]"
    puts $fout "    [join $includes \;]"
    puts $fout "    label = \"Module $module\"\;"
    puts $fout "    color=lightgrey;"
    puts $fout "\}"
  }
  
  foreach {class links} [lsort -dictionary -stride 2 [array get extlinks]] {
    foreach link $links {
      puts $fout "  $class->$link\;"
    }
  }

  foreach {class info} [get classinfo] {
    dict with info {}
    puts $fout "$display \[shape = box\; label=\"[string trimleft $class :]\"\]\;"
  }

  puts $fout "\}"
  close $fout
}

###
# topic: c4dd91d51fb5ab26ec90c39ed4dbd306
###
proc ::tao::diagram_class {base filename {show_indirect 0} {ignorefunct ::tao::diagram_ignore}} {

#layout = dot
#compound = true  
#  
  set direct 1
  set classlist {}

  set direct 0
  set classlist $base
  foreach bclass $base {
    ::tao::db eval {select class from class_ancestor where ancestor=:bclass} {
      if { $class in $classlist } continue
      lappend classlist $class
    }
    ::tao::db eval {select ancestor from class_ancestor where class=:bclass} {
      if { $ancestor in $classlist } continue
      lappend classlist $ancestor
    }
  }

  
  ::tao::db eval "select * from class where name in ('[join $classlist ',']')" {
    ladd modules($package) $name
    dict set classinfo $name display [diagram_name $name]
    dict set classinfo $name module  $package
    ::tao::db eval "select ancestor,direct from class_ancestor where (class=:name and ancestor in ('[join $classlist ',']')) order by seq desc;" {
      if {[$ignorefunct $ancestor]} continue
      if { $ancestor eq $name } continue
      if { !$direct } {
        lappend indirect([diagram_name $ancestor]) [diagram_name $name]
      } else {
        lappend extlinks([diagram_name $ancestor]) [diagram_name $name] 
      }
    }
  }
  if {[info exists classinfo]} return

  set fout [open $filename w]
  puts $fout {
/*
* @command = dot
*
*/
  }
  puts $fout "digraph g \{"
  puts $fout {
rankdir = LR;
compound=true;

  }
  foreach {class links} [lsort -dictionary -stride 2 [array get extlinks]] {
    foreach link $links {
      puts $fout "  $class->$link\;"
    }
  }
  if { $show_indirect } {
    puts $fout "  edge \[color=red\]\;"
    foreach {class links} [lsort -dictionary -stride 2 [array get indirect]] {
      foreach link $links {
        puts $fout "  $class->$link\; "
      }
    }
  }
  foreach {class info} $classinfo {
    dict with info {}
    puts $fout "$display \[shape = box\; label=\"[string trimleft $class :]\"\]\;"
  }

  puts $fout "\}"
  close $fout
}

###
# topic: f1b91f039c8be1c604563a6624af84fe
###
proc ::tao::diagram_ignore class {
  if { $class in {::tao::moac ::oo::class ::oo::object} } {
    return 1
  }
  return 0
}

###
# topic: c7e2d0be0393921331e4476ff0a77e5a
###
proc ::tao::diagram_name name {
  set result {}
  foreach i [split $name :] {
    if { $i ne {} } {
      lappend result [join [split $i .] _]
    }
  }
  return [join $result _]
}

###
# This file implements the Tao event manager
###

::namespace eval ::tao {}

::namespace eval ::tao::event {}

###
# topic: 2097c1149d50b67b94ea09f0bcad9e5c
# description: Subscribe an object to events of type <b>event</b>
###
proc ::tao::event::bind {self event args} {
  if {![llength $args]} {
    return [::tao::db one {select script from object_bind where object=:self and event=:event}]
  }
  set script [lindex $args 0]
  if { $script eq {} } {
    ::tao::db eval {delete from object_bind where object=:self and event=:event}
  } else {
    ::tao::db eval {
insert or ignore into object(name) VALUES (:self);
insert or replace into object_bind (object,event,script) VALUES (:self,:event,:script);
}
  }
}

###
# topic: f2853d380a732845610e40375bcdbe0f
# description: Cancel a scheduled event
###
proc ::tao::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 ::tao::event::generate {self event args} {
  set dictargs [::tao::args_to_options {*}$args]

  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::tao::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  
  
  foreach who [Notification_list $self $event] {
    catch {::tao::event::notify $who $self $event $info}
  }
}

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

###
# topic: 1e53e8405b4631aec17f98b3e8a5d6a4
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::tao::event::Notification_list {self event {stackvar {}}} {
  if { $stackvar ne {} } {
    upvar 1 $stackvar stack
  } else {
    set stack {}
  }
  if {$self in $stack} {
    return {}
  }
  lappend stack $self

  ::tao::db eval {select receiver from object_subscribers where string_match(sender,:self) and string_match(event,:event)} {
    ::tao::db eval {select name as rcpt from object where string_match(name,:receiver)} {
      Notification_list $rcpt $event stack
    }
  }
  return $stack
}

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

###
# topic: 829c89bda736aed1c16bb0c570037088
###
proc ::tao::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: a6e4eebefcd2cec57ee4f0d8c10c92c0
###
proc ::tao::event::publish {self who event} {
  ::tao::db eval {
insert or ignore into object(name) VALUES (:self);
insert or replace into object_subscribers (sender,receiver,event) VALUES (:self,:who,:event);
}
}

###
# topic: eba686cffe18cd141ac9b4accfc634bb
# description: Schedule an event to occur later
###
proc ::tao::event::schedule {self handle interval script} {
  variable timer_event

  if {$::tao::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 ::tao::event::process $self $handle $script]]
}

###
# topic: 63d680db51c1a3a04c2a038b8f9747d0
###
proc ::tao::event::signal {self event} {
  
}

###
# topic: e64cff024027ee93403edddd5dd9fdde
###
proc ::tao::event::subscribe {self who event} {
  ::tao::db eval {
insert or ignore into object(name) VALUES (:self);
insert or replace into object_subscribers (receiver,sender,event) VALUES (:self,:who,:event);
}
}

###
# topic: 177acc5c440c615437dd02cba0ab778c
###
proc ::tao::event::unpublish {self args} {
  switch {[llength $args]} {
    0 {
      ::tao::db eval {delete from object_subscribers where sender=:self}
    }
    1 {
      set event [lindex $args 0]
      ::tao::db eval {delete from object_subscribers where sender=:self and string_match(event,:event)=1}
    }
  }
}

###
# topic: 5f74cfd01735fb1a90705a5f74f6cd8f
###
proc ::tao::event::unsubscribe {self args} {
  switch {[llength $args]} {
    0 {
      ::tao::db eval {delete from object_subscribers where receiver=:self}
    }
    1 {
      set event [lindex $args 0]
      ::tao::db eval {delete from object_subscribers where receiver=:self and string_match(event,:event)=1}
    }
  }
}

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

package provide tao 9.4.4
package require sqlite3
package require TclOO
package require odie
package require listutil 1.7

::namespace eval ::tao {}

###
# topic: f796a2dcb22de645fb365e07d39fce07
###
proc ::tao::load_path {path {ordered_files {}}} {
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string index $path 1] eq ":"} {
      set path [string range $path 2 end]
    }
  }
  lappend loaded index.tcl pkgIndex.tcl
  if {[file exists [file join $path baseclass.tcl]]} {
    lappend loaded baseclass.tcl
    uplevel #0 [list source [file join $path baseclass.tcl]]
  }
  foreach file $ordered_files {
    lappend loaded $file
    uplevel #0 [list source [file join $path $file]]
  }
  foreach file [glob -nocomplain [file join $path *.tcl]] {
    if {[file tail $file] in $loaded} continue
    lappend loaded [file tail $file]
    uplevel #0 [list source $file]
  }
}

###
# topic: b8897eebb90a62e0bac262762116b6b5
###
proc ::tao::script_path {} {
  set path [file dirname [file normalize [info script]]]
  if {$::tcl_platform(platform) eq "windows"} {
    if {[string index $path 1] eq ":"} {
      set path [string range $path 2 end]
    }
  }
  return $path

}

set ::tao::root [::tao::script_path]
::tao::load_path $::tao::root {
  event.tcl
  parser.tcl
  ootools.tcl
  module.tcl
  db.tcl
  moac.tcl
  onion.tcl
  mvc.tcl
}

tao::module pop

TAO - Tcl Architecture of Objects

Copyright (c) 2012, Sean Woods
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in the
      documentation and/or other materials provided with the distribution.
    * Neither the name of the Sean Woods, Etoyoc Heavy Industries,
      Test and Evaluation Solutions, nor the
      names of its contributors may be used to endorse or promote products
      derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY SEAN WOODS ``AS IS'' AND ANY
EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL SEAN WOODS BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

### BEGIN COPYRIGHT BLURB
#   
#   TAO - Tcl Architecture of Objects
#   Copyright (C) 2003 Sean Woods
#   
#   See the file "license.terms" for information on usage and redistribution
#   of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#   
### END COPYRIGHT BLURB

package provide listutil 1.7

proc ::tcl::mathfunc::pi {} [list return [expr 4.0*atan(1.0)]]
proc ::tcl::mathfunc::pio2 {} [list return [expr 2.0*atan(1.0)]]
proc ::tcl::mathfunc::sqrt2 {} [list return [expr sqrt(2)]]
proc ::tcl::mathfunc::e {} [list return [expr exp(1)]]

# [dict getnull] is like [dict get] but returns empty string for missing keys.
proc ::tcl::dict::getnull {dictionary args} {
  if {[exists $dictionary {*}$args]} {
    get $dictionary {*}$args
  }
}

namespace ensemble configure dict -map [dict replace\
    [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]

if 0 {
proc ::string::capitalize word {
    # Return $word with its first letter capitalized
    # Needed because sometimes [string totitle] plays games with us
    return [string toupper [string index $word 0]][string range $word 1 end]
}
}

proc iscommand {name} {
    expr {([string length [info command $name]] > 0) || [auto_load $name]}
}

proc makeproc {name arglist body} {
  if {![iscommand $name]} {
    proc $name $arglist $body
  }
}

###
# Make a new md5 command that 
# behaves like the one in tobe
###
if {[info command irmmd5] != {} } {
  makeproc md5Hash string {
    return [irmmd5 $string]
  }
} else {
  package require md5 2.0
  makeproc md5Hash string {
    return [string tolower [::md5::md5 -hex $string]]
  }
}

###
# proc: ::is_zero value
# title: Returns 1 if the value is zero or null
###
makeproc is_zero value {
  if {[string is false $value]} {
    return 1
  }
  if { $value == 0.0 } {
    return 1
  }
  return 0
}

###
# proc: ::is_zero value
# title: Returns 1 if the value is zero or null
###
makeproc if_zero {value replace} {
  if {[string is false $value]} {
    return $replace
  }
  if { $value == 0.0 } {
    return $replace
  }
  return $value
}
###
# proc: ::is_zero value
# title: Returns 1 if the value is zero or null
###
makeproc if_null {value replace} {
  if {[string is false $value]} {
    return $replace
  }
  if { $value == 0.0 } {
    return $replace
  }
  return $value
}

###
# Print a dict to the screen
###
makeproc pdict value {
  puts ***
  foreach {var val} $value {
    puts "$var: [list $val]"
  }
  puts ***
}

##############################################################
# General use procedures
# proc:  unique
# title: Returns a unique number 
#
makeproc unique {{val 0}} {
  incr val
  makeproc unique "{val $val}" [info body unique]
  return $val
}

makeproc setIfHigher {varname value} {
  upvar 1 $varname var
  if { $var < $value } {
    set var $value
  }
}

makeproc now {} { 
    return [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"]
}

makeproc dflt {varname i b} {
  upvar 1 $varname a
  if {![info exists a($i)] || $a($i)==""} {
    return $b
  }
  if {$a($i)<0.0} {
     return 0
  }
  return [expr {int($a($i))}]
}

makeproc setVarsFromDict {dictval varlist} {
    foreach var $varlist {
        upvar 1 $var $var
        if ![info exists $var] {
            set $var {}
        }
        if [dict exists $dictval $var] {
            set $var [dict get $dictval $var]
        }
    }
}

makeproc addAutoPath path {
    set path [file normalize $path]
    if ![file exists $path] return
    if { $path in $::auto_path } return
    foreach item $::auto_path {
        if { [file normalize $item] == $path } return
    }
    lappend ::auto_path $path
}

makeproc K {x y} { return $x }

makeproc combine args {
    foreach i $args {
        set c [llength $i]
        if { $c % 2 != 0 } {
            foreach {var val} $i {
                puts [list $var $val]
            }
            error [list Unbalanced Dict: $i $args]
        }
        lappend outstr $c
    }
    foreach {var val} [lindex $args 0] {
        dict set result $var $val
    }
    #set result [lindex $args 0]
    foreach item [lrange $args 1 end] {
        foreach {var val} $item {
            if { $val == {} } {
                if ![dict exists $result $var] {
                    dict set result $var $val
                    continue
                }
            }
            if { $val == "NULL" } {
                dict set result $var {}
                continue
            }
            dict set result $var $val
        }
    }
    return $result
}

makeproc dictGet {dict args} {
  if {[dict exists $dict {*}$args]} {
    return [dict get $dict {*}$args]
  }
  return {}
}


### Sets or unsets a flag value
makeproc flag {cmnd varname {val {}} {cd 0}} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}
    }
    if [regexp , $var] {
        set cd 1
        set var [split $var ,]
    }
    
    switch $cmnd {
        add {
            ladd var $val
        }
        remove {
            ldelete var $val
        }
        fix {
            set cd 1
        }
    }
    if $cd {
        set var [join $var ,]
    }
}

#
# A Pure Tcl implementation of the lutil command
#
makeproc lutil {command varname args} {
      
    upvar 1 $varname stack
    if ![info exists stack] {
        set stack {}
    }
    set result {}
    switch $command {
        pop {
            set result [lindex $stack 0]
            set stack [lrange $stack 1 end]
            
            set setvarn [lindex $args 0]
            if { $setvarn != {} } {
                upvar 1 $setvarn setvar
                set setvar $result
                update idletasks
                set result [expr [llength $stack] > 0]
            }
        }
        queue {
            lappend stack [lindex $args 0]
        }
        push {
            set stack [linsert [K $stack [set stack {}]] 0 [lindex $args 0]]
        }
        peek {
            set result [lindex $stack 0]
        }
    }
    return $result
}

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

makeproc ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
  }
  return $var
}

makeproc ladd_sorted {varname item} {
    upvar 1 $varname var
    lappend var $item
    set var [lsort -dictionary -unique $var]
    return $var
}

makeproc lset {varname fieldlist datalist} {
    upvar 1 $varname var
    set idx -1
    foreach field $fieldlist {
        set var($field) [lindex $datalist [incr idx]]
    }
}

makeproc listset {datalist varlist} {
    set idx -1
    foreach fieldVar $varlist {
        upvar 1 $fieldVar $fieldVar
        set $fieldVar [lindex $datalist [incr idx]]
    }
}

makeproc stripList arglist {
    set lastitem $arglist
    while { [llength $arglist] == 1 } {
       set lastitem $arglist
       set arglist [lindex $arglist 0]
    }
    if { [llength $arglist] == 0 } { 
       set arglist $lastitem
    }
    return $arglist
}

###
# Reverse the order of a list
###
makeproc lreverse {list} {	
    set result {}
    foreach item $list {
       set result [linsert [K $result [set result {}]] 0 $item]
    }
    return $result
}


makeproc lmerge {varname valuelist} {
    upvar 1 $varname var
    if ![info exists var] { 
        set var {}
    }
    set result {}
    foreach a $var {
        if { [lsearch $result $a] < 0 } {
            lappend result $a
        }
    }
    foreach a $valuelist {
        if { [lsearch $result $a] < 0 } {
            lappend result $a
        }
    }
    set var $result
    return $result
}


makeproc get varname {
    upvar 1 $varname var
    if [info exists var] {
        return [set var]
    }
}


makeproc dictget {dict field} {
    if [dict exists $dict $field] {
        return [dict get $dict $field]
    }
}

makeproc pop {stackvar resultvar} {
  upvar 1 $stackvar stack 
  upvar 1 $resultvar result
  if { [set len [llength $stack]] == 0 } { 
    set result {}
    return 0
  }
  set result [lindex $stack end]
  if { $len == 1 } { 
    set stack {}
  } else {
    set stack [lrange $stack 0 end-1]
  }
  return 1 
} 


makeproc peek {stackvar} { 
  upvar 1 $stackvar stack
  return [lindex $stack end]
}

makeproc push {stackvar value} {
  upvar 1 $stackvar stack
  lappend stack $value
}

makeproc queue {stackvar val} {
    upvar 1 $stackvar stack
    lappend stack $val
}

makeproc lintersect {list value} {
    foreach item $value {
        if {[lsearch $list $item] >= 0} {
            return true
        }
    }
    return false
}

#oo::define oo::class {
#  destructor {
#    ::tao::class_destroy [self]
#  }
#}
if {[info command ::tao::metaclass] eq {}} {
  oo::class create ::tao::metaclass {
    superclass ::oo::class
    
    destructor {
      ::tao::class_destroy [self]
    }
  }
}

###
# topic: bb7bd8d93b61e5163b84e16341de3a35
# title: Mother of all Classes
# description:
#    Base class used to define a global
#    template of expected behaviors
###
tao::class tao::moac {
  aliases moac
  
  variable signals_pending {}
  variable signals_processed {}
  variable organs {}
  # Sets an active lock that will be
  # erased by a lock remove added to tail
  # of all tao constructors
  variable ActiveLocks constructor
  option trace {
    widget boolean
    default 0
  }
  option_class variable {
    widget entry
    set-command {my Variable_set %field% %value%}
    get-command {my Variable_get %field%}
  }
  option_class organ {
    widget label
    set-command {my Option_graft %field% %value%}
    get-command {my organ %field%}
  }
  option_class property {
    widget label
    default-command {my property %field%}
  }

  property options_strict 0

  constructor args {
    my configurelist [::tao::args_to_options {*}$args]
    my initialize
  }

  destructor {}

  ###
  # topic: fa52b5fa66bccb878ae6c4fe88f471a3
  # description: Indicate to the user that the program is processing
  ###
  method action::busy {}

  ###
  # topic: 97d5cd58316988a2733c7ac2ad19735b
  # description: Commands to run when the system releases the gui
  ###
  method action::idle {}

  ###
  # topic: 03e3b8c1558a8153bc307fc098696d14
  ###
  method action::morph_enter {} {}

  ###
  # topic: f54fc2f9dfcba2ff0e888469b3b3ba27
  ###
  method action::morph_leave {} {}

  ###
  # topic: 7097c7ae9136bef863f89edddc384f60
  ###
  method action::pipeline_busy {} {}

  ###
  # topic: d971de215cd4ce584813fdaa09ae6819
  # description: Commands to run when the system releases the locks
  ###
  method action::pipeline_idle {} {}

  ###
  # topic: 86a1b968cea8d439df87585afdbdaadb
  ###
  method cget {field {default {}}} {
    my variable config
    set field [string trimleft $field -]
    set dat [my property option dict]
  
    if {[my property options_strict] && ![dict exists $dat $field]} {
      error "Invalid option -$field. Valid: [dict keys $dat]"
    }
    set info [dict getnull $dat $field]    
    if {$default eq "default"} {
      set getcmd [dict getnull $info default-command]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        return [dict getnull $info default]
      }
    }
    if {[dict exists $dat $field]} {
      set getcmd [dict getnull $info get-command]
      if {$getcmd ne {}} {
        return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      }
      if {![dict exists $config $field]} {
        set getcmd [dict getnull $info default-command]
        if {$getcmd ne {}} {
          dict set config $field [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
        } else {
          dict set config $field [dict getnull $info default]
        }
      }
      if {$default eq "varname"} {
        set varname [my varname visconfig]
        set ${varname}($field) [dict get $config $field]
        return "${varname}($field)"
      }
      return [dict get $config $field]
    }
    if {[dict exists $config $field]} {
      return [dict get $config $field]
    }
    return [my property $field]
  }

  ###
  # topic: 835853285c2acbbaaa3eb1abb5d1dbe9
  ###
  method code {} {
    return [namespace code {self}]
  }

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

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

  ###
  # topic: 543c936485189593f0b9ed79b5d5f2c0
  ###
  method configurelist_triggers dictargs {
    set dat [my property option dict]
    # Add a lock to prevent signals from
    # spawning signals
    my lock create configure
    ###
    # Apply normal inputs
    ###
    foreach {field val} $dictargs {
      if [catch {
        if {[dict exists $dat $field signal]} {
          my signal {*}[dict get $dat $field signal]
        }
        my Option_set $field $val
      } err] {
        puts [list [self] bg configure error: field $field val $val error $err]
      }
    }
    my Prefs_Store $dictargs
    my lock remove configure
  }

  ###
  # topic: 7b7c4a1ea317ff9e699c875353cf00cf
  ###
  method debugOut string {}

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

  ###
  # topic: d7787c21bbba4fbc8cc347fa6f0b1bc5
  ###
  method forward {method args} {
    oo::objdefine [self] forward $method {*}$args
  }

  ###
  # topic: 87ba9c0905dbadcb68abe425339caddc
  ###
  method get {{field {}}} {
    if { $field == {} } {
      set result {}
      foreach f [::info object vars [self]] {
        my variable $f
        if {[array exists $f]} {
          dict set result @$f [::array get $f]
        } else {
          dict set result $f [set $f]
        }
      }
      return $result
    }
    my variable $field
    if {[array exists $field]} {
      return [::array get $field]
    }
    if {[info exists $field]} {
      return [set $field]
    }
    return {}
  }

  ###
  # topic: d0bf3b83fdbef6d41b5585eb034088da
  ###
  method getVarname field {
    return [my varname $field]
  }

  ###
  # topic: 9afd530cdd4fa83b793dd66f59f707af
  ###
  method graft args {
    my variable organs
    if {[llength $args] == 1} {
      error "Need two arguments"
    }
    set object {}
    foreach {stub object} $args {
      set stub [string trimleft $stub /]
      dict set organs $stub $object
      oo::objdefine [self] forward ${stub} $object
      oo::objdefine [self] forward <${stub}> $object
      oo::objdefine [self] export <${stub}>
    }
    return $object
  }

  ###
  # topic: 4369b15a85b8dc3453ee6af2902bd383
  # description:
  #    Called during the constructor to
  #    set up all local variables and data
  #    structures. It is a seperate method
  #    to ensure inheritence chains predictably
  #    and also to keep us from having to pass
  #    along the constructor's arguments
  ###
  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>
  ###
  method InitializePublic {} {
    my variable config
    if {![info exists config]} {
      set config {}
    }
    set dat [my property option dict]
    foreach {var info} $dat {
      if {[dict exists $info set-command]} {
        if {[catch {my cget $var} value]} {
          dict set config $var [my cget $var default]
        } else {
          if { $value eq {} } {
            dict set config $var [my cget $var default]
          }
        }
      }
      if {![dict exists $config $var]} {
        dict set config $var [my cget $var default]
      }
    }
    foreach {var info} [my property variable dict] {
      if { $var eq "config" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default]} {
          set $var [dict get $info default]
        } else {
          set $var {}
        }
      }
    }
    foreach {var info} [my property array dict] {
      if { $var eq "config" } continue
      my variable $var
      if {![info exists $var]} {
        if {[dict exists $info default]} {
          array set $var [dict get $info default]
        } else {
          array set $var {}
        }
      }
    }
    my configurelist [my Prefs_Load]
  }

  ###
  # topic: 6c9e9e67ccd608d1983bbebcd81f2fd3
  ###
  method lock::active {} {
    my variable ActiveLocks
    return $ActiveLocks
  }

  ###
  # topic: 86d39889df168ace883017cac2de3b61
  ###
  method lock::create args {
    my variable ActiveLocks
    set result 0
    foreach lock $args {
      if { $lock in $ActiveLocks } {
        set result 1
      } else {
        lappend ActiveLocks $lock
      }
    }
    return $result
  }

  ###
  # topic: 6d8562be9185ac4990c3128a5a6aaac8
  ###
  method lock::peek args {
    my variable ActiveLocks
    set result 0
    foreach lock $args {
      if { $lock in $ActiveLocks } {
        set result 1
      }
    }
    return $result
  }

  ###
  # topic: 8429bd3d95cbe42db11fa9d78073ed87
  ###
  method lock::remove args {
    my variable ActiveLocks
    if {![llength $ActiveLocks]} {
      return 0
    }
    set oldlist $ActiveLocks
    set ActiveLocks {}
    foreach item $oldlist {
      if {$item ni $args} { lappend ActiveLocks $item }
    }
    if {![llength $ActiveLocks]} {
      my lock remove_all
      return 1
    }
    return 0
  }

  ###
  # topic: 00210688cea68a175df35ff2c25ce5dd
  # description: Force-Removes all locks
  ###
  method lock::remove_all {} {
    my variable ActiveLocks
    set ActiveLocks {}
    my Signal_pipeline
  }

  ###
  # topic: 75af8a0e6c55a9619ee87698b08bd328
  ###
  method message::error {error errorInfo} {
    puts "Error\n$error\n***\n$::errorInfo"
    return -code 1 $error -errorinfo $errorInfo
  }

  ###
  # topic: d15a85525b1f7151cd808e592bc09fed
  ###
  method morph newclass {
    my lock create morph
    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 action morph_leave
      oo::objdefine [self] class ::${newclass}
      my variable config
      set savestate $config
      my InitializePublic
      my configurelist $savestate
      my action morph_enter
    }
    my lock remove morph
  }

  ###
  # topic: 87c7b53c998e1f15c46b6a2fd187ef81
  ###
  method mutex::down flag {
    my variable mutex
    if {![info exists mutex($flag)]} {
      set mutex($flag) 0
    }
    set value $mutex($flag)
    set mutex($flag) 0
    return $value
  }

  ###
  # topic: 958a56b4c9598f3988955d7606e8c049
  ###
  method mutex::peek flag {
    my variable mutex
    if {![info exists mutex($flag)]} {
      set mutex($flag) 0
    }
    return $mutex($flag)
  }

  ###
  # topic: 1adff94c1cc08f5286b11c97480b3546
  ###
  method mutex::up flag {
    my variable mutex
    if {![info exists mutex($flag)]} {
      set mutex($flag) 0
    }
    if {[set mutex($flag)] > 0} {
      return 1
    }
    set mutex($flag) 1
    return 0
  }

  ###
  # topic: 3277490dddb5b19f42faaaaa50026f64
  # description: Provide a quiet null handler for events
  ###
  method notify::default {sender dictargs} {}

  ###
  # topic: f1ce03ba2aab515d7d7c36ce04e49eda
  ###
  method Option_get::default {} {
    my variable $method
    if {[info exists $method]} {
      return [set $method]
    }
    return {}
  }

  ###
  # topic: 092e79383ef394de41de7a4143beef2b
  ###
  method Option_graft {organ pointer} {
    my variable config
    if { $pointer ne {} } {
      dict set config $organ $pointer
      my graft $organ $pointer
    }
  }

  ###
  # topic: 3749709452836a574ce3dd8165b1308c
  ###
  method Option_noop args {
  }

  ###
  # topic: 4fa8bc688ade4893c0083d96c9e1ddfc
  # description: Default handler for options
  ###
  method Option_set::default newvalue {
    my variable $method
    if {[info exists $method]} {
      set $method $newvalue
    }
  }

  ###
  # topic: 57e093ecd48756c19e14068cad2e6856
  ###
  method OptionsMirrored organ {
    set result {}
    foreach {opt info} [my property option dict] {
      if {$organ in [dict getnull $info mirror]} {
        lappend result -$opt [my cget $opt]
      }
    }
    return $result
  }

  ###
  # topic: f867ee5408660c0296d731cda02b2bf8
  ###
  method organ {{stub all}} {
    my variable organs
    if {![info exists organs]} {
      return {}
    }
    if { $stub eq "all" } {
      return $organs
    }
    return [dict getnull $organs $stub]
  }

  ###
  # topic: fca634e0193df7049d096dd43dd3c417
  # title: Load persistant preferences
  ###
  method Prefs_Load {} {}

  ###
  # topic: e7f90dcfee554639cbf35b695827421a
  # title: Store persistant preferences
  ###
  method Prefs_Store dictargs {}

  ###
  # topic: 03c9ac58d726fe271c331c513f05b3a9
  ###
  method private {method args} {
    return [my $method {*}$args]
  }

  ###
  # topic: 30668ecb1349a981d393d705f5ffe2e0
  ###
  method proxy who {
    return [$who code]
  }

  ###
  # topic: b57ca4f29c6f69e4167176e13ced14ec
  ###
  method put args {
    if { [llength $args] == 1 } {
      set args [lindex $args 0]
    }
    foreach {key val} [::tao::args_to_dict {*}$args] {
      string trimleft $key -
      my variable $key
      set $key $val
    }
  }

  ###
  # topic: 1fe5a989f9e4334a1052fb4ef99eb7d1
  ###
  method sensai object {
    foreach {stub obj} [$object organ all] {
      my graft $stub $obj
    }
  }

  ###
  # topic: b6214c62683a643102ade2ef21853873
  # description: Does nothing
  ###
  method signal args {
    set rawlist [::tao::args_to_dict {*}$args]
    my variable signals_pending signals_processed
        
    set sigdat [my property signal dict]
    ###
    # Process incoming signals
    ###
    set signalmap $signals_pending
    foreach rawsignal $rawlist {
      ::tao::signal_expand $rawsignal $sigdat signalmap
    }

    set newsignals {}
    foreach signal $signalmap {
      if {$signal in $signals_processed} continue
      if {$signal in $signals_pending} continue
      set action [dict get $sigdat $signal action]
      if {[string length $action]} {
        lappend newsignals $signal
        lappend signals_pending $signal
      }
      set apply_action [dict get $sigdat $signal apply_action]
      if {[string length $apply_action]} {
        eval $apply_action
      }
    }
    if {[llength [my lock active]]} {
      return
    }

    if {("idle" in $rawlist && [llength $signals_pending]) || [llength $newsignals] } {
      set event [my event schedule signal idle [namespace code {my Signal_pipeline}]]
    } else {
      set event {}
    }
    return [list $event $signals_pending]
  }

  ###
  # topic: b9adb42b9e32fca79a9af340144281b6
  ###
  method Signal_pipeline {} {
    if {[my mutex up pipeline]} {
      ###
      # Prevent the pipeline from being entered twice
      ###
      return
    }
    set errlist {}
    set trace [my cget trace]
    my action pipeline_busy
    set sigdat [my property signal dict]
    my variable signals_pending signals_processed
    set order [my property meta signal_order]
    set pass 0
    if {$trace} {
      puts [list [self] [self method] $signals_pending]
    }
    if [catch {
    while {[llength [set signals $signals_pending]]} {
      ###
      # Copy our pending signals and clear out the list
      ###
      set signals_pending {}
      # Ignore mutually exclusive tasks
      set ignored {}
      foreach signal $order {
        if { $signal in $signals && $signal ni $ignored } {
          foreach item [dict get $sigdat $signal excludes] {
            ::ladd ignored $item
          }
        }
      }      
      ###
      # Fire off signals in the order calculated
      ###
      foreach signal $order {
        if { $signal in $signals && $signal ni $ignored } {
          set action [dict get $sigdat $signal action]
        }
      }
      foreach signal $order {
        if { $signal in $signals && $signal ni $ignored } {
          lappend signals_processed $signal
          if {$trace} {
            puts [list $signal [dict get $sigdat $signal action]]
          }
          eval [dict get $sigdat $signal action]
        }
      }
    }
    } err] {
      lappend errlist $err $::errorInfo
    }
    my mutex down pipeline
    my action pipeline_idle
    foreach {err info} $errlist {
      my message error $err $info
    }
    ###
    # If this sequence triggered more sequences
    # schedule our next call
    ###
    set signals_processed {}
  }

  ###
  # topic: 135c91aa5f0344e5a37c31c003f7d7ca
  # title: Generate a path to a subordinate object
  ###
  method SubObject::default {} {
    return [namespace current]::SubObject_generic_$method
  }

  ###
  # topic: 853c3b333a67f543c032852f546556c2
  ###
  method trace {{onoff {}}} {
    my variable trace
    if { $onoff == {} } {
      return $trace
    }
    set trace $onoff
    if { $trace } {
      oo::objdefine [self] method debugOut string {puts [list [my simTime] [self] $string]}
    } else {
      oo::objdefine [self] method debugOut string {}
    }
  }

  ###
  # topic: d70aa45da749a2fe7c1fb9755678322b
  ###
  method Variable_get::default {} {
    my variable $method
    return [get $method]
  }

  ###
  # topic: 02c62587fbec93f8adccc41d201c7c26
  ###
  method Variable_set::default newvalue {
    my variable $method
    set $method $newvalue
  }
}

::namespace eval ::tao {}

###
# topic: 3d9cc4f6252df40c5fd760ea4ba86f13
# title: Manage the module stack
# description:
#    While the module stack does not impact normal operations within Tao
#    maintaining it allow Tao to populate the "package" field in the tao::db
#    [example {
#    ::tao::module push myPackage
#    ::tao::load_path $dir
#    ::tao::module pop
#    }]
# darglist: [arg operation] [opt [arg module]]
###
proc ::tao::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"
    }
  }
}

::tao::module push core

###
# Base classes for Model/View/Controller architecture
###

###
# topic: 71b9a2bf1f9b9e1c8b1e06ceaa088b1d
# description:
#    This class implements a common data store used by
#    a model view controller
###
tao::class tao.mvcstore {

}

###
# topic: f9279c5be057cc75b1f1fd3bd4ee3052
###
tao::class tao.model {

}

###
# topic: 2927c0b0fc54227b3538f26e3bd0323b
###
tao::class tao.view {

}

###
# topic: 2d337edf2d1b9042d4ee2510fcc4c99d
###
tao::class tao.controller {
  
  variable mode_stack {}
  variable modes {}
  variable clearing 0

  property default_context {
    class action
    button {}
    main-script {my actionstack clear}
    exit-script {}
    push-script {}
    appswitch-script {}
    popups 1
    cursor arrow
    force_2d 1
    usermode 0
    icon {}
    auto-pop 0
    edit-ok  0
    interactive 0
    modal 0
  }

  signal busy {
    apply_action {my action busy}
    triggers {idle}
  }
  signal idle {
    apply_action {my action idle}
    follows  *
    triggers {}
  }

  ###
  # topic: b749283c69423a3823ff4a9c5ea54a0a
  # description:
  #    Code to run when the application is about to enter a
  #    busy phase
  ###
  method action::busy {} {}

  ###
  # topic: e7b6d7ade002fab7c871236e94d09ff5
  # description: Commands to run when the system ceases to be busy
  ###
  method action::idle {} {}

  ###
  # topic: 22e8612cf1155540ae8463e250978fe6
  # description:
  #    Action to perform at the top of every "peek"
  #    onto the stack
  ###
  method action::mode_peek {
  }

  ###
  # topic: 1906474f86290ff6391a4eb07fa2f7e3
  # description:
  #    Action to perform when a mode is popped off
  #    the stack/exited
  ###
  method action::mode_pop {
  }

  ###
  # topic: 780582fa0c41dcea48ac25c476c15604
  # title: method to execute when we enter the mode from another mode
  # description:
  #    Action to perform when a mode is pushed onto
  #    the stack/entered
  ###
  method action::mode_push {
  }

  ###
  # topic: 849976e96911e4a595d479a45c4c2ec2
  ###
  method action::stack_cleared {
  }

  ###
  # topic: 877b7f2efda12d0e9643afab6090b145
  ###
  method actionstack::clear {} {
    my lock create [self method].$method
    set cleared 0
    variable mode_stack
    while {[llength $mode_stack] > 0} {
      incr cleared
      if {[catch {my actionstack pop} err options]} {
        my action mode_peek
        return -options $options $err
      }
    }
    set mode_stack {}
    my action mode_peek
    if { $cleared } {
      my signal  layer_update
    }
    my lock remove [self method].$method
  }

  ###
  # topic: 2d1fac13797eacfd48cdb8e87462565b
  ###
  method actionstack::define {name settings} {
    my variable modes organs
    if {![info exists modes]} {
      set modes {}
    }
    if {![dict exists $modes $name]} {
      set context [my property default_context]
    } else {
      set context [dict get $modes $name]
    }
    foreach {var val} $settings {
      dict set context $var $val
    }
    dict set modes $name $context
    return $name
  }

  ###
  # topic: 715f11d7322b94a080cc657d2fd02d7f
  # description:
  #    A varient of action that clears the stack and establishes
  #    new base-behaviors. Used to implement the different "modes"
  #    in the visualization (i.e. runmode, playback, etc)
  ###
  method actionstack::morph newclass {
    ###
    # Tell runmode to cease
    ###
    my variable currentclass
    my lock create [self method].$method
    my actionstack clear
    if { [get currentclass] eq $newclass } {
      return
    }
    ###
    # After we have cleared the stack, destroy layers
    # we are not using and add layers that we are
    ###
    global g simconfig
    my action mode_pop
    my morph $newclass
    my activate_layers

    set currentclass $newclass
    my action mode_push [list prev_class $currentclass class $newclass]
    ###
    # Publish that we have changed modes
    ###
    my event generate mode_change prev_class $currentclass class $newclass
    my action mode_peek
    my lock remove [self method].$method
  }

  ###
  # topic: e2a03175995d1ba6e4f9e1224cbbb6cd
  ###
  method actionstack::peek {} {
    my lock create [self method].$method
    my action mode_peek
    my variable mode_stack organs
    if {[llength $mode_stack]==0} {
      my action mode_peek      

      set context [my property default_context]
      set doPop 0
      set force_interactive 1
    } else {
      set context [lindex [get mode_stack] end]
      set doPop 0
      set force_interactive 0
    }
    set code [catch {
      dict with organs {}
      dict with context {}
      my popups_enabled ${popups}
      my cursor $cursor
      my action icon $icon
      if { $button != {} } {
        catch {$button configure -state pressed}
      }
      eval ${main-script}
      if { ${auto-pop} } {
        set doPop 1
      }
    } result returnInfo]
    if { $code ni {0 2} } {      
      set ::errorInfo [list Evaluating object [self] context $context]\n${::errorInfo}
      catch {my actionstack pop}
      return {*}${returnInfo} $result
    }
    if { $doPop } {
      my actionstack pop
    }
    my lock remove [self method].$method
    if {$force_interactive || $interactive} {
      my Signal_pipeline
    }
  }

  ###
  # topic: 312260fae2812d18bdb57fbbe24f7771
  ###
  method actionstack::pop {} {
    my lock create [self method].$method
    my variable mode_stack organs
    set context [lindex $mode_stack end]
    if { $context ne {} } {
      if {![dict get $context usermode]} {
        set mode_stack [lrange $mode_stack 0 end-1]
        dict with organs {}
        dict with context {}
        if [catch ${exit-script} result returnInfo] {
          set ::errorInfo [list Evaluating object [self] context $context]\n${::errorInfo}
          return {*}${returnInfo} $result
        }
      }
    }
    my lock remove [self method].$method
    my actionstack peek
  }

  ###
  # topic: 6e52f9b7b20156b81348133e3c860e8f
  ###
  method actionstack::push {mode {inputcontext {}}} {
    my variable mode_stack modes organs
    my action busy
    my lock create [self method].$method
    set script {}
    ###
    # Load our organs as the local context
    ###
    set context [my property default_context]
    if {[dict exists $modes $mode]} {
      foreach {var val} [dict get $modes $mode] {
        dict set context $var $val
      }
    }
    foreach {var val} $inputcontext {
      dict set context $var $val
    }
    dict set context mode $mode
    dict set modes $mode $context
    set stack_clear 0
    
    if {[dict exists $context exclusive]} {
      ###
      # If we have certain modes that are mutually exclusive on
      # the task stack, clear the stack
      ###
      set exclusive [dict get  $context exclusive]
      set top [lindex $mode_stack end]
      if {[dict exists $top mode]} {
        if {[dict get $top mode] in $exclusive} {
          set stack_clear 1
        }
      }
    }
    ####
    # Modal actions want to be the
    # top thing on the stack
    # so cancel anything else going on
    ###
    if {[dict get $context modal]} {
      set stack_clear 1
    }

    if { $stack_clear } {
      my actionstack clear
    }
    lappend mode_stack $context
    dict with organs {}
    dict with context {}
    if [catch ${push-script} result returnInfo] {
      set ::errorInfo [list Evaluating object [self] context $context]\n${::errorInfo}
      return {*}${returnInfo} $result
    }
    my lock remove [self method].$method
    my actionstack peek
  }

  ###
  # topic: 3aaf2e553ea49a156469847f2a9e60f0
  ###
  method configurelist_triggers dictargs {
    set dat [my property option dict]
    ###
    # Apply normal inputs
    ###
    my lock create configure
    foreach {field val} $dictargs {
      my Option_set $field $val
    }
    ###
    # Generate all signals
    ###
    foreach {field val} $dictargs {
      set signal [dict getnull $dat $field signal]
      if {$signal ne {}} {
        my signal  $signal
      }
    }
    my Prefs_Store $dictargs
    my lock remove configure
    foreach {field val} $dictargs {
      set signal [dict getnull $dat $field signal]
      if {$signal ne {}} {
        my event generate {*}$signal [list value $val]
      }
    }
  }
}

###
# topic: 0f30d28a31ce88dfb36ca1c12b454087
# description:
#    This class is a template for objects that will be managed
#    by an onion class
###
tao::class tao::layer {
  aliases tao.layer
  option prefix {}
  option layer_name {}
  property layer_index_order 0
  
  constructor {sharedobjects args} {
    foreach {organ object} $sharedobjects {
      my graft $organ $object
    }
    my graft layer [self]
    my configurelist [::tao::args_to_options {*}$args]
  }

  ###
  # topic: ce2844831edfd3d32b7e1044690e978a
  # description: Action to perform when layer is mapped visible
  ###
  method initialize {} {
  }

  ###
  # topic: 88c79c0e9188a477f535b66b01631961
  ###
  method node_is_managed unit {
    return 0
  }

  ###
  # topic: 8cc75f590cfad54a22ff0c454c90561c
  ###
  method type_is_managed unit {
    return [expr {$unit eq [my cget prefix]}]
  }
}

###
# topic: 2dba98b257eea6b843505bd2d4887b8a
# description:
#    A form of megawidget which farms out major functions
#    to layers
###
tao::class tao::onion {
  aliases tao.onion
  variable layers {}
  
  ###
  # Organs that are grafted into our layers
  ###
  property shared_organs {
    
  }

  ###
  # topic: 351937a37f294d3ac235e45b9c2f312e
  ###
  method action::activate_layers {} {}

  ###
  # topic: 81232b0943dce1f2586e0ac6159b1e2e
  ###
  method activate_layers {{force 0}} {
    set self [self]
    my variable layers
    set result {}
    set active [my active_layers]

    ###
    # Destroy any layers we are not using
    ###
    set lbefore [get layers]
    foreach {lname obj} $lbefore {
      if {![dict exists $active $lname] || $force} {
        $obj destroy
        dict unset layers $lname
      }
    }

    ###
    # Create or Morph the objects to represent
    # the layers, and then stitch them into
    # the application, and the application to
    # the layers
    ###    
    foreach {lname info} $active {
      set class  [dict get $info class]
      set ordercode [$class property layer_index_order]
      if { $ordercode ni {0 {}} } {
        lappend order($ordercode) $lname $info
      } else {
        lappend order(99) $lname $info
      }
    }
    set shared [my Shared_Organs]
    
    foreach {ordercode} [lsort -integer [array names order]] {
      set objlist $order($ordercode)
      foreach {lname info} $objlist {
        set created 0
        set prefix [dict get $info prefix]
        set class  [dict get $info class]
        set layer_obj [my SubObject layer $lname]
        dict set layers $lname $layer_obj
        if {[info command $layer_obj] == {} } {
          $class create $layer_obj $shared prefix $prefix layer_name $lname
          set created 1
          foreach {organ object} $shared {
            $layer_obj graft $organ $object
          }
        } else {
          foreach {organ object} $shared {
            $layer_obj graft $organ $object
          }
          $layer_obj morph $class
        }
        ::ladd result $layer_obj
        $layer_obj event subscribe [self] *
        $layer_obj initialize
      }
    }
    
    my action activate_layers
    return $result
  }

  ###
  # topic: 7d8c8694fc10c9e8c5017dfaff4b1b8c
  # description: Returns a list of layers with properties needed to create them
  ###
  method active_layers {} {
    ### Example
    #set result {
    #  xtype     {prefix y class sde.layer.xtype}
    #  eqpt      {prefix e class sde.layer.eqpt}
    #  portal    {prefix p class sde.layer.portal}
    #}
    # return $result
    return {}
  }

  ###
  # topic: d800511c8a288ee9b935135e56c91a65
  ###
  method layer {item args} {

    set scan [scan $item "%1s%d" class objid]
    switch $scan {
      2 {
        # Search by class/objid
        if { $class eq "y"} {
          foreach {layer obj} [my layers] {
            if { [$obj type_is_managed $item] } {
              if {[llength $args]} {
                return [$obj {*}$args]
              }
              return $obj
            }
          }
        } else {
          # Search my node if we have a prefix/number
          foreach {layer obj} [my layers] {
            if { [$obj node_is_managed $item] } {
              if {[llength $args]} {
                return [$obj {*}$args]
              }
              return $obj
            }
          }
        }
      }
      default {
        # Search my name/prefix
        foreach {layer obj} [my layers] {
          if { [string match $item $layer] } {
            if {[llength $args]} {
              return [$obj {*}$args]
            }
            return $obj
          }
          set data [my active_layers]
          if { [string match $item [dict get $data $layer prefix]] } {
            if {[llength $args]} {
              return [$obj {*}$args]
            }
            return $obj
          }
        }
        # Search by string
        ###
        # Search by type
        ###
        foreach {layer obj} [my layers] {
          if { [$obj type_is_managed $item] } {
            if {[llength $args]} {
              return [$obj {*}$args]
            }
            return $obj
          }
        }
        ###
        # Search fall back to search by node
        ###
        foreach {layer obj} [my layers] {
          if { [$obj node_is_managed $item] } {
            if {[llength $args]} {
              return [$obj {*}$args]
            }
            return $obj
          }
        }
      }
    }
    return ::noop
  }

  ###
  # topic: 75d06860b688273777a17cafb45710de
  # description: Return a list of layers for this application
  ###
  method layers {} {
    set result {}
    my variable layers
    if {![info exists layers]} {
      my activate_layers
    }
    return $layers
  }

  ###
  # topic: 96201b2abf6901f5750499e903be1351
  ###
  method Shared_Organs {} {
    dict set shared master [self]
    foreach organ [my property shared_organs] {
      set obj [my organ $organ]
      if { $obj ne {} } {
        dict set shared $organ $obj
      }
    }
    return $shared
  }

  ###
  # topic: b1fe13c9c2f33fb26b71b03c7cb1d0a5
  ###
  method SubObject::layer name {
    return [namespace current]::SubObject_Layer_$name
  }
}

::namespace eval ::tao {}

::namespace eval ::tao::event {}

::namespace eval ::tao::info {}

::namespace eval ::tao::parser {}

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

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

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

###
# topic: 396899726d57640d3e90a2caa180d855
# title: Return the canonical name of a class
###
proc ::tao::canonical name {
  set class ::[string trimleft $name :]
  ::tao::db eval {select cname from class_alias where alias=:class} {
    set class $cname
  }
  return $class
}

###
# topic: da87af1492df6d913beb343d9b534d1c
# title: Create or modify a tao class
# description:
#    This command is an enhancement to [emph {::oo::class create}] and [emph {oo::define}].
#    In addition to the normal behavior expected from these operations, [emph tao::class]
#    tracks the class in the [emph tao::db] as well as rebuild the dynamic methods
###
proc ::tao::class {name body} {
  set class [canonical $name]
  if { [::info command $class] == {} } {
    ::tao::metaclass create $class
  }
  ::tao::parser::push $class
  namespace eval ::tao::parser $body
  ::tao::parser::pop
  ::tao::dynamic_methods $class
  foreach {rname} [::tao::db eval {select name from class where regenerate!=0}] {
    ::tao::dynamic_methods $rname
  }
  set ::tao::coreclasses [::tao::db eval {select class from class_property where type='classinfo' and property='type' and dict='core'}]
}

###
# topic: 87e896b8994dba3927f227685169a939
###
proc ::tao::class_ancestors {class {stackvar {}}} {
  if { $stackvar ne {} } {
    upvar 1 $stackvar stack
  } else {
    set stack {}
  }
  if { $class in $stack } {
    return {}
  }
  lappend stack $class
  if {![catch {::info class superclasses $class} ancestors]} {
    foreach ancestor $ancestors {
      class_ancestors $ancestor stack
    }
  }
  if {![catch {::info class superclasses $class} ancestors]} {
    foreach ancestor $ancestors {
      class_ancestors $ancestor stack
    }
  }
  return $stack
}

###
# topic: 19f6ce3edca7d84e2f7d82e8a7e9035f
# description: Return a list of tao classes
###
proc ::tao::class_choices {} {
  return [lsort -dictionary $::tao::info:::class]
}

###
# topic: 8a0deafc19c1f3605a7ca961ec2ab01f
###
proc ::tao::class_descendents {class {stackvar {}}} {
  if { $stackvar ne {} } {
    upvar 1 $stackvar stack
  } else {
    set stack {}
  }
  if { $class in $stack } {
    return {}
  }
  lappend stack $class
  foreach {child} [::tao::db eval {select class from class_ancestor where ancestor=:class}] {
    class_descendents $child stack
  }
  return $stack
}

###
# topic: 8c73a1ebe15b4935a4ff657399742257
###
proc ::tao::class_destroy class {
  if {[dict exists $::tao::info::class $class]} {
    dict unset ::tao::info::class $class
  }
  ::tao::db eval {
delete from class_property where class=:class;
delete from class_ensemble where class=:class;
delete from class_typemethod where class=:class;
delete from class_alias where cname=:class;
delete from class_ancestor where class=:class or ancestor=:class;
  }
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::tao::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 tao
      ###
      set dictargs [::tao::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: a92cd258900010f656f4c6e7dbffae57
###
proc ::tao::dynamic_methods class {
  set ancestors [::tao::db eval {select ancestor from class_ancestor where class=:class order by CAST(seq as INTEGER);}]
  set order 0
  set script {}
  
  ::tao::dynamic_methods_ensembles $class $ancestors
  ::tao::dynamic_methods_class    $class $ancestors
  ::tao::dynamic_methods_property $class $ancestors
  ::tao::db eval {update class set regenerate=0 where name=:class;}
}

###
# topic: b88add196bb63abccc44639db5e5eae1
###
proc ::tao::dynamic_methods_class {thisclass ancestors} {
  set cmethods {}
  foreach anc $ancestors {
    ::tao::db eval {select method,arglist,body from class_typemethod where class=:anc} {
      if { $method in $cmethods } continue
      lappend cmethods $method
      ::oo::objdefine $thisclass method $method $arglist $body
    }
  }
}

###
# topic: fb8d74e9c08db81ee6f1275dad4d7d6f
###
proc ::tao::dynamic_methods_ensembles {thisclass ancestors} {

  set ensembledict {}
  #set trace [string match $thisclass "::taotk::sqlconsole"]
  set trace 0
  if {$trace} { puts "dynamic_methods_ensembles $thisclass"}
  foreach ancestor $ancestors {
    if {$trace} { puts $ancestor }
    ::tao::db eval {select * from class_ensemble where class=:ancestor} {
      if {[dict exists $ensembledict $ensemble $method]} continue
      if { $trace } { puts "$ensemble :: $method from $ancestor"}
      dict set ensembledict $ensemble $method [list $arglist $body]
    }
  }

  foreach {ensemble einfo} $ensembledict {
    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]
      set body "\n      ::tao::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} [lsort -dictionary [dict keys $einfo]] {
      set esubmethodinfo [dict get $einfo $submethod]
      set arglist     [lindex $esubmethodinfo 0]
      set realbody    [lindex $esubmethodinfo 1]
      if {[string length [string trim $realbody]] eq {}} {
        append eswitch "    [list $submethod {}]" \n
      } else {
        set body "\n      ::tao::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
    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
    ::tao::parser::property ensemble_methods $ensemble [lsort -dictionary [dict keys $einfo]]
  }
  if {$trace} { puts "/dynamic_methods_ensembles $thisclass"}

}

###
# topic: 6b7879602c202398bd25f733c0933cf9
###
proc ::tao::dynamic_methods_property {thisclass ancestors} {
  ###
  # Apply properties
  ###  
  set info {}
  dict set info option {}
  set proplist {}
  foreach ancestor $ancestors {
    ::tao::db eval {select property,type,dict from class_property where class=:ancestor} {
      if {[dict exists $info $type $property]} continue
      dict set info $type $property $dict
      if { $type in {eval const subst variable}} {
        # For these values, we want to exclude equivilent calls
        if {[dict exists $info eval $property]} continue
        if {[dict exists $info const $property]} continue
        if {[dict exists $info subst $property]} continue
        lappend proplist $property
        set mdef [split $property _]
        if {[llength $mdef] > 1} {
          set ptype [lindex $mdef 0]
          lappend proptypes($ptype) $property
        }
      }     
    }
  }
  
  set publicvars {}
  ###
  # Build options
  ###
  set option_classes [dict getnull $info option_class]
  # Build option handlers
  foreach {property pdict} [dict getnull $info option] {
    set contents {
      default {}
    }
    #append body \n " [list $property "return \[my cget [list $property]\]"]"
    set optionclass [dict getnull $pdict class]
    if {[dict exists $option_classes $optionclass]} {
      foreach {f v} [dict get $option_classes $optionclass] {
        dict set contents [string trimleft $f -] $v
      }
    }
    if {[dict exists $info option $optionclass]} {
      foreach {f v} [dict get $info option $optionclass] {
        dict set contents [string trimleft $f -] $v
      }
    }
    foreach {f v} $pdict {
      dict set contents [string trimleft $f -] $v
    }
    dict set info option $property $contents
  }
  
  dict set info meta class $thisclass
  dict set info meta ancestors $ancestors
  dict set info meta signal_order [::tao::signal_order [dict getnull $info signal]]
  dict set info meta types [lsort -dictionary -unique [array names proptypes]]
  dict set info meta local [get proplist]
  ###
  # Build the body of the property method
  ###
  set commonbody "switch \$field \{"
  append commonbody \n "  [list class [list return $thisclass]]"
  append commonbody \n "  [list ancestors [list return $ancestors]]"
  
  foreach {type typedict} $info {
    set typebody "    switch \[lindex \$args 0\] \{"
    append typebody \n "    [list list [list return [lsort -unique -dictionary [dict keys $typedict]]]]"
    append typebody \n "    [list dict [list return $typedict]]"
    foreach {subprop value} $typedict {
      switch $type {
        variable {
          append typebody \n "    [list $subprop [list return $value]]"          
        }
        default {
          append typebody \n "    [list $subprop [list return $value]]"          
        }
      }
    }
    append typebody "\n    \}" \n
    append commonbody \n "  [list $type $typebody]"
  }
  # Build const property handlers
  foreach {property pdict} [dict getnull $info const] {
    append commonbody \n " [list $property [list return $pdict]]"   
  }
  set body {
my variable config
if {[llength $args]==0} {
  if {[dict exists $config $field]} {
    return [dict get $config $field]
  }
}
  }
  append body $commonbody
  append classbody $commonbody

  # Build eval property handlers
  foreach {property pdict} [dict getnull $info eval] {
    if {$property in $proplist} continue
    append body \n " [list $property $pdict]"
  }

  # Build subst property handlers
  foreach {property pdict} [dict getnull $info subst] {
    if {$property in $proplist} continue
    append body \n " [list $property [list return [subst $pdict]]]"
  }
  
  # Build option handlers
  foreach {property pdict} [dict getnull $info option] {
    dict set publicvars $property $pdict
    append body \n " [list $property "return \[my cget [list $property]\]"]"
  }  
  
  # Build public variable handlers
  foreach {property pdict} [dict getnull $info variable] {
    dict set publicvars $property $pdict
    append body \n " [list $property "my variable $property \; return \$property\]"]"
  }

  # End of switch
  append body \n "\}"
  append classbody \n "\}"

  append body \n {return {}}
  
  oo::define $thisclass method property {field args} $body
  oo::objdefine $thisclass method property {field args} $classbody
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::tao::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
}

###
# topic: cd54fcd0eef299655f36c9d1e1454d53
###
proc ::tao::macro {name arglist body} {
  proc ::tao::parser::$name $arglist $body
}

###
# topic: cf50771bb0664678ec3857b360c25aab
# title: Go nowhere, do nothing
###
proc ::tao::noop args {}

###
# topic: 9e8830a711a1a888fb4c94c75bd46bad
# description: Register the existence of an object
###
proc ::tao::object_create object {
}

###
# topic: d42790a731ce9e3ff1866e71f9c42f17
# description: Unregister an object from the odie event manager
###
proc ::tao::object_destroy object {  
  variable trace
  if { $trace } {
    puts [list ::tao::object_destroy $object]
  }
  ::tao::event::generate $object destroy {}
  ###
  # Cancel any events
  ###
  ::tao::event::cancel $object *
  set names [list $object {*}[::tao::db eval {select alias from object_alias where cname=:object}]]
  foreach name $names {
    if {[dict exists $::tao::info::object $name]} {
      dict unset ::tao::info::object $name
    }

    ::tao::db eval {
delete from object where name=:name;
delete from object_bind where object=:name;
delete from object_subscribers where sender=:name;
delete from object_subscribers where receiver=:name;
delete from object_alias where cname=:name or alias=:name;
    }
  }
}

###
# topic: d9ebb42dd1ce3ecde3905b57f96109ab
###
proc ::tao::object_rename {object newname} {
  variable trace
  if { $trace } {
    puts [list ::tao::object_rename $object -> $newname]
  }
  rename $object ::[string trimleft $newname]
  ::tao::db eval {
update object_alias set cname=:newname where cname=:object;
update object set name=:newname where name=:object;
update object_bind set object=:newname where object=:object;
update object_subscribers set sender=:newname where sender=:object;
update object_subscribers set receiver=:newname where receiver=:object;

insert or replace into object_alias(cname,alias) VALUES (:newname,:object);
}
}

###
# topic: 6f46e5ab32dc211c4f838aec8d187c17
###
proc ::tao::Signal_compare {i j sigdat {trace 0}} {
  if {$i == $j} {
    return 0
  }

  set j_preceeds_i [Signal_matches $j [dict get $sigdat $i preceeds]]
  set i_preceeds_j [Signal_matches $i [dict get $sigdat $j preceeds]]
  set j_follows_i [Signal_matches $j [dict get $sigdat $i follows]]
  set i_follows_j [Signal_matches $i [dict get $sigdat $j follows]]

  if {$i_preceeds_j && !$j_preceeds_i && !$i_follows_j} {
    return -1
  }
  if {$j_preceeds_i && !$i_preceeds_j && !$j_follows_i} {
    return 1
  }
  if {$j_follows_i && !$i_follows_j} {
    return 1
  }
  if {$i_follows_j && !$j_follows_i} {
    return -1
  }
  set j_triggers_i [Signal_matches $j [dict get $sigdat $j triggers]]
  set i_triggers_j [Signal_matches $i [dict get $sigdat $i triggers]]
  return 0
}

###
# topic: 1f4128fa725b7af77fc6458fe653a651
###
proc ::tao::signal_expand {rawsignal sigdat {signalvar {}}} {
  if {$signalvar ne {}} {
    upvar 1 $signalvar result
  } else {
    set result {}
  }
  if {$rawsignal in $result} {
    return {}
  }
  if {[dict exists $sigdat $rawsignal]} {
    lappend result $rawsignal
    # Map triggers
    foreach s [dict get $sigdat $rawsignal triggers] {
      signal_expand $s $sigdat result
    }
  } else {
    # Map aliases
    foreach {s info} $sigdat {
      if {$rawsignal in [dict get $info aliases]} {
        signal_expand $s $sigdat result
      }
    }
  }
  return $result
}

###
# topic: a92545861c81e86de17b19b008507776
###
proc ::tao::Signal_matches {signal fieldinfo} {
  foreach value $fieldinfo {
    if {[string match $value $signal]} {
      return 1
    }
  }
  return 0
}

###
# topic: 9cfad45cdb257837b13844261768286e
###
proc ::tao::signal_order sigdat {
  set allsig [lsort -dictionary [dict keys $sigdat]]
  
  foreach i $allsig {
    set follows($i) {}
    set preceeds($i) {}
  }
  foreach i $allsig {
    foreach j $allsig {
      if { $i eq $j } continue
      set cmp [Signal_compare $i $j $sigdat]
      if { $cmp < 0 } {
        ::ladd follows($i) $j
      }
    }
  }
  # Resolve mutual dependencies
  foreach i $allsig {
    foreach j $follows($i) {
      foreach k $follows($j) {
        if {[Signal_compare $i $k $sigdat] < 0} {
          ::ladd follows($i) $k
        }
      }
    }
  }
  foreach i $allsig {
    foreach j $follows($i) {
      ::ladd preceeds($j) $i
    }
  }
  # Start with sorted order
  set order $allsig
  set pass 0
  set changed 1
  while {$changed} {
    set changed 0
    foreach i $allsig {
      set iidx [lsearch $order $i]
      set max $iidx
      foreach j $preceeds($i) {
        set jidx [lsearch $order $j]
        if {$jidx > $max } {
          set after $j
          set max $jidx
        }
      }
      if { $max > $iidx } {
        set changed 1
        set order [lreplace $order $iidx $iidx]
        set order [linsert $order [expr {$max + 1}] $i]
      }
    }
    if {[incr pass]>10} break
  }
  return $order
}

###
# topic: de8ee09c5a76e55364264b1e7a4b8003
###
proc ::tao::singleton {name body} {
  set class ::[string trimleft $name :].class
  #::ladd ::tao::class_list $class
  if { [::info command $class] == {} } {
    ::tao::metaclass create $class
  }
  ::tao::parser::push $class
  namespace eval ::tao::parser $body
  ::tao::parser::pop

  foreach {rname} [::tao::db eval {select name from class where regenerate!=0}] {
    ::tao::dynamic_methods $rname
  }
  $class create $name
}

::namespace eval ::tao {}

::namespace eval ::tao::parser {}

###
# topic: 5832132afd4f65a0dd404f834e7fce7f
# title: Specify other names that this class will answer to
###
proc ::tao::parser::aliases args {
  set class [peek]
  foreach name $args {
    set alias ::[string trimleft $name :]
    set cname [::tao::db one {select cname from class_alias where alias=:alias}]
    if { $cname ni [list {} $class] } {
      error "$alias is already an alias for $cname"
    }
    ::tao::db eval {
insert into class_alias(cname,alias) VALUES (:class,:alias);
}
  }
}

###
# topic: 7a5c7e04989704eef117ff3c9dd88823
# title: Specify the a method for the class object itself, instead of for objects of the class
###
proc ::tao::parser::class_method {name arglist body} {
  set class [peek]
  method $name $arglist $body
  ::tao::db eval {insert or replace into class_typemethod (class,method,arglist,body) VALUES (:class,:name,:arglist,:body);}
}

###
# topic: 710a93168e4ba7a971d3dbb8a3e7bcbc
###
proc ::tao::parser::component args {
  
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::tao::parser::constructor {arglist rawbody} {
  set body {
::tao::object_create [self]
my InitializePublic
  }
  append body $rawbody
  append body {
# Remove lock constructor
my lock remove constructor
  }
  ::oo::define [peek] constructor $arglist $body
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::tao::parser::destructor rawbody {
  set body {
::tao::object_destroy [self]
  }
  append body $rawbody
  ::oo::define [peek] destructor $body
}

###
# topic: ec9ca249b75e2667ad5bcb2f7cd8c568
# title: Define an ensemble method for this agent
###
::proc ::tao::parser::method {rawmethod args} {
  set class [peek]
  set mlist [split $rawmethod "::"]
  if {[llength $mlist]==1} {
    set method $rawmethod
    set arglist [lindex $args 0]
    set body [lindex $args 1]
    ::oo::define $class method $rawmethod {*}$args
    return
  }
  set ensemble [lindex $mlist 0]
  set method [join [lrange $mlist 2 end] "::"]
  switch [llength $args] {
    1 {
      set arglist dictargs
      set body [lindex $args 0]
      ::tao::db eval {
insert or replace into class_ensemble(class,ensemble,method,arglist,body) VALUES
(:class,:ensemble,:method,:arglist,:body)}
    }
    2 {
      set arglist [lindex $args 0]
      set body [lindex $args 1]
      ::tao::db eval {
insert or replace into class_ensemble(class,ensemble,method,arglist,body) VALUES
(:class,:ensemble,:method,:arglist,:body)}
    }
    default {
      error "Usage: method NAME ARGLIST BODY"
    }
  }
}

###
# topic: 68aa446005235a0632a10e2a441c0777
# title: Define an option for the class
###
proc ::tao::parser::option {name args} {
  set class [peek]
  set dictargs {default {}}
  foreach {var val} [::tao::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  
  ###
  # Mirrored Option Handling
  ###
  set mirror [dict getnull $dictargs mirror]
  if {[llength $mirror]} {
    if {![dict exists $dictargs signal]} {
      set signal {}
      foreach i $mirror {
        set sname option_mirror_$i
        lappend signal $sname
        if {![::tao::db exists {select * from class_property where (class=:class or class in (select ancestor from class_ancestor where class=:class)) and type='signal' and property=:sname}]} {
          ::tao::parser::signal $sname [string map [list %signal% sname %organ% $i] {
            action {
              if {[my organ %organ%] ne {}} {
                my %organ% configure {*}[my OptionsMirrored %organ%]
              }
            }
          }]
        }
      }
      dict set dictargs signal $signal
    }
  }
  property 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 ::tao::parser::option_class {name args} {
  set class [peek]
  set dictargs {default {}}
  foreach {var val} [::tao::args_to_dict {*}$args] {
    dict set dictargs [string trimleft $var -] $val
  }
  set name [string trimleft $name -]
  property option_class $name $dictargs
}

###
# topic: baeb5170936f985e0e97be63018bc130
# title: Internal function
# description: Returns the current class being processed
###
proc ::tao::parser::peek args {
  if {[llength $args] == 2} {
    upvar 1 [lindex $args 0] class [lindex $args 1] docnode 
  }
  ::variable classStack
  set class   [lindex $classStack end]
  return ${class}
}

###
# topic: 1c598e92d29ba0311212b3fdf2334b34
# title: Internal function
# description: Removes the current class being processed from the parser stack.
###
proc ::tao::parser::pop {} {
  ::variable classStack
  set class      [lindex $classStack end]
  set classStack [lrange $classStack 0 end-1]

  tao::db eval {update class set regenerate=1 where name=:class}
  # Signal for all decendents to regenerate
  foreach d [::tao::class_descendents $class] {
    tao::db eval {update class set regenerate=1 where name=:d}
  }
  return $class
}

###
# topic: 83160a2aba9dfa455d82b46cdd2e4127
# title: Define the properties for this class as a key/value list
###
proc ::tao::parser::properties args {
  set class [peek]
  switch [llength $args] {
    1 {
      foreach {var val} [lindex $args 0] {
        ::tao::db eval {insert or replace into class_property (class,type,property,dict) VALUES (:class,'const',:var,:val);}
      }
    }
    2 {
      set type [lindex $args 0]
      foreach {var val} [lindex $args 1] {
        ::tao::db eval {insert or replace into class_property (class,type,property,dict) VALUES (:class,:type,:var,:val);}
      }
    }
    default {
      error "Usage: property ?type? infodict"
    }
  }
}

###
# topic: 709b71e10365e576653d00f185ca9efd
# title: Define a single property for this class
# description: If no type is given [emph const] is assumed.
# darglist: [opt [arg type]] [arg name] [arg value]
###
proc ::tao::parser::property args {
  set class [peek]
  switch [llength $args] {
    2 {
      set type const
      set property [lindex $args 0]
      set value [lindex $args 1]
    }
    3 {
      set type     [lindex $args 0]
      set property [lindex $args 1]
      set value    [lindex $args 2]
    }
    default {
      error "Usage: property ?type? field value"
    }
    default {
      error "Usage:
property name typet valuedict
OR property name value"
    }
  }
  if { $type eq {} } {
    set type eval
  }
  ::tao::db eval {insert or replace into class_property (class,type,property,dict) VALUES (:class,:type,:property,:value);}
}

###
# topic: bd23198ef1938428fb1532dd96de2c12
# description: Push a class onto the stack
###
proc ::tao::parser::push type {
  ::variable classStack
  lappend classStack $type
  if {![::tao::db exists {select name from class where name=:type}]} {
    ::tao::db eval {insert into class(name,package,regenerate) VALUES (:type,$::tao::module,1);}
  }
  if {![dict exists $::tao::info::class $type]} {
    dict set ::tao::info::class $type {
      aliases   {}
      ancestors {}
      regenerate 1
      property {}
      ensemble {}
      superclass {::tao::moac}
    }
  } else {
    dict set ::tao::info::class $type regenerate 1
  }
}

###
# topic: 4d12b6ca2823d960a81e6f15fd9962e6
# title: Create a signal for this class
# description:
#    Really just a wrapper for [emph {property signal}]. However,
#    this keyword ensures manditory fields are given.
###
proc ::tao::parser::signal {name infodict} {
  set result {
    apply_action {}
    action       {}
    aliases      {}
    comment      {}
    excludes     {}
    preceeds     {}
    follows      {}
    triggers     {}
  }
  dict set result name $name
  foreach {f v} $infodict {
    dict set result $f $v
  }
  property signal $name $result
}

###
# topic: 2f74ddd49a0c8e8f92e73a843acca2d7
# title: Specify ancestors for this class
# description:
#    This keyword mimics the behavior of the TclOO [emph superclass]
#    keyword. In addition to the TclOO connotations, this keyword
#    also indexes the class in the in-memory database.
#    [para]
#    For classes with no ancestors, call this keyword with no arguments.
#    Failure to do so will cause problems with the property method.
#    [para]
#    This function will also map classes classes refered to by alias.
###
proc ::tao::parser::superclass args {
  set class [peek]
  set ancestors {}
  set direct {}
  set rawvalue {}
  foreach item $args {
    set anc ::[string trimleft $item :]
    set item $anc
    if {[::tao::db exists {select cname from class_alias where alias=:anc}]} {
      set item [::tao::db one {select cname from class_alias where alias=:anc}]
    }
    lappend rawvalue $item
  }
  foreach item $rawvalue {
    if { $item in {::tao::moac ::oo::class} } continue
    if { $item in $::tao::coreclasses } continue
    lappend direct $item
    if { $item ni $ancestors && $item ne $class } {
      lappend direct $item
      lappend ancestors $item
    }
  }
  foreach item $rawvalue {
    if { $item in {::tao::moac ::oo::class} } continue
    if { $item ni $::tao::coreclasses } continue
    lappend direct $item
    if { $item ni $ancestors && $item ne $class } {
      lappend direct $item
      lappend ancestors $item
    }
  }
  if { $class ne "::tao::moac" } {
    lappend ancestors ::tao::moac
  }
  ::tao::db eval {update class set superclass=:ancestors where name=:class}
  ::oo::define $class superclass {*}$ancestors
  
  set order -1
  ::tao::db eval {delete from class_ancestor where class=:class}
  set ancestors [::tao::class_ancestors $class]
  foreach d $ancestors {
    incr order
    ::tao::db eval {insert into class_ancestor(class,seq,ancestor,direct) VALUES (:class,:order,:d,0);}
  }
  foreach d $direct {
    ::tao::db eval {update class_ancestor set direct=1 where class=:class and ancestor=:d}
  }
  property meta ancestors $ancestors
}

###
# 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 ::tao::parser::variable {name {default {}}} {
  property variable $name [list default $default]
}

###
# topic: c5f7c9ada6fe1605219273b957283d70
# description: Work space for the IRM class parser
###
namespace eval ::tao::parser {
  foreach keyword {
    deletemethod export filter forward  renamemethod
    self unexport unknown
  } {
    proc $keyword args "::oo::define \[peek\] $keyword {*}\$args"
  }
  namespace export *
}

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

package ifneeded listutil 1.7 [list source [file join $dir lutils.tcl]]
package ifneeded tao 9.4.4 [list source [file join $dir index.tcl]]