Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Adding a distribution of the Tao core Moved taourl out to a seperate file Adding a stub page to document qwiki |
---|---|
Timelines: | family | ancestors | descendants | both | 4_0 |
Files: | files | file ages | folders |
SHA1: |
52ee0a713bc0afd05a7f5a91a6ac6cf6 |
User & Date: | hypnotoad 2015-04-02 09:39:08.631 |
Context
2015-04-02
| ||
09:47 | Fixed a type in community Fixed the pkgIndex.tcl file in modules/httpd Removed the requirement for odielib check-in: 9aaf42ca4e user: hypnotoad tags: 4_0 | |
09:39 | Adding a distribution of the Tao core Moved taourl out to a seperate file Adding a stub page to document qwiki check-in: 52ee0a713b user: hypnotoad tags: 4_0 | |
09:19 | Moved DirectOO to its own module. Adding markdown files in the source to make maintaining the code simpler check-in: 701281756f user: hypnotoad tags: 4_0 | |
Changes
Changes to modules/community/community.tcl.
1 2 3 | ### # Facilities for user, group, and community management ### | | < > < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ### # 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 {} { |
︙ | ︙ |
Changes to modules/community/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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::community 0.1 [list source [file join $dir community.tcl]] | > | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. 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]] |
Added modules/directoo/pkgIndex.tcl.
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. 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]] |
Added modules/directoo/taourl.md.
Added modules/directoo/taourl.tcl.
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | 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 |
Added modules/qwiki/qwiki.md.
Added modules/tao/db.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | ### # 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 } |
Added modules/tao/diagram.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | ::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 _] } |
Added modules/tao/event.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 | ### # 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 } |
Added modules/tao/index.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | 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 |
Added modules/tao/license.terms.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | 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. |
Added modules/tao/lutils.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | ### 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 } |
Added modules/tao/moac.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 | #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 } } |
Added modules/tao/module.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | ::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 |
Added modules/tao/mvc.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | ### # 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] } } } } |
Added modules/tao/onion.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | ### # 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 } } |
Added modules/tao/ootools.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 | ::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 } |
Added modules/tao/parser.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 | ::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 * } |
Added modules/tao/pkgIndex.tcl.
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. 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]] |
Added modules/tao/tao.md.