Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Abandoning efforts to merge the hypnotoad branch into trunk Copying files straight over from the clay fossil repo. |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | httpd-clay |
Files: | files | file ages | folders |
SHA3-256: |
c4f2912d41441fdfea35982ca3dd0cea |
User & Date: | hypnotoad 2019-06-04 00:21:20.436 |
Context
2019-06-04
| ||
00:21 | Abandoning efforts to merge the hypnotoad branch into trunk Copying files straight over from the clay fossil repo. Closed-Leaf check-in: c4f2912d41 user: hypnotoad tags: httpd-clay | |
2019-05-07
| ||
19:05 | Add two tests for the quasirandom packages; describe and test the estimates for the number of primes in an interval check-in: c2db185801 user: arjenmarkus tags: trunk | |
Changes
Added modules/clay/build/build.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 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] set version 0.8 set module clay set filename clay if {[file exists [file join $moddir .. .. scripts practcl.tcl]]} { source [file join $moddir .. .. scripts practcl.tcl] } elseif {[file exists [file join $moddir .. practcl build doctool.tcl]]} { source [file join $moddir .. practcl build doctool.tcl] } else { package require practcl 0.14 } ::practcl::doctool create AutoDoc set fout [open [file join $moddir ${filename}.tcl] w] dict set modmap %module% $module dict set modmap %version% $version dict set modmap %license% BSD dict set modmap %filename% $filename set authors {{Sean Woods} {<[email protected]>}} puts $fout [string map $modmap {### # %filename%.tcl # # Copyright (c) 2018 Sean Woods # # BSD License ### # @@ Meta Begin # Package %module% %version% # Meta platform tcl # Meta summary A minimalist framework for complex TclOO development # Meta description This package introduces the method "clay" to both oo::object # Meta description and oo::class which facilitate complex interactions between objects # Meta description and their ancestor and mixed in classes. # Meta category TclOO # Meta subject framework # Meta require {Tcl 8.6}}] foreach {name email} $authors { puts $fout "# Meta author $name" } puts $fout [string map $modmap {# Meta license %license% # @@ Meta End }] puts $fout [string map $modmap {### # Amalgamated package for %module% # Do not edit directly, tweak the source in build/ and rerun # build.tcl ### package provide %module% %version% namespace eval ::%module% {} }] # Track what files we have included so far set loaded {} lappend loaded build.tcl test.tcl foreach file { procs.tcl core.tcl uuid.tcl dict.tcl list.tcl dictargs.tcl dialect.tcl metaclass.tcl ensemble.tcl class.tcl object.tcl } { lappend loaded $file set content [::practcl::cat [file join $srcdir {*}$file]] AutoDoc scan_text $content puts $fout "###\n# START: [file tail $file]\n###" puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # These files can be loaded in any order foreach file [lsort -dictionary [glob [file join $srcdir *.tcl]]] { if {[file tail $file] in $loaded} continue lappend loaded $file set content [::practcl::cat [file join $srcdir {*}$file]] AutoDoc scan_text $content puts $fout "###\n# START: [file tail $file]\n###" puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # Provide some cleanup and our final package provide puts $fout [string map $modmap { namespace eval ::%module% { namespace export * } }] close $fout ### # Build our pkgIndex.tcl file ### set fout [open [file join $moddir pkgIndex.tcl] w] puts $fout [string map $modmap {# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.6]} {return} }] puts $fout [string map $modmap { package ifneeded %module% %version% [list source [file join $dir %module%.tcl]] }] close $fout ### # Generate the test script ### namespace eval ::clay {} source [file join $srcdir procs.tcl] set fout [open [file join $moddir $filename.test] w] puts $fout { namespace eval ::oo::dialect {} set ::oo::dialect::has(tip470) 0 } puts $fout [source [file join $srcdir test.tcl]] puts $fout { if {![package vsatisfies [package provide Tcl] 8.7]} {return} puts "Repeating tests with 8.7 features" namespace eval ::oo::dialect {} set ::oo::dialect::has(tip470) 1 } puts $fout [source [file join $srcdir test.tcl]] close $fout set manout [open [file join $moddir $filename.man] w] puts $manout [AutoDoc manpage map $modmap \ header [::practcl::cat [file join $srcdir manual.txt]] \ authors $authors \ footer [::practcl::cat [file join $srcdir footer.txt]] \ ] close $manout |
Added modules/clay/build/class.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 | ::oo::define ::clay::class { ### # description: # The [method clay] method allows a class object access # to a combination of its own clay data as # well as to that of its ancestors # ensemble: # ancestors { # argspec {} # description {Return this class and all ancestors in search order.} # } # dump { # argspec {} # description {Return a complete dump of this object's clay data, but only this object's clay data.} # } # find { # argspec {path {mandatory 1 positional 1 repeating 1}} # description { # Pull a chunk of data from the clay system. If the last element of [emph path] is a branch, # returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. # If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching # leaf and return the first value found. # If no value is found, returns an empty string. # If a branch is returned the topmost . entry is omitted. # } # } # get { # argspec {path {mandatory 1 positional 1 repeating 1}} # description { # Pull a chunk of data from the class's clay system. # If no value is found, returns an empty string. # If a branch is returned the topmost . entry is omitted. # } # } # GET { # argspec {path {mandatory 1 positional 1 repeating 1}} # description { # Pull a chunk of data from the class's clay system. # If no value is found, returns an empty string. # } #} # merge { # argspec {dict {mandatory 1 positional 1 repeating 1}} # description {Recursively merge the dictionaries given into the object's local clay storage.} # } # replace { # argspec {dictionary {mandatory 1 positional 1}} # description {Replace the contents of the internal clay storage with the dictionary given.} # } # search { # argspec {path {mandatory 1 positional 1 repeating 1}} # description {Return the first matching value for the path in either this class's clay data or one of its ancestors} # } # set { # argspec {path {mandatory 1 positional 1 repeating 1} value {mandatory 1 postional 1}} # description {Merge the conents of [const value] with the object's clay storage at [const path].} # } ### method clay {submethod args} { my variable clay if {![info exists clay]} { set clay {} } switch $submethod { ancestors { tailcall ::clay::ancestors [self] } branch { set path [::clay::tree::storage $args] if {![dict exists $clay {*}$path .]} { dict set clay {*}$path . {} } } exists { if {![info exists clay]} { return 0 } set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return 1 } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return 1 } return 0 } dump { return $clay } dget { if {![info exists clay]} { return {} } set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] } return {} } is_branch { set path [::clay::tree::storage $args] return [dict exists $clay {*}$path .] } getnull - get { if {![info exists clay]} { return {} } set path [::clay::tree::storage $args] if {[llength $path]==0} { return $clay } if {[dict exists $clay {*}$path .]} { return [::clay::tree::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] } return {} } find { set path [::clay::tree::storage $args] if {![info exists clay]} { set clay {} } set clayorder [::clay::ancestors [self]] set found 0 if {[llength $path]==0} { set result [dict create . {}] foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } return [::clay::tree::sanitize $result] } foreach class $clayorder { if {[$class clay exists {*}$path .]} { # Found a branch break set found 1 break } if {[$class clay exists {*}$path]} { # Found a leaf. Return that value immediately return [$class clay get {*}$path] } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] } } if {!$found} { return {} } set result {} # Leaf searches return one data field at a time # Search in our local dict # Search in the in our list of classes for an answer foreach class [lreverse $clayorder] { ::clay::tree::dictmerge result [$class clay dget {*}$path] } return [::clay::tree::sanitize $result] } merge { foreach arg $args { ::clay::tree::dictmerge clay {*}$arg } } noop { # Do nothing. Used as a sign of clay savviness } search { foreach aclass [::clay::ancestors [self]] { if {[$aclass clay exists {*}$args]} { return [$aclass clay get {*}$args] } } } set { ::clay::tree::dictset clay {*}$args } unset { dict unset clay {*}$args } default { dict $submethod clay {*}$args } } } } |
Added modules/clay/build/core.tcl.
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. if {[info commands irmmd5] eq {}} { if {[catch {package require odielibc}]} { package require md5 2 } } ::namespace eval ::clay {} ::namespace eval ::clay::classes {} ::namespace eval ::clay::define {} ::namespace eval ::clay::tree {} ::namespace eval ::clay::dict {} ::namespace eval ::clay::list {} ::namespace eval ::clay::uuid {} if {![info exists ::clay::idle_destroy]} { set ::clay::idle_destroy {} } |
Added modules/clay/build/dialect.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 | ### # Adapted from Tcllib's oo::dialect # # Copyright (c) 2015-2018 Sean Woods # Copyright (c) 2015 Donald K Fellows # # BSD License ### # @@ Meta Begin # Package clay::dialect 0.4 # Meta platform tcl # Meta summary A utility for defining a domain specific language for TclOO systems # Meta description This package allows developers to generate # Meta description domain specific languages to describe TclOO # Meta description classes and objects. # Meta category TclOO # Meta subject oodialect # Meta require {Tcl 8.6} # Meta author Sean Woods # Meta author Donald K. Fellows # Meta license BSD # @@ Meta End namespace eval ::clay::dialect { namespace export create # Allow test rigs to overwrite the flags before invoking this script foreach {flag test} { tip470 {package vsatisfies [package provide Tcl] 8.7} } { if {![info exists ::clay::dialect::has($flag)]} { set ::clay::dialect::has($flag) [eval $test] } } } proc ::clay::dialect::Push {class} { ::variable class_stack lappend class_stack $class } proc ::clay::dialect::Peek {} { ::variable class_stack return [lindex $class_stack end] } proc ::clay::dialect::Pop {} { ::variable class_stack set class_stack [lrange $class_stack 0 end-1] } if {$::clay::dialect::has(tip470)} { proc ::clay::dialect::current_class {} { return [uplevel 1 self] } } else { proc ::clay::dialect::current_class {} { tailcall Peek } } ### # This proc will generate a namespace, a "mother of all classes", and a # rudimentary set of policies for this dialect. ### proc ::clay::dialect::create {name {parent ""}} { variable has set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name] ::namespace eval $NSPACE {::namespace eval define {}} ### # Build the "define" namespace ### if {$parent eq ""} { ### # With no "parent" language, begin with all of the keywords in # oo::define ### foreach command [info commands ::oo::define::*] { set procname [namespace tail $command] interp alias {} ${NSPACE}::define::$procname {} \ ::clay::dialect::DefineThunk $procname } # Create an empty dynamic_methods proc proc ${NSPACE}::dynamic_methods {class} {} namespace eval $NSPACE { ::namespace export dynamic_methods ::namespace eval define {::namespace export *} } set ANCESTORS {} } else { ### # If we have a parent language, that language already has the # [oo::define] keywords as well as additional keywords and behaviors. # We should begin with that ### set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent] apply [list parent { ::namespace export dynamic_methods ::namespace import -force ${parent}::dynamic_methods } $NSPACE] $pnspace apply [list parent { ::namespace import -force ${parent}::define::* ::namespace export * } ${NSPACE}::define] $pnspace set ANCESTORS [list ${pnspace}::object] } ### # Build our dialect template functions ### proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] { ### # To facilitate library reloading, allow # a dialect to create a class from DEFINE ### set class [::clay::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass] if {[info commands $class] eq {}} { %NSPACE%::class create $class {*}${args} } else { ::clay::dialect::Define %NSPACE% $class {*}${args} } }] interp alias {} ${NSPACE}::define::current_class {} \ ::clay::dialect::current_class interp alias {} ${NSPACE}::define::aliases {} \ ::clay::dialect::Aliases $NSPACE interp alias {} ${NSPACE}::define::superclass {} \ ::clay::dialect::SuperClass $NSPACE if {[info command ${NSPACE}::class] ne {}} { ::rename ${NSPACE}::class {} } ### # Build the metaclass for our language ### ::oo::class create ${NSPACE}::class { superclass ::clay::dialect::MotherOfAllMetaClasses } # Wire up the create method to add in the extra argument we need; the # MotherOfAllMetaClasses will know what to do with it. ::oo::objdefine ${NSPACE}::class \ method create {name {definitionScript ""}} \ "next \$name [list ${NSPACE}::define] \$definitionScript" ### # Build the mother of all classes. Note that $ANCESTORS is already # guaranteed to be a list in canonical form. ### uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { %NSPACE%::class create %NSPACE%::object { superclass %ANCESTORS% # Put MOACish stuff in here } }] if { "${NSPACE}::class" ni $::clay::dialect::core_classes } { lappend ::clay::dialect::core_classes "${NSPACE}::class" } if { "${NSPACE}::object" ni $::clay::dialect::core_classes } { lappend ::clay::dialect::core_classes "${NSPACE}::object" } } # Support commands; not intended to be called directly. proc ::clay::dialect::NSNormalize {namespace qualname} { if {![string match ::* $qualname]} { set qualname ${namespace}::$qualname } regsub -all {::+} $qualname "::" } proc ::clay::dialect::DefineThunk {target args} { tailcall ::oo::define [Peek] $target {*}$args } proc ::clay::dialect::Canonical {namespace NSpace class} { namespace upvar $namespace cname cname #if {[string match ::* $class]} { # return $class #} if {[info exists cname($class)]} { return $cname($class) } if {[info exists ::clay::dialect::cname($class)]} { return $::clay::dialect::cname($class) } if {[info exists ::clay::dialect::cname(${NSpace}::${class})]} { return $::clay::dialect::cname(${NSpace}::${class}) } foreach item [list "${NSpace}::$class" "::$class"] { if {[info commands $item] ne {}} { return $item } } return ${NSpace}::$class } ### # Implementation of the languages' define command ### proc ::clay::dialect::Define {namespace class args} { Push $class try { if {[llength $args]==1} { namespace eval ${namespace}::define [lindex $args 0] } else { ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end] } ${namespace}::dynamic_methods $class } finally { Pop } } ### # Implementation of how we specify the other names that this class will answer # to ### proc ::clay::dialect::Aliases {namespace args} { set class [Peek] namespace upvar $namespace cname cname set NSpace [join [lrange [split $class ::] 1 end-2] ::] set cname($class) $class foreach name $args { set cname($name) $class #set alias $name set alias [NSNormalize $NSpace $name] # Add a local metaclass reference if {![info exists ::clay::dialect::cname($alias)]} { lappend ::clay::dialect::aliases($class) $alias ## # Add a global reference, first come, first served ## set ::clay::dialect::cname($alias) $class } } } ### # Implementation of a superclass keyword which will enforce the inheritance of # our language's mother of all classes ### proc ::clay::dialect::SuperClass {namespace args} { set class [Peek] namespace upvar $namespace class_info class_info dict set class_info($class) superclass 1 set ::clay::dialect::cname($class) $class set NSpace [join [lrange [split $class ::] 1 end-2] ::] set unique {} foreach item $args { set Item [Canonical $namespace $NSpace $item] dict set unique $Item $item } set root ${namespace}::object if {$class ne $root} { dict set unique $root $root } tailcall ::oo::define $class superclass {*}[dict keys $unique] } ### # Implementation of the common portions of the the metaclass for our # languages. ### if {[info command ::clay::dialect::MotherOfAllMetaClasses] eq {}} { ::oo::class create ::clay::dialect::MotherOfAllMetaClasses { superclass ::oo::class constructor {define definitionScript} { $define [self] { superclass } $define [self] $definitionScript } method aliases {} { if {[info exists ::clay::dialect::aliases([self])]} { return $::clay::dialect::aliases([self]) } } } } namespace eval ::clay::dialect { variable core_classes {::oo::class ::oo::object} } |
Added modules/clay/build/dict.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 | ### # If the path (given by the list of elements) exists, return that value. # Otherwise return an empty string. Designed to replace [example { # if {[dict exists $dictionary {*}$args]} { # return [dict get $dictionary {*}$args] # } else { # return {} # } # }] # example: # set value [dict getnull $arglist $option] # arglist: # dictionary {mandatory 1 positional 1} # element {mandatory 0 positional 1 repeating 1} ### ::clay::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] } ### # Test if value is a dict. # [para] # This command is added to the [fun dict] ensemble as [fun {dict is_dict}] ### ::clay::PROC ::tcl::dict::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict] } ### # A routine to recursively dig through dicts and merge # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/ ### ::clay::PROC ::tcl::dict::rmerge {args} { ::set result [dict create . {}] # Merge b into a, and handle nested dicts appropriately ::foreach b $args { for { k v } $b { ::set field [string trim $k :/] if {![::clay::tree::is_branch $b $k]} { # Element names that end in ":" are assumed to be literals set result $k $v } elseif { [exists $result $k] } { # key exists in a and b? let's see if both values are dicts # both are dicts, so merge the dicts if { [is_dict [get $result $k]] && [is_dict $v] } { set result $k [rmerge [get $result $k] $v] } else { set result $k $v } } else { set result $k $v } } } return $result } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge] } ### # Return true if the element [variable path] with the value [variable dict] # is a dict. [variable path] is given as a list to descend into sub-dicts of # the current dict. # The rules are as follows: # [list_begin enumerated] # [enum] # If the last character of the last element of [variable path] is a colon (:) # return false # [enum] # If the last character of the last element of [variable path] is a slash (/) # return true # [enum] # If a sub-element if [variable path] named [const .info] is present return true # [list_end] # [para] # [para] # This command is added to the [fun dict] ensemble as [fun {clay::tree::is_branch}] # example: # > set mydict {sub/ {sub/ {field {A block of text}}} # > clay::tree::is_branch $mydict sub/ # 1 # > clay::tree::is_branch $mydict {sub/ sub/} # 1 # > clay::tree::is_branch $mydict {sub/ sub/ field} # 0 ### ::clay::PROC ::clay::tree::is_branch { dict path } { set field [lindex $path end] if {[string index $field end] eq ":"} { return 0 } if {[string index $field 0] eq "."} { return 0 } if {[string index $field end] eq "/"} { return 1 } return [dict exists $dict {*}$path .] } ### # Output a dictionary as an indented stream of # data suitable for output to the screen. The system uses # the rules for [fun {clay::tree::is_branch}] to determine if # an value in a dictionary is a leaf or a branch. # example: # > set mydict {sub/ {sub/ {field {A block of text}}} # > clay::tree::print $mydict # sub/ { # sub/ { # field {A block of text} # } # } ### ::clay::PROC ::clay::tree::print {dict} { ::set result {} ::set level -1 ::clay::tree::_dictputb $level result $dict return $result } ### # Helper function for ::clay::tree::print # Formats the string representation for a dictionary element within # a human readable stream of lines, and determines if it needs to call itself # with further indentation to express a sub-branch ### ::clay::PROC ::clay::tree::_dictputb {level varname dict} { upvar 1 $varname result incr level dict for {field value} $dict { if {$field eq "."} continue if {[clay::tree::is_branch $dict $field]} { putb result "[string repeat " " $level]$field \{" _dictputb $level result $value putb result "[string repeat " " $level]\}" } else { putb result "[string repeat " " $level][list $field $value]" } } } ### # Output a dictionary removing any . entries added by [fun {clay::tree::merge}] ### proc ::clay::tree::sanitize {dict} { ::set result {} ::set level -1 ::clay::tree::_sanitizeb {} result $dict return $result } ### # Helper function for ::clay::tree::sanitize # Formats the string representation for a dictionary element within # a human readable stream of lines, and determines if it needs to call itself # with further indentation to express a sub-branch ### proc ::clay::tree::_sanitizeb {path varname dict} { upvar 1 $varname result dict for {field value} $dict { if {$field eq "."} continue if {[clay::tree::is_branch $dict $field]} { _sanitizeb [list {*}$path $field] result $value } else { dict set result {*}$path $field $value } } } ### # Return the path as a storage path for clay::tree # with all branch terminators removed. # This command will also break arguments up if they # contain /. # example: # > clay::tree::storage {foo bar baz bang} # foo bar baz bang # > clay::tree::storage {foo bar baz bang/} # foo bar baz bang # > clay::tree::storage {foo bar baz bang:} # foo bar baz bang: # > clay::tree::storage {foo/bar/baz bang:} # foo bar baz bang: # > clay::tree::storage {foo/bar/baz/bang} # foo bar baz bang ### proc ::clay::tree::storage {rawpath} { set isleafvar 0 set path {} set tail [string index $rawpath end] foreach element $rawpath { set items [split [string trim $element /] /] foreach item $items { if {$item eq {}} continue lappend path $item } } return $path } ### # Set an element with a recursive dictionary, # marking all branches on the way down to the # final element. # If the value does not exists in the nested dictionary # it is added as a leaf. If the value already exists as a branch # the value given is merged if the value is a valid dict. If the # incoming value is not a valid dict, the value overrides the value # stored, and the value is treated as a leaf from then on. # example: # > set r {} # > ::clay::tree::dictset r option color default Green # . {} option {. {} color {. {} default Green}} # > ::clay::tree::dictset r option {Something not dictlike} # . {} option {Something not dictlike} # # Note that if the value is not a dict, and you try to force it to be # # an error with be thrown on the merge # > ::clay::tree::dictset r option color default Blue # missing value to go with key ### proc ::clay::tree::dictset {varname args} { upvar 1 $varname result if {[llength $args] < 2} { error "Usage: ?path...? path value" } elseif {[llength $args]==2} { set rawpath [lindex $args 0] } else { set rawpath [lrange $args 0 end-1] } set value [lindex $args end] set path [storage $rawpath] set dot . set one {} dict set result $dot $one set dpath {} foreach item [lrange $path 0 end-1] { set field $item lappend dpath [string trim $item /] dict set result {*}$dpath $dot $one } set field [lindex $rawpath end] set ext [string index $field end] if {$ext eq {:} || ![dict is_dict $value]} { dict set result {*}$path $value return } if {$ext eq {/} && ![dict exists $result {*}$path $dot]} { dict set result {*}$path $dot $one } if {[dict exists $result {*}$path $dot]} { dict set result {*}$path [::clay::tree::merge [dict get $result {*}$path] $value] return } dict set result {*}$path $value } ### # A recursive form of dict merge, intended for modifying variables in place. # example: # > set mydict {sub/ {sub/ {description {a block of text}}}} # > ::clay::tree::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}] # > clay::tree::print $mydict # sub/ { # sub/ { # description {a block of text} # field {another block of text} # } # } ### proc ::clay::tree::dictmerge {varname args} { upvar 1 $varname result set dot . set one {} dict set result $dot $one foreach dict $args { dict for {f v} $dict { set field [string trim $f /] set bbranch [clay::tree::is_branch $dict $f] if {![dict exists $result $field]} { dict set result $field $v if {$bbranch} { dict set result $field [clay::tree::merge $v] } else { dict set result $field $v } } elseif {[dict exists $result $field $dot]} { if {$bbranch} { dict set result $field [clay::tree::merge [dict get $result $field] $v] } else { dict set result $field $v } } } } return $result } ### # A recursive form of dict merge # [para] # A routine to recursively dig through dicts and merge # adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/ # example: # > set mydict {sub/ {sub/ {description {a block of text}}}} # > set odict [clay::tree::merge $mydict {sub/ {sub/ {field {another block of text}}}}] # > clay::tree::print $odict # sub/ { # sub/ { # description {a block of text} # field {another block of text} # } # } ### proc ::clay::tree::merge {args} { ### # The result of a merge is always a dict with branches ### set dot . set one {} dict set result $dot $one set argument 0 foreach b $args { # Merge b into a, and handle nested dicts appropriately if {![dict is_dict $b]} { error "Element $b is not a dictionary" } dict for { k v } $b { if {$k eq $dot} { dict set result $dot $one continue } set bbranch [is_branch $b $k] set field [string trim $k /] if { ![dict exists $result $field] } { if {$bbranch} { dict set result $field [merge $v] } else { dict set result $field $v } } else { set abranch [dict exists $result $field $dot] if {$abranch && $bbranch} { dict set result $field [merge [dict get $result $field] $v] } else { dict set result $field $v if {$bbranch} { dict set result $field $dot $one } } } } } return $result } ### # Returns true if the path specified by args either does not exist, # if exists and contains an empty string or the value of NULL or null. # [para] # This function is added to the global dict ensemble as [fun {dict isnull}] ### ::clay::PROC ::tcl::dict::isnull {dictionary args} { if {![exists $dictionary {*}$args]} {return 1} return [expr {[get $dictionary {*}$args] in {{} NULL null}}] } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull] } |
Added modules/clay/build/dictargs.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 | namespace eval ::dictargs {} if {[info commands ::dictargs::parse] eq {}} { proc ::dictargs::parse {argdef argdict} { set result {} dict for {field info} $argdef { if {![string is alnum [string index $field 0]]} { error "$field is not a simple variable name" } upvar 1 $field _var set aliases {} if {[dict exists $argdict $field]} { set _var [dict get $argdict $field] continue } if {[dict exists $info aliases:]} { set found 0 foreach {name} [dict get $info aliases:] { if {[dict exists $argdict $name]} { set _var [dict get $argdict $name] set found 1 break } } if {$found} continue } if {[dict exists $info default:]} { set _var [dict get $info default:] continue } set mandatory 1 if {[dict exists $info mandatory:]} { set mandatory [dict get $info mandatory:] } if {$mandatory} { error "$field is required" } } } } ### # Named Procedures as new command ### proc ::dictargs::proc {name argspec body} { set result {} append result "::dictargs::parse \{$argspec\} \$args" \; append result $body uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result] } proc ::dictargs::method {name argspec body} { set class [lindex [::info level -1] 1] set result {} append result "::dictargs::parse \{$argspec\} \$args" \; append result $body oo::define $class method $name [list [list args [list dictargs $argspec]]] $result } |
Added modules/clay/build/ensemble.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 | ::namespace eval ::clay::define {} proc ::clay::ensemble_methodbody {ensemble einfo} { set default standard set preamble {} set eswitch {} if {[dict exists $einfo default]} { set emethodinfo [dict get $einfo default] set argspec [dict getnull $emethodinfo argspec] set realbody [dict getnull $emethodinfo body] set argstyle [dict getnull $emethodinfo argstyle] if {$argstyle eq "dictargs"} { set body "\n ::dictargs::parse \{$argspec\} \$args" } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} { set body {} } else { set body "\n ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args" } append body "\n " [string trim $realbody] " \n" set default $body dict unset einfo default } foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] { set submethod [string trim $msubmethod :/-] if {$submethod eq "_body"} continue if {$submethod eq "_preamble"} { set preamble [dict getnull $esubmethodinfo body] continue } set argspec [dict getnull $esubmethodinfo argspec] set realbody [dict getnull $esubmethodinfo body] set argstyle [dict getnull $esubmethodinfo argstyle] if {[string length [string trim $realbody]] eq {}} { dict set eswitch $submethod {} } else { if {$argstyle eq "dictargs"} { set body "\n ::dictargs::parse \{$argspec\} \$args" } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} { set body {} } else { set body "\n ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args" } append body "\n " [string trim $realbody] " \n" if {$submethod eq "default"} { set default $body } else { foreach alias [dict getnull $esubmethodinfo aliases] { dict set eswitch $alias - } dict set eswitch $submethod $body } } } set methodlist [lsort -dictionary [dict keys $eswitch]] if {![dict exists $eswitch <list>]} { dict set eswitch <list> {return $methodlist} } if {$default eq "standard"} { set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\"" } dict set eswitch default $default set mbody {} append mbody $preamble \n append mbody \n [list set methodlist $methodlist] append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]" append mbody \n {return -options $opts $result} return $mbody } ::proc ::clay::define::Ensemble {rawmethod args} { if {[llength $args]==2} { lassign $args argspec body set argstyle tcl } elseif {[llength $args]==3} { lassign $args argstyle argspec body } else { error "Usage: Ensemble name ?argstyle? argspec body" } set class [current_class] #if {$::clay::trace>2} { # puts [list $class Ensemble $rawmethod $argspec $body] #} set mlist [split $rawmethod "::"] set ensemble [string trim [lindex $mlist 0] :/] set mensemble ${ensemble}/ if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} { set method _body ### # Simple method, needs no parsing, but we do need to record we have one ### if {$argstyle eq "dictargs"} { set argspec [list args $argspec] } $class clay set method_ensemble/ $mensemble _body [dict create argspec $argspec body $body argstyle $argstyle] if {$::clay::trace>2} { puts [list $class clay set method_ensemble/ $mensemble _body ...] } set method $rawmethod if {$::clay::trace>2} { puts [list $class Ensemble $rawmethod $argspec $body] set rawbody $body set body {puts [list [self] $class [self method]]} append body \n $rawbody } if {$argstyle eq "dictargs"} { set rawbody $body set body "::dictargs::parse \{$argspec\} \$args\; " append body $rawbody } ::oo::define $class method $rawmethod $argspec $body return } set method [join [lrange $mlist 2 end] "::"] $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create argspec $argspec body $body argstyle $argstyle] if {$::clay::trace>2} { puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/] ...] } } |
Added modules/clay/build/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 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | ::namespace eval ::clay::event {} ### # Mark an object for destruction on the next cleanup ### proc ::clay::destroy args { if {![info exists ::clay::idle_destroy]} { set ::clay::idle_destroy {} } foreach object $args { if {$object in $::clay::idle_destroy} continue lappend ::clay::idle_destroy $object } } ### # Process the queue of objects to be destroyed ### proc ::clay::cleanup {} { if {![info exists ::clay::idle_destroy]} return foreach obj $::clay::idle_destroy { if {[info commands $obj] ne {}} { catch {$obj destroy} } } set ::clay::idle_destroy {} } ### # description: Cancel a scheduled event ### proc ::clay::event::cancel {self {task *}} { variable timer_event variable timer_script foreach {id event} [array get timer_event $self:$task] { ::after cancel $event set timer_event($id) {} set timer_script($id) {} } } ### # description: # Generate an event # Adds a subscription mechanism for objects # to see who has recieved this event and prevent # spamming or infinite recursion ### proc ::clay::event::generate {self event args} { set wholist [Notification_list $self $event] if {$wholist eq {}} return set dictargs [::oo::meta::args_to_options {*}$args] set info $dictargs set strict 0 set debug 0 set sender $self dict with dictargs {} dict set info id [::clay::event::nextid] dict set info origin $self dict set info sender $sender dict set info rcpt {} foreach who $wholist { catch {::clay::event::notify $who $self $event $info} } } ### # title: Return a unique event handle ### proc ::clay::event::nextid {} { return "event#[format %0.8x [incr ::clay::event_count]]" } ### # description: # Called recursively to produce a list of # who recieves notifications ### proc ::clay::event::Notification_list {self event {stackvar {}}} { set notify_list {} foreach {obj patternlist} [array get ::clay::object_subscribe] { if {$obj eq $self} continue if {$obj in $notify_list} continue set match 0 foreach {objpat eventlist} $patternlist { if {![string match $objpat $self]} continue foreach eventpat $eventlist { if {![string match $eventpat $event]} continue set match 1 break } if {$match} { break } } if {$match} { lappend notify_list $obj } } return $notify_list } ### # Final delivery to intended recipient object ### proc ::clay::event::notify {rcpt sender event eventinfo} { if {[info commands $rcpt] eq {}} return if {$::clay::trace} { puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo] } $rcpt notify $event $sender $eventinfo } ### # Evaluate an event script in the global namespace ### proc ::clay::event::process {self handle script} { variable timer_event variable timer_script array unset timer_event $self:$handle array unset timer_script $self:$handle set err [catch {uplevel #0 $script} result errdat] if $err { puts "BGError: $self $handle $script ERR: $result [dict get $errdat -errorinfo] ***" } } ### # description: Schedule an event to occur later ### proc ::clay::event::schedule {self handle interval script} { variable timer_event variable timer_script if {$::clay::trace} { puts [list $self schedule $handle $interval] } if {[info exists timer_event($self:$handle)]} { if {$script eq $timer_script($self:$handle)} { return } ::after cancel $timer_event($self:$handle) } set timer_script($self:$handle) $script set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]] } ### # Subscribe an object to an event pattern ### proc ::clay::event::subscribe {self who event} { upvar #0 ::clay::object_subscribe($self) subscriptions if {![info exists subscriptions]} { set subscriptions {} } set match 0 foreach {objpat eventlist} $subscriptions { if {![string match $objpat $who]} continue foreach eventpat $eventlist { if {[string match $eventpat $event]} { # This rule already exists return } } } dict lappend subscriptions $who $event } ### # Unsubscribe an object from an event pattern ### proc ::clay::event::unsubscribe {self args} { upvar #0 ::clay::object_subscribe($self) subscriptions if {![info exists subscriptions]} { return } switch [llength $args] { 1 { set event [lindex $args 0] if {$event eq "*"} { # Shortcut, if the set subscriptions {} } else { set newlist {} foreach {objpat eventlist} $subscriptions { foreach eventpat $eventlist { if {[string match $event $eventpat]} continue dict lappend newlist $objpat $eventpat } } set subscriptions $newlist } } 2 { set who [lindex $args 0] set event [lindex $args 1] if {$who eq "*" && $event eq "*"} { set subscriptions {} } else { set newlist {} foreach {objpat eventlist} $subscriptions { if {[string match $who $objpat]} { foreach eventpat $eventlist { if {[string match $event $eventpat]} continue dict lappend newlist $objpat $eventpat } } } set subscriptions $newlist } } } } |
Added modules/clay/build/footer.txt.
> > | 1 2 | [vset CATEGORY oo] [include ../doctools2base/include/feedback.inc] |
Added modules/clay/build/list.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 | ### # Add elements to a list if that are not already present in the list. # As a side effect, if variable [variable varname] does not exists, # create it as an empty list. # arglist: # varname {positional 1 mandatory 1} # element {positional 1 mandatory 0 repeating 1} # example: # ladd contents foo bar # puts $contents # > foo bar # ladd contents foo bar baz bang # puts $contents # > foo bar baz bang ### ::clay::PROC ::clay::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 } ### # Delete all instances of the elements given from a list contained in [variable varname]. # If the variable does exist this is a noop. # arglist: # varname {positional 1 mandatory 1} # element {positional 1 mandatory 0 repeating 1} # example: # set contents {foo bar baz bang foo foo foo} # ldelete contents foo # puts $contents # > bar baz bang ### ::clay::PROC ::clay::ldelete {varname args} { upvar 1 $varname var if ![info exists var] { return } foreach item [lsort -unique $args] { while {[set i [lsearch $var $item]]>=0} { set var [lreplace $var $i $i] } } return $var } ### # Return a random element from [variable list] ### ::clay::PROC ::clay::lrandom list { set len [llength $list] set idx [expr int(rand()*$len)] return [lindex $list $idx] } |
Added modules/clay/build/manual.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | [keywords oo] [copyright {2018 Sean Woods <[email protected]>}] [moddesc {Clay Framework}] [titledesc {A minimalist framework for large scale OO Projects}] [category {Programming tools}] [keywords TclOO] [require Tcl 8.6] [require uuid] [require oo::dialect] [description] Clay introduces a method ensemble to both [class oo::class] and [class oo::object] called clay. This ensemble handles all of the high level interactions within the framework. Clay stores structured data. Clan manages method delegation. Clay has facilities to manage the complex interactions that come about with mixins. [para] The central concept is that inside of every object and class (which are actually objects too) is a dict called clay. What is stored in that dict is left to the imagination. But because this dict is exposed via a public method, we can share structured data between object, classes, and mixins. [para] [subsection {Structured Data}] Clay uses a standardized set of method interactions and introspection that TclOO already provides to perform on-the-fly searches. On-the-fly searches mean that the data is never stale, and we avoid many of the sorts of collisions that would arise when objects start mixing in other classes during operation. [para] The [method clay] methods for both classes and objects have a get and a set method. For objects, get will search through the local clay dict. If the requested leaf is not found, or the query is for a branch, the system will then begin to poll the clay methods of all of the class that implements the object, all of that classes’ ancestors, as well as all of the classes that have been mixed into this object, and all of their ancestors. [para] Intended branches on a tree end with a directory slash (/). Intended leaves are left unadorned. This is a guide for the tool that builds the search results to know what parts of a dict are intended to be branches and which are intended to be leaves. For simple cases, branch marking can be ignored: [example { ::oo::class create ::foo { } ::foo clay set property/ color blue ::foo clay set property/ shape round set A [::foo new] $A clay get property/ {color blue shape round} $A clay set property/ shape square $A clay get property/ {color blue shape square} }] [para] But when you start storing blocks of text, guessing what field is a dict and what isn’t gets messy: [example { ::foo clay set description {A generic thing of designated color and shape} $A clay get description {A generic thing of designated color and shape} Without a convention for discerning branches for leaves what should have been a value can be accidentally parsed as a dictionary, and merged with all of the other values that were never intended to be merge. Here is an example of it all going wrong: ::oo::class create ::foo { } # Add description as a leaf ::foo clay set description \ {A generic thing of designated color and shape} # Add description as a branch ::foo clay set description/ \ {A generic thing of designated color and shape} ::oo::class create ::bar { superclass foo } # Add description as a leaf ::bar clay set description \ {A drinking establishment of designated color and shape and size} # Add description as a branch ::bar clay set description/ \ {A drinking establishment of designated color and shape and size} set B [::bar new] # As a leaf we get the value verbatim from he nearest ancestor $B clay get description {A drinking establishment of designated color and shape and size} # As a branch we get a recursive merge $B clay get description/ {A drinking establishment of designated color and size thing of} }] [subsection {Clay Dialect}] Clay is built using the oo::dialect module from Tcllib. oo::dialect allows you to either add keywords directly to clay, or to create your own metaclass and keyword set using Clay as a foundation. For details on the keywords and what they do, consult the functions in the ::clay::define namespace. [subsection {Method Delegation}] Method Delegation It is sometimes useful to have an external object that can be invoked as if it were a method of the object. Clay provides a delegate ensemble method to perform that delegation, as well as introspect which methods are delegated in that manner. All delegated methods are marked with html-like tag markings (< >) around them. [example { ::clay::define counter { Variable counter 0 method incr {{howmuch 1}} { my variable counter incr counter $howmuch } method value {} { my variable counter return $counter } method reset {} { my variable counter set counter 0 } } ::clay::define example { variable buffer constructor {} { # Build a counter object set obj [namespace current]::counter ::counter create $obj # Delegate the counter my delegate <counter> $obj } method line {text} { my <counter> incr append buffer $text } } set A [example new] $A line {Who’s line is it anyway?} $A <counter> value 1 }] |
Added modules/clay/build/metaclass.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 | #------------------------------------------------------------------------- # TITLE: # clay.tcl # # PROJECT: # clay: TclOO Helper Library # # DESCRIPTION: # clay(n): Implementation File # #------------------------------------------------------------------------- ::clay::dialect::create ::clay proc ::clay::dynamic_methods class { foreach command [info commands [namespace current]::dynamic_methods_*] { $command $class } } proc ::clay::dynamic_methods_class {thisclass} { set methods {} set mdata [$thisclass clay find class_typemethod] foreach {method info} $mdata { if {$method eq {.}} continue set method [string trimright $method :/-] if {$method in $methods} continue lappend methods $method set arglist [dict getnull $info arglist] set body [dict getnull $info body] ::oo::objdefine $thisclass method $method $arglist $body } } ### # New OO Keywords for clay ### proc ::clay::define::Array {name {values {}}} { set class [current_class] set name [string trim $name :/] $class clay branch array $name dict for {var val} $values { $class clay set array/ $name $var $val } } ### # An annotation that objects of this class interact with delegated # methods. The annotation is intended to be a dictionary, and the # only reserved key is [emph {description}], a human readable description. ### proc ::clay::define::Delegate {name info} { set class [current_class] foreach {field value} $info { $class clay set component/ [string trim $name :/]/ $field $value } } ### # topic: 2cfc44a49f067124fda228458f77f177 # title: Specify the constructor for a class ### proc ::clay::define::constructor {arglist rawbody} { set body { my variable DestroyEvent set DestroyEvent 0 ::clay::object_create [self] [info object class [self]] # Initialize public variables and options my InitializePublic } append body $rawbody set class [current_class] ::oo::define $class constructor $arglist $body } ### # Specify the a method for the class object itself, instead of for objects of the class ### proc ::clay::define::Class_Method {name arglist body} { set class [current_class] $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body] } ### # And alias to the new Class_Method keyword ### proc ::clay::define::class_method {name arglist body} { set class [current_class] $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body] } proc ::clay::define::clay {args} { set class [current_class] if {[lindex $args 0] in "cget set branch"} { $class clay {*}$args } else { $class clay set {*}$args } } ### # topic: 4cb3696bf06d1e372107795de7fe1545 # title: Specify the destructor for a class ### proc ::clay::define::destructor rawbody { set body { # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 ::clay::object_destroy $self } append body $rawbody ::oo::define [current_class] destructor $body } proc ::clay::define::Dict {name {values {}}} { set class [current_class] set name [string trim $name :/] $class clay branch dict $name foreach {var val} $values { $class clay set dict/ $name/ $var $val } } ### # Define an option for the class ### proc ::clay::define::Option {name args} { set class [current_class] set dictargs {default {}} foreach {var val} [::clay::args_to_dict {*}$args] { dict set dictargs [string trim $var -:/] $val } set name [string trimleft $name -] ### # Option Class handling ### set optclass [dict getnull $dictargs class] if {$optclass ne {}} { foreach {f v} [$class clay find option_class $optclass] { if {![dict exists $dictargs $f]} { dict set dictargs $f $v } } if {$optclass eq "variable"} { variable $name [dict getnull $dictargs default] } } foreach {f v} $dictargs { $class clay set option $name $f $v } } proc ::clay::define::Method {name argstyle argspec body} { set class [current_class] set result {} switch $argstyle { dictargs { append result "::dictargs::parse \{$argspec\} \$args" \; } } append result $body oo::define $class method $name [list [list args [list dictargs $argspec]]] $result } ### # Define a class of options # All field / value pairs will be be inherited by an option that # specify [emph name] as it class field. ### proc ::clay::define::Option_Class {name args} { set class [current_class] set dictargs {default {}} set name [string trimleft $name -:] foreach {f v} [::clay::args_to_dict {*}$args] { $class clay set option_class $name [string trim $f -/:] $v } } ### # 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 ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } proc ::clay::object_create {objname {class {}}} { #if {$::clay::trace>0} { # puts [list $objname CREATE] #} } proc ::clay::object_rename {object newname} { if {$::clay::trace>0} { puts [list $object RENAME -> $newname] } } proc ::clay::object_destroy objname { if {$::clay::trace>0} { puts [list $objname DESTROY] } #::cron::object_destroy $objname } |
Added modules/clay/build/object.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 | # clay::object # # This class is inherited by all classes that have options. # ::oo::define ::clay::object { ### # description: # The [method clay] method allows an object access # to a combination of its own clay data as # well as to that of its class # ensemble: # ancestors { # argspec {} # description {Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.} # } # cget { # argspec {field {mandatory 1 positional 1}} # description { # Pull a value from either the object's clay structure or one of its constituent classes that matches the field name. # The order of search us: # [para] 1. The as a value in local dict variable config # [para] 2. The as a value in local dict variable clay # [para] 3. As a leaf in any ancestor as a root of the clay tree # [para] 4. As a leaf in any ancestor as [const const] [emph field] # [para] 5. As a leaf in any ancestor as [const option] [emph field] [const default] # } # } # delegate { # argspec {stub {mandatory 0 positional 1} object {mandatory 0 positional 1}} # description { # Introspect or control method delegation. With no arguments, the method will return a # key/value list of stubs and objects. With just the [arg stub] argument, the method will # return the object (if any) attached to the stub. With a [arg stub] and an [arg object] # this command will forward all calls to the method [arg stub] to the [arg object]. # } # } # dump { argspec {} description {Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in.}} # ensemble_map {argspec {} description {Return a dictionary describing the method ensembles to be assembled for this object}} # eval {argspec {script {mandatory 1 positional 1}} description {Evaluated a script in the namespace of this object}} # evolve {argspec {} description {Trigger the [method InitializePublic] private method}} # exists {argspec {path {mandatory 1 positional 1 repeating 1}} description {Returns 1 if [emph path] exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found.}} # flush {argspec {} description {Wipe any caches built by the clay implementation}} # forward {argspec {method {positional 1 mandatory 1} object {positional 1 mandatory 1}} description {A convenience wrapper for # [example {oo::objdefine [self] forward {*}$args}] # } # } # get {argspec {path {mandatory 1 positional 1 repeating 1}} # description {Pull a chunk of data from the clay system. If the last element of [emph path] is a branch (ends in a slash /), # returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. # If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching # leaf and return the first value found. # If no value is found, returns an empty string. # } # } # leaf {argspec {path {mandatory 1 positional 1 repeating 1}} description {A modified get which is tailored to pull only leaf elements}} # merge {argspec {dict {mandatory 1 positional 1 repeating 1}} description {Recursively merge the dictionaries given into the object's local clay storage.}} # mixin {argspec {class {mandatory 1 positional 1 repeating 1}} description { # Perform [lb]oo::objdefine [lb]self[rb] mixin[rb] on this object, with a few additional rules: # Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.) # For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.) # Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.) # }} # mixinmap { # argspec {stub {mandatory 0 positional 1} classes {mandatory 0 positional 1}} # description {With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given, # returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given # classes and invoke clay mixin on the new matrix of mixed in classes. # } # } # provenance {argspec {path {mandatory 1 positional 1 repeating 1}} description {Return either [const self] if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element.}} # replace {argspec {dictionary {mandatory 1 positional 1}} description {Replace the contents of the internal clay storage with the dictionary given.}} # source {argspec {filename {mandatory 1 positional 1}} description {Source the given filename within the object's namespace}} # set {argspec {path {mandatory 1 positional 1 repeating 1} value {mandatory 1 postional 1}} description {Merge the conents of [const value] with the object's clay storage at [const path].}} ### method clay {submethod args} { my variable clay claycache clayorder config option_canonical if {![info exists clay]} {set clay {}} if {![info exists claycache]} {set claycache {}} if {![info exists config]} {set config {}} if {![info exists clayorder] || [llength $clayorder]==0} { set clayorder {} if {[dict exists $clay cascade]} { dict for {f v} [dict get $clay cascade] { if {$f eq "."} continue if {[info commands $v] ne {}} { lappend clayorder $v } } } lappend clayorder {*}[::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] } switch $submethod { ancestors { return $clayorder } branch { set path [::clay::tree::storage $args] if {![dict exists $clay {*}$path .]} { dict set clay {*}$path . {} } } cget { # Leaf searches return one data field at a time # Search in our local dict if {[llength $args]==1} { set field [string trim [lindex $args 0] -:/] if {[info exists option_canonical($field)]} { set field $option_canonical($field) } if {[dict exists $config $field]} { return [dict get $config $field] } } set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path]} { if {[dict exists $claycache {*}$path .]} { return [dict remove [dict get $claycache {*}$path] .] } else { return [dict get $claycache {*}$path] } } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } if {[$class clay exists const {*}$path]} { set value [$class clay get const {*}$path] dict set claycache {*}$path $value return $value } if {[$class clay exists option {*}$path default]} { set value [$class clay get option {*}$path default] dict set claycache {*}$path $value return $value } } return {} } delegate { if {![dict exists $clay .delegate <class>]} { dict set clay .delegate <class> [info object class [self]] } if {[llength $args]==0} { return [dict get $clay .delegate] } if {[llength $args]==1} { set stub <[string trim [lindex $args 0] <>]> if {![dict exists $clay .delegate $stub]} { return {} } return [dict get $clay .delegate $stub] } if {([llength $args] % 2)} { error "Usage: delegate OR delegate stub OR delegate stub OBJECT ?stub OBJECT? ..." } foreach {stub object} $args { set stub <[string trim $stub <>]> dict set clay .delegate $stub $object oo::objdefine [self] forward ${stub} $object oo::objdefine [self] export ${stub} } } dump { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } ensemble_map { set ensemble [lindex $args 0] my variable claycache set mensemble [string trim $ensemble :/] if {[dict exists $claycache method_ensemble $mensemble]} { return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]] } set emap [my clay dget method_ensemble $mensemble] dict set claycache method_ensemble $mensemble $emap return [clay::tree::sanitize $emap] } eval { set script [lindex $args 0] set buffer {} set thisline {} foreach line [split $script \n] { append thisline $line if {![info complete $thisline]} { append thisline \n continue } set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} continue if {[string length $thisline]==0} continue if {[lindex $thisline 0] eq "my"} { # Line already calls out "my", accept verbatim append buffer $thisline \n } elseif {[string range $thisline 0 2] eq "::"} { # Fully qualified commands accepted verbatim append buffer $thisline \n } elseif { append buffer "my $thisline" \n } set thisline {} } eval $buffer } evolve - initialize { my InitializePublic } exists { # Leaf searches return one data field at a time # Search in our local dict set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return 1 } # Search in our local cache if {[dict exists $claycache {*}$path]} { return 2 } set count 2 # Search in the in our list of classes for an answer foreach class $clayorder { incr count if {[$class clay exists {*}$path]} { return $count } } return 0 } flush { set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] } forward { oo::objdefine [self] forward {*}$args } dget { set path [::clay::tree::storage $args] if {[llength $path]==0} { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [dict get $claycache {*}$path] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result [dict getnull $clay {*}$path] foreach class $clayorder { if {![$class clay exists {*}$path .]} continue ::clay::tree::dictmerge result [$class clay dget {*}$path] } #if {[dict exists $clay {*}$path .]} { # ::clay::tree::dictmerge result #} dict set claycache {*}$path $result return $result } getnull - get { set path [::clay::tree::storage $args] if {[llength $path]==0} { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return [::clay::tree::sanitize $result] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [::clay::tree::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result [dict getnull $clay {*}$path] #foreach class [lreverse $clayorder] { # if {![$class clay exists {*}$path .]} continue # ::clay::tree::dictmerge result [$class clay dget {*}$path] #} foreach class $clayorder { if {![$class clay exists {*}$path .]} continue ::clay::tree::dictmerge result [$class clay dget {*}$path] } #if {[dict exists $clay {*}$path .]} { # ::clay::tree::dictmerge result [dict get $clay {*}$path] #} dict set claycache {*}$path $result return [clay::tree::sanitize $result] } leaf { # Leaf searches return one data field at a time # Search in our local dict set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path .]} { return [clay::tree::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [clay::tree::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } } } merge { foreach arg $args { ::clay::tree::dictmerge clay {*}$arg } } mixin { ### # Mix in the class ### set prior [info object mixins [self]] set newmixin {} foreach item $args { lappend newmixin ::[string trimleft $item :] } set newmap $args foreach class $prior { if {$class ni $newmixin} { set script [$class clay search mixin/ unmap-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]" } } } } ::oo::objdefine [self] mixin {*}$args ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### my InitializePublic foreach class $newmixin { if {$class ni $prior} { set script [$class clay search mixin/ map-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]" } } } } foreach class $newmixin { set script [$class clay search mixin/ react-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" } break } } } mixinmap { my variable clay if {![dict exists $clay .mixin]} { dict set clay .mixin {} } if {[llength $args]==0} { return [dict get $clay .mixin] } elseif {[llength $args]==1} { return [dict getnull $clay .mixin [lindex $args 0]] } else { dict for {slot classes} $args { dict set clay .mixin $slot $classes } set classlist {} dict for {item class} [dict get $clay .mixin] { if {$class ne {}} { lappend classlist $class } } my clay mixin {*}[lreverse $classlist] } } provenance { if {[dict exists $clay {*}$args]} { return self } foreach class $clayorder { if {[$class clay exists {*}$args]} { return $class } } return {} } replace { set clay [lindex $args 0] } source { source [lindex $args 0] } set { #puts [list [self] clay SET {*}$args] set claycache {} ::clay::tree::dictset clay {*}$args } default { dict $submethod clay {*}$args } } } ### # Instantiate variables. Called on object creation and during clay mixin. ### method InitializePublic {} { my variable clayorder clay claycache config option_canonical set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] if {![info exists clay]} { set clay {} } if {![info exists config]} { set config {} } dict for {var value} [my clay get variable] { if { $var in {. clay} } continue set var [string trim $var :/] my variable $var if {![info exists $var]} { if {$::clay::trace>2} {puts [list initialize variable $var $value]} set $var $value } } dict for {var value} [my clay get dict/] { if { $var in {. clay} } continue set var [string trim $var :/] my variable $var if {![info exists $var]} { set $var {} } foreach {f v} $value { if {$f eq "."} continue if {![dict exists ${var} $f]} { if {$::clay::trace>2} {puts [list initialize dict $var $f $v]} dict set ${var} $f $v } } } foreach {var value} [my clay get array/] { if { $var in {. clay} } continue set var [string trim $var :/] if { $var eq {clay} } continue my variable $var if {![info exists $var]} { array set $var {} } foreach {f v} $value { if {![array exists ${var}($f)]} { if {$f eq "."} continue if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]} set ${var}($f) $v } } } foreach {field info} [my clay get option/] { if { $field in {. clay} } continue set field [string trim $field -/:] foreach alias [dict getnull $info aliases] { set option_canonical($alias) $field } if {[dict exists $config $field]} continue set getcmd [dict getnull $info default-command] if {$getcmd ne {}} { set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]] } else { set value [dict getnull $info default] } dict set config $field $value set setcmd [dict getnull $info set-command] if {$setcmd ne {}} { {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd] } } my variable clayorder clay claycache if {[info exists clay]} { set emap [dict getnull $clay method_ensemble] } else { set emap {} } foreach class [lreverse $clayorder] { ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### dict for {mensemble einfo} [$class clay get method_ensemble] { if {$mensemble eq {.}} continue set ensemble [string trim $mensemble :/] if {$::clay::trace>2} {puts [list Defining $ensemble from $class]} dict for {method info} $einfo { if {$method eq {.}} continue if {![dict is_dict $info]} { puts [list WARNING: class: $class method: $method not dict: $info] continue } dict set info source $class if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]} dict set emap $ensemble $method $info } } } foreach {ensemble einfo} $emap { #if {[dict exists $einfo _body]} continue set body [::clay::ensemble_methodbody $ensemble $einfo] if {$::clay::trace>2} { set rawbody $body set body {puts [list [self] <object> [self method]]} append body \n $rawbody } oo::objdefine [self] method $ensemble {{method default} args} $body } } } ::clay::object clay branch array ::clay::object clay branch mixin ::clay::object clay branch option ::clay::object clay branch dict clay ::clay::object clay set variable DestroyEvent 0 |
Added modules/clay/build/procs.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 | namespace eval ::clay {} set ::clay::trace 0 ### # Because many features in this package may be added as # commands to future tcl cores, or be provided in binary # form by packages, I need a declaritive way of saying # [emph {Create this command if there isn't one already}]. # The [emph ninja] argument is a script to execute if the # command is created by this mechanism. ### proc ::clay::PROC {name arglist body {ninja {}}} { if {[info commands $name] ne {}} return proc $name $arglist $body eval $ninja } if {[info commands ::PROC] eq {}} { namespace eval ::clay { namespace export PROC } namespace eval :: { namespace import ::clay::PROC } } proc ::clay::_ancestors {resultvar class} { upvar 1 $resultvar result if {$class in $result} { return } lappend result $class foreach aclass [::info class superclasses $class] { _ancestors result $aclass } } proc ::clay::ancestors {args} { set result {} set queue {} set metaclasses {} foreach class $args { set ancestors($class) {} _ancestors ancestors($class) $class } foreach class [lreverse $args] { foreach aclass $ancestors($class) { if {$aclass in $result} continue set skip 0 foreach bclass $args { if {$class eq $bclass} continue if {$aclass in $ancestors($bclass)} { set skip 1 break } } if {$skip} continue lappend result $aclass } } foreach class [lreverse $args] { foreach aclass $ancestors($class) { if {$aclass in $result} continue lappend result $aclass } } ### # Screen out classes that do not participate in clay # interactions ### set output {} foreach {item} $result { if {[catch {$item clay noop} err]} { continue } lappend output $item } return $output } proc ::clay::args_to_dict args { if {[llength $args]==1} { return [lindex $args 0] } return $args } proc ::clay::args_to_options args { set result {} foreach {var val} [args_to_dict {*}$args] { lappend result [string trim $var -:] $val } return $result } ### # topic: 4969d897a83d91a230a17f166dbcaede ### proc ::clay::dynamic_arguments {ensemble method arglist args} { set idx 0 set len [llength $args] if {$len > [llength $arglist]} { ### # Catch if the user supplies too many arguments ### set dargs 0 if {[lindex $arglist end] ni {args dictargs}} { return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]" } } foreach argdef $arglist { if {$argdef eq "args"} { ### # Perform args processing in the style of tcl ### uplevel 1 [list set args [lrange $args $idx end]] break } if {$argdef eq "dictargs"} { ### # Perform args processing in the style of tcl ### uplevel 1 [list set args [lrange $args $idx end]] ### # Perform args processing in the style of clay ### set dictargs [::clay::args_to_options {*}[lrange $args $idx end]] uplevel 1 [list set dictargs $dictargs] break } if {$idx > $len} { ### # Catch if the user supplies too few arguments ### if {[llength $argdef]==1} { return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]" } else { uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]] } } else { uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]] } incr idx } } ### # topic: 53ab28ac5c6ee601fe1fe07b073be88e ### proc ::clay::dynamic_wrongargs_message {arglist} { set result "" set dargs 0 foreach argdef $arglist { if {$argdef in {args dictargs}} { set dargs 1 break } if {[llength $argdef]==1} { append result " $argdef" } else { append result " ?[lindex $argdef 0]?" } } if { $dargs } { append result " ?option value?..." } return $result } proc ::clay::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {::dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } proc ::clay::is_null value { return [expr {$value in {{} NULL}}] } proc ::clay::leaf args { set marker [string index [lindex $args end] end] set result [path {*}${args}] if {$marker eq "/"} { return $result } return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]] } proc ::clay::K {a b} {set a} if {[info commands ::K] eq {}} { namespace eval ::clay { namespace export K } namespace eval :: { namespace import ::clay::K } } ### # Perform a noop. Useful in prototyping for commenting out blocks # of code without actually having to comment them out. It also makes # a handy default for method delegation if a delegate has not been # assigned yet. proc ::clay::noop args {} if {[info commands ::noop] eq {}} { namespace eval ::clay { namespace export noop } namespace eval :: { namespace import ::clay::noop } } proc ::clay::path args { set result {} foreach item $args { set item [string trim $item :./] foreach subitem [split $item /] { lappend result [string trim ${subitem}]/ } } return $result } ### # Append a line of text to a variable. Optionally apply a string mapping. # arglist: # map {mandatory 0 positional 1} # text {mandatory 1 positional 1} ### proc ::clay::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { append buffer [lindex $args 0] \n } 2 { append buffer [string map {*}$args] \n } default { error "usage: putb buffername ?map? string" } } } if {[info command ::putb] eq {}} { namespace eval ::clay { namespace export putb } namespace eval :: { namespace import ::clay::putb } } proc ::clay::script_path {} { set path [file dirname [file join [pwd] [info script]]] return $path } proc ::clay::NSNormalize qualname { if {![string match ::* $qualname]} { set qualname ::clay::classes::$qualname } regsub -all {::+} $qualname "::" } proc ::clay::uuid_generate args { return [uuid generate] } namespace eval ::clay { variable option_class {} variable core_classes {::oo::class ::oo::object} } |
Added modules/clay/build/test.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 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 | ### # Test script build functions ### set result {} putb result {# clay.test - Copyright (c) 2018 Sean Woods # ------------------------------------------------------------------------- set MODDIR [file dirname [file dirname [file join [pwd] [info script]]]] if {[file exists [file join $MODDIR devtools testutilities.tcl]]} { # Running inside tcllib set TCLLIBMOD $MODDIR } else { set TCLLIBMOD [file join $MODDIR .. .. tcllib modules] } source [file join $TCLLIBMOD devtools testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2 testsNeed TclOO 1 support {} testing { useLocal clay.tcl clay } } putb result { set ::clay::trace 0 } ### # UUID test ### putb result { # ------------------------------------------------------------------------- # Handle multiple implementation testing # array set preserve [array get ::clay::uuid::accel] proc implementations {} { variable ::clay::uuid::accel foreach {a v} [array get accel] {if {$v} {lappend r $a}} lappend r tcl; set r } proc select_implementation {impl} { variable ::clay::uuid::accel foreach e [array names accel] { set accel($e) 0 } if {[string compare "tcl" $impl] != 0} { set accel($impl) 1 } } proc reset_implementation {} { variable ::clay::uuid::accel array set accel [array get ::preserve] } # ------------------------------------------------------------------------- # Setup any constraints # # ------------------------------------------------------------------------- # Now the package specific tests.... # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- foreach impl [implementations] { select_implementation $impl test uuid-1.0-$impl "uuid requires args" { list [catch {clay::uuid} msg] } {1} test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" { list [catch {string length [clay::uuid generate]} msg] $msg } {0 36} test uuid-1.2-$impl "uuid comparison of uuid with self should be true" { list [catch { set a [clay::uuid generate] clay::uuid equal $a $a } msg] $msg } {0 1} test uuid-1.3-$impl "uuid comparison of two different\ uuids should be false" { list [catch { set a [clay::uuid generate] set b [clay::uuid generate] clay::uuid equal $a $b } msg] $msg } {0 0} reset_implementation } } putb result { # Modification History: ### # Modification 2018-10-30 # Fixed an error in our ancestry mapping and developed tests to # ensure we are actually following in the order TclOO follows methods ### # Modification 2018-10-21 # The clay metaclass no longer exports the clay method # to oo::class and oo::object, and clay::ancestors no # longer returns any class that lacks the clay method ### # Modification 2018-10-10 # clay::ancestors now rigged to descend into all classes depth-first # and then place metaclasses at the end of the search ### # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- # Test Helpers ### proc dict_compare {a b} { set result {} set A {} dict for {f v} $a { set f [string trim $f :/] if {$f eq {.}} continue dict set A $f $v } set B {} dict for {f v} $b { set f [string trim $f :/] if {$f eq {.}} continue dict set B $f $v } dict for {f v} $A { if {[dict exists $B $f]} { if {[dict get $B $f] ne $v} { lappend result [list B $f [dict get $B $f] [list != $v]] } } else { lappend result [list B $f $v missing] } } dict for {f v} $B { if {![dict exists $A $f]} { lappend result [list A $f $v missing] } } return $result } test dict-compare-001 {Test our testing method} { dict_compare {} {} } {} test dict-compare-002 {Test our testing method} { dict_compare {a 1} {} } {{B a 1 missing}} test dict-compare-003 {Test our testing method} { dict_compare {a 1 b 2} {a 1 b 2} } {} test dict-compare-003.a {Test our testing method} { dict_compare {a 1 b 2} {b 2 a 1 } } {} test dict-compare-003.b {Test our testing method} { dict_compare {b 2 a 1} {a 1 b 2} } {} test dict-compare-004 {Test our testing method} { dict_compare {a: 1 b: 2} {a 1 b 2} } {} test dict-compare-005 {Test our testing method} { dict_compare {a 1 b 3} {a 1 b 2} } {{B b 2 {!= 3}}} } ### # Tests for clay::tree ### putb result { ### # Test canonical mapping ### } set test 0 foreach {pattern canonical storage} { {foo bar baz} {foo/ bar/ baz} {foo bar baz} {foo bar baz/} {foo/ bar/ baz/} {foo bar baz} {foo bar .} {foo/ bar} {foo bar .} {foo/ bar/ .} {foo/ bar} {foo bar .} {foo . bar . baz .} {foo/ bar/ baz} {foo . bar . baz .} {foo bar baz bat:} {foo/ bar/ baz/ bat:} {foo bar baz bat:} {foo:} {foo:} {foo:} {foo/bar/baz/bat:} {foo/ bar/ baz/ bat:} {foo bar baz bat:} } { dict set map %pattern% $pattern dict set map %canonical% $canonical dict set map %storage% $storage incr test dict set map %test% [format "test-storage-%04d" $test] putb result $map { test {%test%} {Test ::clay::tree::storage with %pattern%} { clay::tree::storage {%pattern%} } {%storage%} } } putb result { dict set r foo/ bar/ baz 1 dict set s foo/ bar/ baz 0 set t [clay::tree::merge $r $s] test rmerge-0001 {Test that the root is marked as a branch} { dict get $t foo bar baz } 0 set r [dict create] clay::tree::dictmerge r { foo/ { bar/ { baz 1 bing: 2 bang { bim 3 boom 4 } womp: {a 1 b 2} } } } test dictmerge-0001 {Test that the root is marked as a branch} { dict exists $r . } 1 test dictmerge-0002 {Test that branch foo is marked correctly} { dict exists $r foo . } 1 test dictmerge-0003 {Test that branch bar is marked correctly} { dict exists $r foo bar . } 1 test dictmerge-0004 {Test that leaf foo/bar/bang is not marked as branch despite being a dict} { dict exists $r foo bar bang . } 0 test dictmerge-0004 {Test that leaf foo/bar/bang/bim exists} { dict exists $r foo bar bang bim } 1 test dictmerge-0005 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 1 ### # Replace bang with bang/ ### clay::tree::dictmerge r { foo/ { bar/ { bang/ { whoop 1 } } } } test dictmerge-0006 {Test that leaf foo/bar/bang/bim ceases to exist} { dict exists $r foo bar bang bim } 0 test dictmerge-0007 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 0 test dictmerge-0008 {Test that leaf foo/bar/bang is now a branch} { dict exists $r foo bar bang . } 1 test branch-0001 {Test that foo/ is a branch} { clay::tree::is_branch $r foo/ } 1 test branch-0002 {Test that foo is a branch} { clay::tree::is_branch $r foo } 1 test branch-0003 {Test that foo/bar/ is a branch} { clay::tree::is_branch $r {foo/ bar/} } 1 test branch-0004 {Test that foo bar is not branch} { clay::tree::is_branch $r {foo bar} } 1 test branch-0004 {Test that foo/ bar is not branch} { clay::tree::is_branch $r {foo/ bar} } 0 } set test 0 foreach {path isbranch} { foo 1 {foo bar} 1 {foo bar baz} 0 {foo bar bing} 0 {foo bar bang} 1 {foo bar bang whoop} 0 } { set mpath [lrange $path 0 end-1] set item [lindex $path end] set tests [list {} {} $isbranch {} : 0 {} / 1 . {} 0] dict set map %mpath% $mpath dict set map %item% $item foreach {head tail isbranch} $tests { dict set map %head% $head dict set map %tail% $tail dict set map %isbranch% $isbranch dict set map %test% [format "test-branch-%04d" [incr test]] putb result $map { test {%test%} {Test that %mpath% %head%%item%%tail% is_branch = %isbranch%} { clay::tree::is_branch $r {%mpath% %head%%item%%tail%} } %isbranch% } } } putb result { # ------------------------------------------------------------------------- # dictmerge Testing - oometa unset -nocomplain foo clay::tree::dictmerge foo { option/ { color/ { label Color default green } } } clay::tree::dictmerge foo { option/ { color/ { default purple } } } test oometa-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color default } purple test oometa-0002 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color label } Color unset -nocomplain foo set foo {. {}} ::clay::tree::dictmerge foo {. {} color {. {} default green label Color}} ::clay::tree::dictmerge foo {. {} color {. {} default purple}} test oometa-0003 {Recursive merge problem from oometa/clay find} { dict get $foo color default } purple test oometa-0004 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color unset -nocomplain foo set foo {. {}} ::clay::tree::dictmerge foo {. {} color {. {} default purple}} ::clay::tree::dictmerge foo {. {} color {. {} default green label Color}} test oometa-0005 {Recursive merge problem from oometa/clay find} { dict get $foo color default } green test oometa-0006 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color test oometa-0008 {Un-Sanitized output} { set foo } {. {} color {. {} default green label Color}} test oometa-0009 {Sanitize} { clay::tree::sanitize $foo } {color {default green label Color}} } putb result { # ------------------------------------------------------------------------- # dictmerge Testing - clay unset -nocomplain foo test clay-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { ::clay::tree::dictmerge foo set foo } {. {}} unset -nocomplain foo ::clay::tree::dictset foo bar/ baz/ bell bang test clay-0002 {For new entries dictmerge is essentially a set} { dict get $foo bar baz bell } {bang} ::clay::tree::dictset foo bar/ baz/ boom/ bang test clay-0003 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz bell } {bang} test clay-0004 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz boom } {bang} ::clay::tree::dictset foo bar/ baz/ bop {color green flavor strawberry} test clay-0005 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color green flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bop {color yellow} test clay-0006 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color yellow} ::clay::tree::dictset foo bar/ baz/ bang/ {color green flavor strawberry} test clay-0007a {Branches are merged} { dict get $foo bar baz bang } {. {} color green flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ color yellow test clay-0007b {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ {color blue} test clay-0007c {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ shape: {Sort of round} test clay-0007d {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo bar/ baz/ bang/ color yellow test clay-0007e {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo bar/ baz/ bang/ {color blue} test clay-0007f {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo dict my_var 10 ::clay::tree::dictset foo dict my_other_var 9 test clay-0007g {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9} ::clay::tree::dictset foo dict/ my_other_other_var 8 test clay-0007h {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9 my_other_other_var 8} ::clay::tree::dictmerge foo {option/ {color {type color} flavor {sense taste}}} ::clay::tree::dictmerge foo {option/ {format {default ascii}}} test clay-0008 {Whole dicts are merged} { dict get $foo option color } {type color} test clay-0009 {Whole dicts are merged} { dict get $foo option flavor } {sense taste} test clay-0010 {Whole dicts are merged} { dict get $foo option format } {default ascii} ### # Tests for the httpd module ### test clay-0010 {Test that leaves are merged properly} set bar {} ::clay::tree::dictmerge bar { proxy/ {port 10101 host myhost.localhost} } ::clay::tree::dictmerge bar { mimetxt {Host: localhost Content_Type: text/plain Content-Length: 15 } http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}} mixin {reply ::test::content.echo} prefix /echo proxy_port 10010 proxy/ {host localhost} } test clay-0011 {Whole dicts are merged} { dict get $bar proxy_port } {10010} test clay-0012 {Whole dicts are merged} { dict get $bar http CONTENT_LENGTH } 15 test clay-0013 {Whole dicts are merged} { dict get $bar proxy host } localhost test clay-0014 {Whole dicts are merged} { dict get $bar proxy port } 10101 } putb result { ### # Dialect Testing ### ::clay::dialect::create ::alpha proc ::alpha::define::is_alpha {} { dict set ::testinfo([current_class]) is_alpha 1 } ::alpha::define ::alpha::object { is_alpha } ::clay::dialect::create ::bravo ::alpha proc ::bravo::define::is_bravo {} { dict set ::testinfo([current_class]) is_bravo 1 } ::bravo::define ::bravo::object { is_bravo } ::clay::dialect::create ::charlie ::bravo proc ::charlie::define::is_charlie {} { dict set ::testinfo([current_class]) is_charlie 1 } ::charlie::define ::charlie::object { is_charlie } ::clay::dialect::create ::delta ::charlie proc ::delta::define::is_delta {} { dict set ::testinfo([current_class]) is_delta 1 } ::delta::define ::delta::object { is_delta } ::delta::class create adam { is_alpha is_bravo is_charlie is_delta } test oodialect-keyword-001 {Testing keyword application} { set ::testinfo(::adam) } {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1} test oodialect-keyword-002 {Testing keyword application} { set ::testinfo(::alpha::object) } {is_alpha 1} test oodialect-keyword-003 {Testing keyword application} { set ::testinfo(::bravo::object) } {is_bravo 1} test oodialect-keyword-004 {Testing keyword application} { set ::testinfo(::charlie::object) } {is_charlie 1} test oodialect-keyword-005 {Testing keyword application} { set ::testinfo(::delta::object) } {is_delta 1} ### # Declare an object from a namespace ### namespace eval ::test1 { ::alpha::class create a { aliases A is_alpha } ::alpha::define b { aliases B BEE is_alpha } ::alpha::class create ::c { aliases C is_alpha } ::alpha::define ::d { aliases D is_alpha } } test oodialect-naming-001 {Testing keyword application} { set ::testinfo(::test1::a) } {is_alpha 1} test oodialect-naming-002 {Testing keyword application} { set ::testinfo(::test1::b) } {is_alpha 1} test oodialect-naming-003 {Testing keyword application} { set ::testinfo(::c) } {is_alpha 1} test oodialect-naming-004 {Testing keyword application} { set ::testinfo(::d) } {is_alpha 1} test oodialect-aliasing-001 {Testing keyword application} { namespace eval ::test1 { ::alpha::define e { superclass A } } } ::test1::e test oodialect-aliasing-002 {Testing keyword application} { namespace eval ::test1 { ::bravo::define f { superclass A } } } ::test1::f test oodialect-aliasing-003 {Testing aliase method on class} { ::test1::a aliases } {::test1::A} ### # Test modified 2018-10-21 ### test oodialect-ancestry-003 {Testing heritage} { ::clay::ancestors ::test1::f } {} ### # Test modified 2018-10-21 ### test oodialect-ancestry-004 {Testing heritage} { ::clay::ancestors ::alpha::object } {} ### # Test modified 2018-10-21 ### test oodialect-ancestry-005 {Testing heritage} { ::clay::ancestors ::delta::object } {} } putb result { # ------------------------------------------------------------------------- # clay submodule testing # ------------------------------------------------------------------------- } putb result { # Test canonical path building set path {const/ foo/ bar/ baz/} } set testnum 0 foreach {pattern} { {const foo bar baz} {const/ foo/ bar/ baz} {const/foo/bar/baz} {const/foo bar/baz} {const/foo/bar baz} {const foo/bar/baz} {const foo bar/baz} {const/foo bar baz} } { putb result [list %pattern% $pattern %testnum% [format %04d [incr testnum]]] { test oo-clay-path-%testnum% "Test path: %pattern%" { ::clay::path %pattern% } $path } } putb result {set path {const/ foo/ bar/ baz/ bing}} set testnum 0 foreach {pattern} { {const foo bar baz bing} {const/ foo/ bar/ baz/ bing} {const/foo/bar/baz/bing} {const/foo bar/baz/bing:} {const/foo/bar baz bing} {const/foo/bar baz bing:} {const foo/bar/baz/bing} {const foo bar/baz/bing} {const/foo bar baz bing} } { putb result [list %pattern% $pattern %testnum% [format %04d [incr testnum]]] { test oo-clay-leaf-%testnum% "Test leaf: %pattern%" { ::clay::leaf %pattern% } $path } } putb result {namespace eval ::foo {}} set class-a ::foo::classa set commands-a { clay set const color blue clay set const/flavor strawberry clay set {const/ sound} zoink clay set info/ { animal no building no subelement {pedantic yes} } } set claydict-a { const/ {color blue flavor strawberry sound zoink} info/ { animal no building no subelement {pedantic yes} } } putb result [list %class% ${class-a} %commands% ${commands-a}] { clay::define %class% { %commands% } } set testnum 0 foreach {top children} ${claydict-a} { foreach {child value} $children { set map {} dict set map %class% ${class-a} dict set map %top% $top dict set map %child% $child dict set map %value% $value dict set map %testnum% [format %04d [incr testnum]] putb result $map { test oo-class-clay-method-%testnum% "Test %class% %top% %child% exists" { %class% clay exists %top% %child% } 1 } dict set map %test% [format %04d [incr testnum]] putb result $map { test oo-class-clay-method-%testnum% "Test %class% %top% %child% value" { %class% clay get %top% %child% } {%value%} } } } set class-b ::foo::classb set claydict-b { const/ {color black flavor vanilla feeling dread} info/ {subelement {spoon yes}} } set commands-b {} foreach {top children} ${claydict-b} { foreach {child value} $children { putb commands-b " [list clay set $top $child $value]" } } putb result [list %class% ${class-b} %commands% ${commands-b}] { clay::define %class% { %commands% } } foreach {top children} ${claydict-b} { foreach {child value} $children { set map {} dict set map %class% ${class-b} dict set map %top% $top dict set map %child% $child dict set map %value% $value dict set map %testnum% [format %04d [incr testnum]] putb result $map { test oo-class-clay-method-%testnum% "Test %class% %top% %child% exists" { %class% clay exists %top% %child% } 1 } dict set map %test% [format %04d [incr testnum]] putb result $map { test oo-class-clay-method-%testnum% "Test %class% %top% %child% value" { %class% clay get %top% %child% } {%value%} } } } set commands-c {superclass ::foo::classb ::foo::classa} set class-c ::foo::class.ab putb result [list %class% ${class-c} %commands% ${commands-c}] { clay::define %class% { %commands% } } set commands-d {superclass ::foo::classa ::foo::classb} set class-d ::foo::class.ba putb result [list %class% ${class-d} %commands% ${commands-d}] { clay::define %class% { %commands% } } ### # Tests for objects ### putb result {# ------------------------------------------------------------------------- # OBJECT of ::foo::classa set OBJECTA [::foo::classa new] ### # Test object degation ### proc ::foo::fakeobject {a b} { return [expr {$a + $b}] } ::clay::object create TEST TEST clay delegate funct ::foo::fakeobject test oo-object-delegate-001 {Test object delegation} { ::TEST clay delegate } {<class> ::clay::object <funct> ::foo::fakeobject} test oo-object-delegate-002 {Test object delegation} { ::TEST clay delegate funct } {::foo::fakeobject} test oo-object-delegate-002a {Test object delegation} { ::TEST clay delegate <funct> } {::foo::fakeobject} test oo-object-delegate-003 {Test object delegation} { ::TEST <funct> 1 1 } {2} test oo-object-delegate-004 {Test object delegation} { ::TEST <funct> 10 -7 } {3} # Replace the function out from under proc ::foo::fakeobject {a b} { return [expr {$a * $b}] } test oo-object-delegate-005 {Test object delegation} { ::TEST <funct> 10 -7 } {-70} # Object with ::foo::classa mixed in set MIXINA [::oo::object new] oo::objdefine $MIXINA mixin ::foo::classa } set matrix ${claydict-a} set testnum 0 foreach {top children} $matrix { foreach {child value} $children { set map {} dict set map %object1% OBJECTA dict set map %object2% MIXINA dict set map %top% $top dict set map %child% $child dict set map %value% $value dict set map %testnum% [format %04d [incr testnum]] putb result $map { test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } } } putb result {# ------------------------------------------------------------------------- # OBJECT of ::foo::classb set OBJECTB [::foo::classb new] # Object with ::foo::classb mixed in set MIXINB [::oo::object new] oo::objdefine $MIXINB mixin ::foo::classb } set matrix ${claydict-b} #set testnum 0 foreach {top children} $matrix { foreach {child value} $children { set map {} dict set map %object1% OBJECTB dict set map %object2% MIXINB dict set map %top% $top dict set map %child% $child dict set map %value% $value dict set map %testnum% [format %04d [incr testnum]] putb result $map { test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } } } putb result {# ------------------------------------------------------------------------- # OBJECT descended from ::foo::classa ::foo::classb set OBJECTAB [::foo::class.ab new] # Object where classes were mixed in ::foo::classa ::foo::classb set MIXINAB [::oo::object new] # Test modified 2018-10-30, mixin order was wrong before oo::objdefine $MIXINAB mixin ::foo::classb ::foo::classa } set matrix ${claydict-b} foreach {top children} ${claydict-a} { foreach {child value} $children { if {![dict exists $matrix $top $child]} { dict set matrix $top $child $value } } } #set testnum 0 foreach {top children} $matrix { foreach {child value} $children { set map {} dict set map %object1% OBJECTAB dict set map %object2% MIXINAB dict set map %top% $top dict set map %child% $child dict set map %value% $value dict set map %testnum% [format %04d [incr testnum]] putb result $map { test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} { $%object2% clay get %top% %child% } {%value%} } } } putb result {# ------------------------------------------------------------------------- # OBJECT descended from ::foo::classb ::foo::classa set OBJECTBA [::foo::class.ba new] # Object where classes were mixed in ::foo::classb ::foo::classa set MIXINBA [::oo::object new] # Test modified 2018-10-30, mixin order was wrong before oo::objdefine $MIXINBA mixin ::foo::classa ::foo::classb } set matrix ${claydict-a} foreach {top children} ${claydict-b} { foreach {child value} $children { if {![dict exists $matrix $top $child]} { dict set matrix $top $child $value } } } #set testnum 0 foreach {top children} $matrix { foreach {child value} $children { set map {} dict set map %object1% OBJECTBA dict set map %object2% MIXINBA dict set map %top% $top dict set map %child% $child dict set map %value% $value dict set map %testnum% [format %04d [incr testnum]] putb result $map { test oo-object-clay-method-native-%testnum% {Test native object gets the property} { $%object1% clay get %top% %child% } {%value%} test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property} { $%object2% clay get %top% %child% } {%value%} } } } putb resut { ### # Test local setting if clay data in an object ### set OBJECT [::foo::classa new] test oo-object-clay-method-local-0001 {Test native object gets the property} { $OBJECT clay get const/ color } {blue} test oo-object-clay-method-local-0002 {Test that local settings override the inherited properties} { $OBJECT clay set const/ color black $OBJECT clay set const/ } {black} test oo-object-clay-method-local-0003 {Test native object gets an empty property} { $OBJECT clay get color } {} test oo-object-clay-method-local-0004 {Test that local settings override the empty property} { $OBJECT clay set color orange $OBJECT clay get color } {orange} } putb result { ### # put a do-nothing constructor on the books ### ::clay::define ::clay::object { constructor args {} } oo::objdefine ::clay::object method foo args { return bar } test clay-core-method-0001 {Test that adding methods to the core ::clay::object class works} { ::clay::object foo } {bar} namespace eval ::TEST {} ::clay::define ::TEST::myclass { clay color red clay flavor strawberry } ### # Test adding a clay property ### test clay-class-clay-0001 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclass clay get color } red test clay-class-clay-0002 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclass clay get flavor } strawberry ### # Test that objects of the class get the same properties ### set OBJ [::clay::object new {}] set OBJ2 [::TEST::myclass new {}] test clay-object-clay-a-0001 {Test that objects not thee class do not get properties} { $OBJ clay get color } {} test clay-object-clay-a-0002 {Test that objects not thee class do not get properties} { $OBJ clay get flavor } {} test clay-object-clay-a-0003 {Test that objects of the class get properties} { $OBJ2 clay get color } red test clay-object-clay-a-0004 {Test that objects of the class get properties} { $OBJ2 clay get flavor } strawberry ### # Test modified 2018-10-21 ### test clay-object-clay-a-0005 {Test the clay ancestors function} { $OBJ clay ancestors } {::clay::object} ### # Test modified 2018-10-21 ### test clay-object-clay-a-0006 {Test the clay ancestors function} { $OBJ2 clay ancestors } {::TEST::myclass ::clay::object} test clay-object-clay-a-0007 {Test the clay provenance function} { $OBJ2 clay provenance flavor } ::TEST::myclass ### # Test that object local setting override the class ### test clay-object-clay-a-0008 {Test that object local setting override the class} { $OBJ2 clay set color purple $OBJ2 clay get color } purple test clay-object-clay-a-0009 {Test that object local setting override the class} { $OBJ2 clay provenance color } self ::clay::define ::TEST::myclasse { superclass ::TEST::myclass clay color blue method do args { return "I did $args" } Ensemble which::color {} { return [my clay get color] } clay set method_ensemble which color aliases farbe } ### # Test clay information is passed town to subclasses ### test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclasse clay get color } blue test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} { ::TEST::myclasse clay get flavor } {} test clay-class-clay-0005 {Test that clay statements from the ancestors of this class are found with the FIND method} { ::TEST::myclasse clay find flavor } {strawberry} ### # Test that properties reach objects ### set OBJ3 [::TEST::myclasse new {}] test clay-object-clay-b-0001 {Test that objects of the class get properties} { $OBJ3 clay get color } blue test clay-object-clay-b-0002 {Test the clay provenance function} { $OBJ3 clay provenance color } ::TEST::myclasse test clay-object-clay-b-0003 {Test that objects of the class get properties} { $OBJ3 clay get flavor } strawberry test clay-object-clay-b-0004 {Test the clay provenance function} { $OBJ3 clay provenance flavor } ::TEST::myclass ### # Test modified 2018-10-21 ### test clay-object-clay-b-0005 {Test the clay provenance function} { $OBJ3 clay ancestors } {::TEST::myclasse ::TEST::myclass ::clay::object} ### # Test defining a standard method ### test clay-object-method-0001 {Test and standard method} { $OBJ3 do this really cool thing } {I did this really cool thing} test clay-object-method-0003 {Test an ensemble} { $OBJ3 which color } blue # Test setting properties test clay-object-method-0004 {Test an ensemble} { $OBJ3 clay set color black $OBJ3 which color } black # Test setting properties test clay-object-method-0004 {Test an ensemble alias} { $OBJ3 which farbe } black ### # Test that if you try to replace a global command you get an error ### test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body { ::clay::define open { method bar {} { return foo } } } -returnCodes {error} -result "::open does not refer to an object" ::clay::define fubar { method bar {} { return foo } } test clay-nspace-0002 {Test a non qualified class ends up in the current namespace} { info commands ::fubar } {::fubar} namespace eval ::cluster { ::clay::define fubar { method bar {} { return foo } } ::clay::define ::clay::pot { method bar {} { return foo } } } test clay-nspace-0003 {Test a non qualified class ends up in the current namespace} { info commands ::cluster::fubar } {::cluster::fubar} test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} { info commands ::clay::pot } {::clay::pot} #set ::clay::trace 3 ### # Mixin tests ### ### # Define a core class ### ::clay::define ::TEST::thing { method do args { return "I did $args" } } ::clay::define ::TEST::vegetable { clay color unknown clay flavor unknown Ensemble which::flavor {} { return [my clay get flavor] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::animal { clay color unknown clay sound unknown Ensemble which::sound {} { return [my clay get sound] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::species.cat { superclass ::TEST::animal clay sound meow } ::clay::define ::TEST::coloring.calico { clay color calico } ::clay::define ::TEST::condition.dark { Ensemble which::color {} { return grey } } ::clay::define ::TEST::mood.happy { Ensemble which::sound {} { return purr } } test clay-object-0001 {Test than an object is created when clay::define is invoked} { info commands ::TEST::mood.happy } ::TEST::mood.happy set OBJ [::TEST::thing new] test clay-mixin-a-0001 {Test that prior to a mixin an ensemble doesn't exist} -body { $OBJ which color } -returnCodes error -result {unknown method "which": must be clay, destroy or do} test clay-mixin-a-0002 {Test and standard method from an ancestor} { $OBJ do this really cool thing } {I did this really cool thing} $OBJ clay mixinmap species ::TEST::animal test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {unknown} test clay-mixin-b-0003 {Test that an ensemble is created during a mixin} \ -body {$OBJ which flavor} -returnCodes {error} \ -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-21 ### test clay-mixin-b-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::animal ::TEST::thing ::clay::object} ### # Replacing a mixin replaces the behaviors ### $OBJ clay mixinmap species ::TEST::vegetable test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-c-0002 {Test that an ensemble is created during a mixin} \ -body {$OBJ which sound} \ -returnCodes {error} \ -result {unknown method which sound. Valid: color flavor} test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} { $OBJ which flavor } {unknown} ### # Test Modified: 2018-10-21 ### test clay-mixin-c-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::vegetable ::TEST::thing ::clay::object} ### # Replacing a mixin $OBJ clay mixinmap species ::TEST::species.cat test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} \ -body {$OBJ which flavor} -returnCodes {error} \ -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-30, 2018-10-21, 2018-10-10 ### test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} { $OBJ clay ancestors } {::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object} $OBJ clay mixinmap coloring ::TEST::coloring.calico test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {calico} test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-f-0003 {Test that an ensemble is created during a mixin} \ -body {$OBJ which flavor} -returnCodes {error} \ -result {unknown method which flavor. Valid: color sound} ### # Test modified 2018-10-30, 2018-10-21, 2018-10-10 ### test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} { $OBJ clay ancestors } {::TEST::coloring.calico ::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object} test clay-mixin-f-0005 {Test that clay data from a mixin works} { $OBJ clay provenance color } {::TEST::coloring.calico} ### # Test variable initialization ### ::clay::define ::TEST::has_var { Variable my_variable 10 method get_my_variable {} { my variable my_variable return $my_variable } } set OBJ [::TEST::has_var new] test clay-class-variable-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get variable/ my_variable } {10} # Modified 2018-10-30 (order is different) test clay-class-variable-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get variable } {my_variable 10 DestroyEvent 0} # Modified 2018-10-30 (order is different) test clay-class-variable-0003 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget variable } {. {} my_variable 10 DestroyEvent 0} test clay-class-variable-0004 {Test that variables declared in the class definition are initialized} { $OBJ get_my_variable } 10 ### # Test array initialization ### ::clay::define ::TEST::has_array { Array my_array {timeout 10} method get_my_array {field} { my variable my_array return $my_array($field) } } set OBJ [::TEST::has_array new] test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get array } {my_array {timeout 10}} test clay-class-array-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget array } {. {} my_array {. {} timeout 10}} test clay-class-array-0003 {Test that variables declared in the class definition are initialized} { $OBJ get_my_array timeout } 10 ::clay::define ::TEST::has_more_array { superclass ::TEST::has_array Array my_array {color blue} } test clay-class-array-0008 {Test that the parser injected the right value in the right place for clay to catch it} { ::TEST::has_more_array clay get array } {my_array {color blue}} test clay-class-array-0009 {Test that the parser injected the right value in the right place for clay to catch it} { ::TEST::has_more_array clay find array } {my_array {timeout 10 color blue}} # Modified 2018-10-30 (order is different) set BOBJ [::TEST::has_more_array new] test clay-class-array-0004 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay get array } {my_array {color blue timeout 10}} # Modified 2018-10-30 (order is different) test clay-class-array-0005 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay dget array } {. {} my_array {. {} color blue timeout 10}} test clay-class-arrau-0006 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_array timeout } 10 test clay-class-arrau-0007 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_array color } blue ::clay::define ::TEST::has_empty_array { Array my_array {} method my_array_exists {} { my variable my_array return [info exists my_array] } method get {field} { my variable my_array return $my_array($field) } method set {field value} { my variable my_array set my_array($field) $value } } test clay-class-array-0008 {Test that an declaration of an array with no values produces and empty array} { set COBJ [::TEST::has_empty_array new] $COBJ my_array_exists } 1 test clay-class-array-0009 {Test that an declaration of an array with no values produces and empty array} { $COBJ set test "A random value" $COBJ get test } {A random value} ### # Test dict initialization ### ::clay::define ::TEST::has_dict { Dict my_dict {timeout 10} method get_my_dict {args} { my variable my_dict if {[llength $args]==0} { return $my_dict } return [dict get $my_dict {*}$args] } } set OBJ [::TEST::has_dict new] test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get dict } {my_dict {timeout 10}} test clay-class-dict-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget dict } {. {} my_dict {. {} timeout 10}} test clay-class-dict-0003 {Test that variables declared in the class definition are initialized} { $OBJ get_my_dict timeout } 10 test clay-class-dict-0004 {Test that an empty dict is annotated} { $OBJ clay get dict } {my_dict {timeout 10}} ::clay::define ::TEST::has_more_dict { superclass ::TEST::has_dict Dict my_dict {color blue} } set BOBJ [::TEST::has_more_dict new] # Modified 2018-10-30 test clay-class-dict-0004 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay get dict } {my_dict {color blue timeout 10}} # Modified 2018-10-30 test clay-class-dict-0005 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay dget dict } {. {} my_dict {. {} color blue timeout 10}} test clay-class-dict-0006 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_dict timeout } 10 test clay-class-dict-0007 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_dict color } blue ::clay::define ::TEST::has_empty_dict { Dict my_empty_dict {} method get_my_empty_dict {args} { my variable my_empty_dict if {[llength $args]==0} { return $my_empty_dict } return [dict get $my_empty_dict {*}$args] } } set COBJ [::TEST::has_empty_dict new] test clay-class-dict-0008 {Test that the parser injected the right value in the right place for clay to catch it} { $COBJ clay dget dict } {my_empty_dict {. {}}} test clay-class-dict-0009 {Test that an empty dict is initialized} { $COBJ get_my_empty_dict } {} ### # Test object delegation ### ::clay::define ::TEST::organelle { method add args { set total 0 foreach item $args { set total [expr {$total+$item}] } return $total } } ::clay::define ::TEST::master { constructor {} { set mysub [namespace current]::sub ::TEST::organelle create $mysub my clay delegate sub $mysub } } set OBJ [::TEST::master new] ### # Test that delegation is working ### test clay-delegation-0001 {Test an array driven ensemble} { $OBJ <sub> add 5 5 } 10 ### # Test the Ensemble keyword ### ::clay::define ::TEST::with_ensemble { Ensemble myensemble {pattern args} { set ensemble [self method] set emap [my clay ensemble_map $ensemble] set mlist [dict keys $emap [string tolower $pattern]] if {[llength $mlist] != 1} { error "Couldn't figure out what to do with $pattern" } set method [lindex $mlist 0] set argspec [dict get $emap $method argspec] set body [dict get $emap $method body] if {$argspec ni {args {}}} { ::clay::dynamic_arguments $ensemble $method [list $argspec] {*}$args } eval $body } Ensemble myensemble::go args { return 1 } } ::clay::define ::TEST::with_ensemble.dance { Ensemble myensemble::dance args { return 1 } } ::clay::define ::TEST::with_ensemble.cannot_dance { Ensemble myensemble::dance args { return 0 } } set OBJA [::clay::object new] set OBJB [::clay::object new] $OBJA clay mixinmap \ core ::TEST::with_ensemble \ friends ::TEST::with_ensemble.dance $OBJB clay mixinmap \ core ::TEST::with_ensemble \ friends ::TEST::with_ensemble.cannot_dance } set testnum 0 set matrix { go { OBJA 1 OBJB 1 } dance { OBJA 1 OBJB 0 } } foreach {action output} $matrix { putb result "# Test $action" foreach {object value} $output { set map [dict create %object% $object %action% $action %value% $value] dict set map %testnum% [format %04d [incr testnum]] putb result $map {test clay-dynamic-ensemble-%testnum% {Test ensemble with static method} { $%object% myensemble %action% } {%value%}} } } putb result { ### # Class method testing ### clay::class create WidgetClass { Class_Method working {} { return {Works} } Class_Method unknown args { set tkpath [lindex $args 0] if {[string index $tkpath 0] eq "."} { set obj [my new $tkpath {*}[lrange $args 1 end]] $obj tkalias $tkpath return $tkpath } next {*}$args } constructor {TkPath args} { my variable hull set hull $TkPath my clay delegate hull $TkPath } method tkalias tkname { set oldname $tkname my variable tkalias set tkalias $tkname set self [self] set hullwidget [::info object namespace $self]::tkwidget my clay delegate tkwidget $hullwidget #rename ::$tkalias $hullwidget my clay delegate hullwidget $hullwidget #::tool::object_rename [self] ::$tkalias rename [self] ::$tkalias #my Hull_Bind $tkname return $hullwidget } } test tool-class-method-000 {Test that class methods actually work...} { WidgetClass working } {Works} test tool-class-method-001 {Test Tk style creator} { WidgetClass .foo .foo clay delegate hull } {.foo} ::clay::define WidgetNewClass { superclass WidgetClass } test tool-class-method-002 {Test Tk style creator inherited by morph} { WidgetNewClass .bar .bar clay delegate hull } {.bar} ### # Test ensemble inheritence ### clay::define NestedClassA { Ensemble do::family {} { return NestedClassA } Ensemble do::something {} { return A } Ensemble do::whop {} { return A } } clay::define NestedClassB { superclass NestedClassA Ensemble do::family {} { set r [next family] lappend r NestedClassB return $r } Ensemble do::whop {} { return B } } clay::define NestedClassC { superclass NestedClassB Ensemble do::somethingelse {} { return C } } clay::define NestedClassD { superclass NestedClassB Ensemble do::somethingelse {} { return D } } clay::define NestedClassE { superclass NestedClassD NestedClassC } clay::define NestedClassF { superclass NestedClassC NestedClassD } NestedClassC create NestedObjectC ### # These tests no longer work because method ensembles are now dynamically # generated by object, that are not attached to the class anymore # #### #test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} { # NestedObjectC do family #} {::NestedClassA ::NestedClassB ::NestedClassC} test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} { NestedObjectC do whop } {B} test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} { NestedObjectC do something } {A} NestedClassE create NestedObjectE NestedClassF create NestedObjectF test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} { NestedObjectE do somethingelse } {D} test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} { NestedObjectF do somethingelse } {C} ### # Set of tests to exercise the mixinmap system ### clay::define MixinMainClass { Variable mainvar unchanged Ensemble test::which {} { my variable mainvar return $mainvar } Ensemble test::main args { puts [list this is main $method $args] } } set mixoutscript {my test untool $class} set mixinscript {my test tool $class} clay::define MixinTool { Variable toolvar unchanged.mixin clay set mixin/ unmap-script $mixoutscript clay set mixin/ map-script $mixinscript clay set mixin/ name {Generic Tool} Ensemble test::untool class { my variable toolvar mainvar set mainvar {} set toolvar {} } Ensemble test::tool class { my variable toolvar mainvar set mainvar [$class clay get mixin name] set toolvar [$class clay get mixin name] } } clay::define MixinToolA { superclass MixinTool clay set mixin/ name {Tool A} } clay::define MixinToolB { superclass MixinTool clay set mixin/ name {Tool B} method test_newfunc {} { return "B" } } test tool-mixinspec-001 {Test application of mixin specs} { MixinTool clay get mixin map-script } $mixinscript test tool-mixinspec-002 {Test application of mixin specs} { MixinToolA clay get mixin map-script } {} test tool-mixinspec-003 {Test application of mixin specs} { MixinToolA clay find mixin map-script } $mixinscript test tool-mixinspec-004 {Test application of mixin specs} { MixinToolB clay find mixin map-script } $mixinscript MixinMainClass create mixintest test tool-mixinmap-001 {Test object prior to mixins} { mixintest test which } {unchanged} mixintest clay mixinmap tool MixinToolA test tool-mixinmap-002 {Test mixin map script ran} { mixintest test which } {Tool A} mixintest clay mixinmap tool MixinToolB test tool-mixinmap-003 {Test mixin map script ran} { mixintest test which } {Tool B} test tool-mixinmap-003 {Test mixin map script ran} { mixintest test_newfunc } {B} mixintest clay mixinmap tool {} test tool-mixinmap-004 {Test object prior to mixins} { mixintest test which } {} } ### # Test clay mixinslots ### putb result { clay::define ::clay::object { method path {} { return [self class] } } clay::define ::MixinRoot { clay set opts core root clay set opts option unset clay set opts color unset Ensemble info::root {} { return MixinRoot } Ensemble info::shade {} { return avacodo } Ensemble info::default {} { return Undefined } method did {} { return MixinRoot } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinOption1 { clay set opts option option1 Ensemble info::option {} { return MixinOption1 } Ensemble info::other {} { return MixinOption1 } method did {} { return MixinOption1 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinOption2 { superclass ::MixinOption1 clay set opts option option2 Ensemble info::option {} { return MixinOption2 } method did {} { return MixinOption2 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinColor1 { clay set opts color blue Ensemble info::color {} { return MixinColor1 } Ensemble info::shade {} { return blue } method did {} { return MixinColor1 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinColor2 { clay set opts color green Ensemble info::color {} { return MixinColor2 } Ensemble info::shade {} { return green } method did {} { return MixinColor2 } method path {} { return [list [self class] {*}[next]] } } set obj [clay::object new] $obj clay mixinmap root ::MixinRoot } set testnum 0 set batnum 0 set obj {$obj} set template { test tool-prototype-%battery%-%test% {%comment%} { %obj% %method% } {%answer%} } set map {} dict set map %obj% {$obj} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin core} foreach {method answer} { {info root} {MixinRoot} {info option} {Undefined} {info color} {Undefined} {info other} {Undefined} {info shade} {avacodo} {did} {MixinRoot} {path} {::MixinRoot ::clay::object} {clay get opts} {core root option unset color unset} {clay get opts core} root {clay get opts option} unset {clay get opts color} unset {clay ancestors} {::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap option ::MixinOption1} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin option1} foreach {method answer} { {info root} {MixinRoot} {info option} {MixinOption1} {info color} {Undefined} {info other} {MixinOption1} {info shade} {avacodo} {did} {MixinOption1} {path} {::MixinOption1 ::MixinRoot ::clay::object} {clay get opts} {option option1 core root color unset} {clay get opts core} root {clay get opts option} option1 {clay get opts color} unset {clay ancestors} {::MixinOption1 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result { set obj2 [clay::object new] $obj2 clay mixinmap root ::MixinRoot option ::MixinOption1 } putb result {$obj clay mixinmap option ::MixinOption1} dict set map %obj% {$obj2} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin option1 - clean object} foreach {method answer} { {info root} {MixinRoot} {info option} {MixinOption1} {info color} {Undefined} {info other} {MixinOption1} {info shade} {avacodo} {did} {MixinOption1} {path} {::MixinOption1 ::MixinRoot ::clay::object} {clay get opts} {option option1 core root color unset} {clay get opts core} root {clay get opts option} option1 {clay get opts color} unset {clay ancestors} {::MixinOption1 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap option ::MixinOption2} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin option2} dict set map %obj% {$obj} foreach {method answer} { {info root} {MixinRoot} {info option} {MixinOption2} {info color} {Undefined} {info other} {MixinOption1} {info shade} {avacodo} {did} {MixinOption2} {path} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} {clay get opts} {option option2 core root color unset} {clay get opts core} root {clay get opts option} option2 {clay get opts color} unset {clay ancestors} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap color MixinColor1} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin color1} foreach {method answer} { {info root} {MixinRoot} {info option} {MixinOption2} {info color} {MixinColor1} {info other} {MixinOption1} {info shade} {blue} {did} {MixinColor1} {path} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} {clay get opts} {color blue option option2 core root} {clay get opts core} root {clay get opts option} option2 {clay get opts color} blue {clay ancestors} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap color MixinColor2} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin color2} foreach {method answer} { {info root} {MixinRoot} {info option} {MixinOption2} {info color} {MixinColor2} {info other} {MixinOption1} {info shade} {green} {clay get opts} {color green option option2 core root} {clay get opts core} root {clay get opts option} option2 {clay get opts color} green {clay ancestors} {::MixinColor2 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap option MixinOption1} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin color2 + Option1} foreach {method answer} { {info root} {MixinRoot} {info option} {MixinOption1} {info color} {MixinColor2} {info other} {MixinOption1} {info shade} {green} {clay get opts} {color green option option1 core root} {clay get opts core} root {clay get opts option} option1 {clay get opts color} green {clay ancestors} {::MixinColor2 ::MixinOption1 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap option {}} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin color2 + no option} foreach {method answer} { {info root} {MixinRoot} {info option} {Undefined} {info color} {MixinColor2} {info other} {Undefined} {info shade} {green} {clay get opts} {color green core root option unset} {clay get opts core} root {clay get opts option} unset {clay get opts color} green {clay ancestors} {::MixinColor2 ::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } set testnum 0 putb result {$obj clay mixinmap color {}} dict set map %battery% [format %04d [incr batnum]] dict set map %comment% {Mixin core (return to normal)} foreach {method answer} { {info root} {MixinRoot} {info option} {Undefined} {info color} {Undefined} {info other} {Undefined} {info shade} {avacodo} {clay get opts} {core root option unset color unset} {clay get opts core} root {clay get opts option} unset {clay get opts color} unset {clay ancestors} {::MixinRoot ::clay::object} } { set testid [format %04d [incr testnum]] dict set map %test% $testid dict set map %method% $method dict set map %answer% $answer putb result $map $template } putb result { ### # Tip479 Tests ### clay::define tip479class { Method newitem dictargs { id {type: number} color {default: green} shape {options: {round square}} flavor {default: grape} } { my variable items foreach {f v} $args { dict set items $id $f $v } if {"color" ni [dict keys $args]} { dict set items $id color $color } return [dict get $items $id] } method itemget {id field} { my variable items return [dict get $id $field] } } set obj [tip479class new] test tip479-001 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 1 color orange shape round } {id 1 color orange shape round} # Fail because we left off a mandatory argument test tip479-002 {Test that a later ensemble definition trumps a more primitive one} \ -errorCode NONE -body { $obj newitem id 2 } -result {shape is required} ### # Leave off a value that has a default # note: Method had special handling for color, but not flavor ### test tip479-003 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 3 shape round } {id 3 shape round color green} ### # Add extra arguments ### test tip479-004 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 4 shape round trim leather } {id 4 shape round trim leather color green} clay::define tip479classE { Ensemble item::new dictargs { id {type: number} color {default: green} shape {options: {round square}} flavor {default: grape} } { my variable items foreach {f v} $args { dict set items $id $f $v } if {"color" ni [dict keys $args]} { dict set items $id color $color } return [dict get $items $id] } Ensemble item::get {id field} { my variable items return [dict get $id $field] } } set obj [tip479classE new] test tip479-001 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 1 color orange shape round } {id 1 color orange shape round} # Fail because we left off a mandatory argument test tip479-002 {Test that a later ensemble definition trumps a more primitive one} \ -errorCode NONE -body { $obj item new id 2 } -result {shape is required} ### # Leave off a value that has a default # note: Method had special handling for color, but not flavor ### test tip479-003 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 3 shape round } {id 3 shape round color green} ### # Add extra arguments ### test tip479-004 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 4 shape round trim leather } {id 4 shape round trim leather color green} } ### # TESTS NEEDED: # destructor ### putb result { testsuiteCleanup # Local variables: # mode: tcl # indent-tabs-mode: nil # End: } return $result |
Added modules/clay/build/uuid.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 | ### # Adapted from tcllib module # # uuid.tcl - Copyright (C) 2004 Pat Thoyts <[email protected]> # # UUIDs are 128 bit values that attempt to be unique in time and space. # # Reference: # http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt # # uuid: scheme: # http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html # # Usage: clay::uuid generate # clay::uuid equal $idA $idB namespace eval ::clay::uuid { namespace export uuid } ### # Optimization # Caches machine info after the first pass ### proc ::clay::uuid::generate_tcl_machinfo {} { variable machinfo if {[info exists machinfo]} { return $machinfo } lappend machinfo [clock seconds]; # timestamp lappend machinfo [clock clicks]; # system incrementing counter lappend machinfo [info hostname]; # spatial unique id (poor) lappend machinfo [pid]; # additional entropy lappend machinfo [array get ::tcl_platform] ### # If we have /dev/urandom just stream 128 bits from that ### if {[file exists /dev/urandom]} { set fin [open /dev/urandom r] binary scan [read $fin 128] H* machinfo close $fin } elseif {[catch {package require nettool}]} { # More spatial information -- better than hostname. # bug 1150714: opening a server socket may raise a warning messagebox # with WinXP firewall, using ipconfig will return all IP addresses # including ipv6 ones if available. ipconfig is OK on win98+ if {[string equal $::tcl_platform(platform) "windows"]} { catch {exec ipconfig} config lappend machinfo $config } else { catch { set s [socket -server void -myaddr [info hostname] 0] ::clay::K [fconfigure $s -sockname] [close $s] } r lappend machinfo $r } if {[package provide Tk] != {}} { lappend machinfo [winfo pointerxy .] lappend machinfo [winfo id .] } } else { ### # If the nettool package works on this platform # use the stream of hardware ids from it ### lappend machinfo {*}[::nettool::hwid_list] } return $machinfo } # Generates a binary UUID as per the draft spec. We generate a pseudo-random # type uuid (type 4). See section 3.4 # if {[info commands irmmd5] ne {}} { proc ::clay::uuid::generate {{type {}}} { variable nextuuid set s [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"] foreach {a b} {0 7 8 11 12 15 16 19 20 31} { append r [string range $s $a $b] - } return [string tolower [string trimright $r -]] } proc ::clay::uuid::short {{type {}}} { variable nextuuid set r [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"] return [string range $r 0 16] } } else { package require md5 2 proc ::clay::uuid::raw {{type {}}} { variable nextuuid set tok [md5::MD5Init] md5::MD5Update $tok "$type [incr nextuuid($type)] [generate_tcl_machinfo]" set r [md5::MD5Final $tok] return [::clay::uuid::tostring $r] } proc ::clay::uuid::generate {{type {}}} { return [::clay::uuid::tostring [::clay::uuid::raw $type]] } proc ::clay::uuid::short {{type {}}} { set r [::clay::uuid::raw $type] binary scan $r H* s return [string range $s 0 16] } } proc ::clay::uuid::tostring {uuid} { binary scan $uuid H* s foreach {a b} {0 7 8 11 12 15 16 19 20 31} { append r [string range $s $a $b] - } return [string tolower [string trimright $r -]] } # Convert a string representation of a uuid into its binary format. # proc ::clay::uuid::fromstring {uuid} { return [binary format H* [string map {- {}} $uuid]] } # Compare two uuids for equality. # proc ::clay::uuid::equal {left right} { set l [fromstring $left] set r [fromstring $right] return [string equal $l $r] } # uuid generate -> string rep of a new uuid # uuid equal uuid1 uuid2 # proc ::clay::uuid {cmd args} { switch -exact -- $cmd { generate { return [::clay::uuid::generate {*}$args] } short { set uuid [::clay::uuid::short {*}$args] } equal { tailcall ::clay::uuid::equal {*}$args } default { return -code error "bad option \"$cmd\":\ must be generate or equal" } } } |
Added modules/clay/clay.man.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | [comment {-*- tcl -*- doctools manpage}] [vset PACKAGE_VERSION 0.8] [manpage_begin clay n [vset PACKAGE_VERSION]] [keywords oo] [copyright {2018 Sean Woods <[email protected]>}] [moddesc {Clay Framework}] [titledesc {A minimalist framework for large scale OO Projects}] [category {Programming tools}] [keywords TclOO] [require Tcl 8.6] [require uuid] [require oo::dialect] [description] Clay introduces a method ensemble to both [class oo::class] and [class oo::object] called clay. This ensemble handles all of the high level interactions within the framework. Clay stores structured data. Clan manages method delegation. Clay has facilities to manage the complex interactions that come about with mixins. [para] The central concept is that inside of every object and class (which are actually objects too) is a dict called clay. What is stored in that dict is left to the imagination. But because this dict is exposed via a public method, we can share structured data between object, classes, and mixins. [para] [subsection {Structured Data}] Clay uses a standardized set of method interactions and introspection that TclOO already provides to perform on-the-fly searches. On-the-fly searches mean that the data is never stale, and we avoid many of the sorts of collisions that would arise when objects start mixing in other classes during operation. [para] The [method clay] methods for both classes and objects have a get and a set method. For objects, get will search through the local clay dict. If the requested leaf is not found, or the query is for a branch, the system will then begin to poll the clay methods of all of the class that implements the object, all of that classes’ ancestors, as well as all of the classes that have been mixed into this object, and all of their ancestors. [para] Intended branches on a tree end with a directory slash (/). Intended leaves are left unadorned. This is a guide for the tool that builds the search results to know what parts of a dict are intended to be branches and which are intended to be leaves. For simple cases, branch marking can be ignored: [example { ::oo::class create ::foo { } ::foo clay set property/ color blue ::foo clay set property/ shape round set A [::foo new] $A clay get property/ {color blue shape round} $A clay set property/ shape square $A clay get property/ {color blue shape square} }] [para] But when you start storing blocks of text, guessing what field is a dict and what isn’t gets messy: [example { ::foo clay set description {A generic thing of designated color and shape} $A clay get description {A generic thing of designated color and shape} Without a convention for discerning branches for leaves what should have been a value can be accidentally parsed as a dictionary, and merged with all of the other values that were never intended to be merge. Here is an example of it all going wrong: ::oo::class create ::foo { } # Add description as a leaf ::foo clay set description \ {A generic thing of designated color and shape} # Add description as a branch ::foo clay set description/ \ {A generic thing of designated color and shape} ::oo::class create ::bar { superclass foo } # Add description as a leaf ::bar clay set description \ {A drinking establishment of designated color and shape and size} # Add description as a branch ::bar clay set description/ \ {A drinking establishment of designated color and shape and size} set B [::bar new] # As a leaf we get the value verbatim from he nearest ancestor $B clay get description {A drinking establishment of designated color and shape and size} # As a branch we get a recursive merge $B clay get description/ {A drinking establishment of designated color and size thing of} }] [subsection {Clay Dialect}] Clay is built using the oo::dialect module from Tcllib. oo::dialect allows you to either add keywords directly to clay, or to create your own metaclass and keyword set using Clay as a foundation. For details on the keywords and what they do, consult the functions in the ::clay::define namespace. [subsection {Method Delegation}] Method Delegation It is sometimes useful to have an external object that can be invoked as if it were a method of the object. Clay provides a delegate ensemble method to perform that delegation, as well as introspect which methods are delegated in that manner. All delegated methods are marked with html-like tag markings (< >) around them. [example { ::clay::define counter { Variable counter 0 method incr {{howmuch 1}} { my variable counter incr counter $howmuch } method value {} { my variable counter return $counter } method reset {} { my variable counter set counter 0 } } ::clay::define example { variable buffer constructor {} { # Build a counter object set obj [namespace current]::counter ::counter create $obj # Delegate the counter my delegate <counter> $obj } method line {text} { my <counter> incr append buffer $text } } set A [example new] $A line {Who’s line is it anyway?} $A <counter> value 1 }] [section {Commands}] [list_begin definitions] [call proc [cmd clay::PROC] [arg name] [arg arglist] [arg body] [opt "[arg ninja] [const ""]"]] Because many features in this package may be added as commands to future tcl cores, or be provided in binary form by packages, I need a declaritive way of saying [emph {Create this command if there isn't one already}]. The [emph ninja] argument is a script to execute if the command is created by this mechanism. [call proc [cmd clay::_ancestors] [arg resultvar] [arg class]] [call proc [cmd clay::ancestors] [opt "[arg args]"]] [call proc [cmd clay::args_to_dict] [opt "[arg args]"]] [call proc [cmd clay::args_to_options] [opt "[arg args]"]] [call proc [cmd clay::dynamic_arguments] [arg ensemble] [arg method] [arg arglist] [opt "[arg args]"]] [call proc [cmd clay::dynamic_wrongargs_message] [arg arglist]] [call proc [cmd clay::is_dict] [arg d]] [call proc [cmd clay::is_null] [arg value]] [call proc [cmd clay::leaf] [opt "[arg args]"]] [call proc [cmd clay::K] [arg a] [arg b]] [call proc [cmd clay::noop] [opt "[arg args]"]] Perform a noop. Useful in prototyping for commenting out blocks of code without actually having to comment them out. It also makes a handy default for method delegation if a delegate has not been assigned yet. [call proc [cmd clay::path] [opt "[arg args]"]] [call proc [cmd clay::putb] [opt "[arg map]"] [arg text]] Append a line of text to a variable. Optionally apply a string mapping. [call proc [cmd clay::script_path]] [call proc [cmd clay::NSNormalize] [arg qualname]] [call proc [cmd clay::uuid_generate] [opt "[arg args]"]] [call proc [cmd clay::uuid::generate_tcl_machinfo]] [call proc [cmd clay::uuid::tostring] [arg uuid]] [call proc [cmd clay::uuid::fromstring] [arg uuid]] Convert a string representation of a uuid into its binary format. [call proc [cmd clay::uuid::equal] [arg left] [arg right]] Compare two uuids for equality. [call proc [cmd clay::uuid] [arg cmd] [opt "[arg args]"]] uuid generate -> string rep of a new uuid uuid equal uuid1 uuid2 [call proc [cmd clay::tree::sanitize] [arg dict]] Output a dictionary removing any . entries added by [fun {clay::tree::merge}] [call proc [cmd clay::tree::_sanitizeb] [arg path] [arg varname] [arg dict]] Helper function for ::clay::tree::sanitize Formats the string representation for a dictionary element within a human readable stream of lines, and determines if it needs to call itself with further indentation to express a sub-branch [call proc [cmd clay::tree::storage] [arg rawpath]] Return the path as a storage path for clay::tree with all branch terminators removed. This command will also break arguments up if they contain /. [para]Example: [example { > clay::tree::storage {foo bar baz bang} foo bar baz bang > clay::tree::storage {foo bar baz bang/} foo bar baz bang > clay::tree::storage {foo bar baz bang:} foo bar baz bang: > clay::tree::storage {foo/bar/baz bang:} foo bar baz bang: > clay::tree::storage {foo/bar/baz/bang} foo bar baz bang }] [call proc [cmd clay::tree::dictset] [arg varname] [opt "[arg args]"]] Set an element with a recursive dictionary, marking all branches on the way down to the final element. If the value does not exists in the nested dictionary it is added as a leaf. If the value already exists as a branch the value given is merged if the value is a valid dict. If the incoming value is not a valid dict, the value overrides the value stored, and the value is treated as a leaf from then on. [para]Example: [example { > set r {} > ::clay::tree::dictset r option color default Green . {} option {. {} color {. {} default Green}} > ::clay::tree::dictset r option {Something not dictlike} . {} option {Something not dictlike} # Note that if the value is not a dict, and you try to force it to be # an error with be thrown on the merge > ::clay::tree::dictset r option color default Blue missing value to go with key }] [call proc [cmd clay::tree::dictmerge] [arg varname] [opt "[arg args]"]] A recursive form of dict merge, intended for modifying variables in place. [para]Example: [example { > set mydict {sub/ {sub/ {description {a block of text}}}} > ::clay::tree::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}] > clay::tree::print $mydict sub/ { sub/ { description {a block of text} field {another block of text} } } }] [call proc [cmd clay::tree::merge] [opt "[arg args]"]] A recursive form of dict merge [para] A routine to recursively dig through dicts and merge adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/ [para]Example: [example { > set mydict {sub/ {sub/ {description {a block of text}}}} > set odict [clay::tree::merge $mydict {sub/ {sub/ {field {another block of text}}}}] > clay::tree::print $odict sub/ { sub/ { description {a block of text} field {another block of text} } } }] [call proc [cmd dictargs::proc] [arg name] [arg argspec] [arg body]] Named Procedures as new command [call proc [cmd dictargs::method] [arg name] [arg argspec] [arg body]] [call proc [cmd clay::dialect::Push] [arg class]] [call proc [cmd clay::dialect::Peek]] [call proc [cmd clay::dialect::Pop]] [call proc [cmd clay::dialect::create] [arg name] [opt "[arg parent] [const ""]"]] This proc will generate a namespace, a "mother of all classes", and a rudimentary set of policies for this dialect. [call proc [cmd clay::dialect::NSNormalize] [arg namespace] [arg qualname]] Support commands; not intended to be called directly. [call proc [cmd clay::dialect::DefineThunk] [arg target] [opt "[arg args]"]] [call proc [cmd clay::dialect::Canonical] [arg namespace] [arg NSpace] [arg class]] [call proc [cmd clay::dialect::Define] [arg namespace] [arg class] [opt "[arg args]"]] Implementation of the languages' define command [call proc [cmd clay::dialect::Aliases] [arg namespace] [opt "[arg args]"]] [call proc [cmd clay::dialect::SuperClass] [arg namespace] [opt "[arg args]"]] [call proc [cmd clay::dynamic_methods] [arg class]] [call proc [cmd clay::dynamic_methods_class] [arg thisclass]] [call proc [cmd clay::define::Array] [arg name] [opt "[arg values] [const ""]"]] New OO Keywords for clay [call proc [cmd clay::define::Delegate] [arg name] [arg info]] An annotation that objects of this class interact with delegated methods. The annotation is intended to be a dictionary, and the only reserved key is [emph {description}], a human readable description. [call proc [cmd clay::define::constructor] [arg arglist] [arg rawbody]] [call proc [cmd clay::define::Class_Method] [arg name] [arg arglist] [arg body]] Specify the a method for the class object itself, instead of for objects of the class [call proc [cmd clay::define::class_method] [arg name] [arg arglist] [arg body]] And alias to the new Class_Method keyword [call proc [cmd clay::define::clay] [opt "[arg args]"]] [call proc [cmd clay::define::destructor] [arg rawbody]] [call proc [cmd clay::define::Dict] [arg name] [opt "[arg values] [const ""]"]] [call proc [cmd clay::define::Option] [arg name] [opt "[arg args]"]] Define an option for the class [call proc [cmd clay::define::Method] [arg name] [arg argstyle] [arg argspec] [arg body]] [call proc [cmd clay::define::Option_Class] [arg name] [opt "[arg args]"]] Define a class of options All field / value pairs will be be inherited by an option that specify [emph name] as it class field. [call proc [cmd clay::define::Variable] [arg name] [opt "[arg default] [const ""]"]] 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. [call proc [cmd clay::object_create] [arg objname] [opt "[arg class] [const ""]"]] [call proc [cmd clay::object_rename] [arg object] [arg newname]] [call proc [cmd clay::object_destroy] [arg objname]] [call proc [cmd clay::ensemble_methodbody] [arg ensemble] [arg einfo]] [call proc [cmd clay::define::Ensemble] [arg rawmethod] [opt "[arg args]"]] [call proc [cmd clay::destroy] [opt "[arg args]"]] Mark an object for destruction on the next cleanup [call proc [cmd clay::cleanup]] Process the queue of objects to be destroyed [call proc [cmd clay::event::cancel] [arg self] [opt "[arg task] [const "*"]"]] Cancel a scheduled event [call proc [cmd clay::event::generate] [arg self] [arg event] [opt "[arg args]"]] Generate an event Adds a subscription mechanism for objects to see who has recieved this event and prevent spamming or infinite recursion [call proc [cmd clay::event::nextid]] [call proc [cmd clay::event::Notification_list] [arg self] [arg event] [opt "[arg stackvar] [const ""]"]] Called recursively to produce a list of who recieves notifications [call proc [cmd clay::event::notify] [arg rcpt] [arg sender] [arg event] [arg eventinfo]] Final delivery to intended recipient object [call proc [cmd clay::event::process] [arg self] [arg handle] [arg script]] Evaluate an event script in the global namespace [call proc [cmd clay::event::schedule] [arg self] [arg handle] [arg interval] [arg script]] Schedule an event to occur later [call proc [cmd clay::event::subscribe] [arg self] [arg who] [arg event]] Subscribe an object to an event pattern [call proc [cmd clay::event::unsubscribe] [arg self] [opt "[arg args]"]] Unsubscribe an object from an event pattern [list_end] [section Classes] [subsection {Class clay::class}] [para] [class {Methods}] [list_begin definitions] [call method [cmd "clay ancestors"]] Return this class and all ancestors in search order. [call method [cmd "clay dump"]] Return a complete dump of this object's clay data, but only this object's clay data. [call method [cmd "clay find"] [arg path] [opt [option "path..."]]] Pull a chunk of data from the clay system. If the last element of [emph path] is a branch, returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching leaf and return the first value found. If no value is found, returns an empty string. If a branch is returned the topmost . entry is omitted. [call method [cmd "clay get"] [arg path] [opt [option "path..."]]] Pull a chunk of data from the class's clay system. If no value is found, returns an empty string. If a branch is returned the topmost . entry is omitted. [call method [cmd "clay GET"] [arg path] [opt [option "path..."]]] Pull a chunk of data from the class's clay system. If no value is found, returns an empty string. [call method [cmd "clay merge"] [arg dict] [opt [option "dict..."]]] Recursively merge the dictionaries given into the object's local clay storage. [call method [cmd "clay replace"] [arg dictionary]] Replace the contents of the internal clay storage with the dictionary given. [call method [cmd "clay search"] [arg path] [opt [option "path..."]]] Return the first matching value for the path in either this class's clay data or one of its ancestors [call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]] Merge the conents of [const value] with the object's clay storage at [const path]. [list_end] [para] [subsection {Class clay::object}] clay::object This class is inherited by all classes that have options. [para] [class {Methods}] [list_begin definitions] [call method [cmd "clay ancestors"]] Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order. [call method [cmd "clay cget"] [arg field]] Pull a value from either the object's clay structure or one of its constituent classes that matches the field name. The order of search us: [para] 1. The as a value in local dict variable config [para] 2. The as a value in local dict variable clay [para] 3. As a leaf in any ancestor as a root of the clay tree [para] 4. As a leaf in any ancestor as [const const] [emph field] [para] 5. As a leaf in any ancestor as [const option] [emph field] [const default] [call method [cmd "clay delegate"] [opt "[arg stub]"] [opt "[arg object]"]] Introspect or control method delegation. With no arguments, the method will return a key/value list of stubs and objects. With just the [arg stub] argument, the method will return the object (if any) attached to the stub. With a [arg stub] and an [arg object] this command will forward all calls to the method [arg stub] to the [arg object]. [call method [cmd "clay dump"]] Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in. [call method [cmd "clay ensemble_map"]] Return a dictionary describing the method ensembles to be assembled for this object [call method [cmd "clay eval"] [arg script]] Evaluated a script in the namespace of this object [call method [cmd "clay evolve"]] Trigger the [method InitializePublic] private method [call method [cmd "clay exists"] [arg path] [opt [option "path..."]]] Returns 1 if [emph path] exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found. [call method [cmd "clay flush"]] Wipe any caches built by the clay implementation [call method [cmd "clay forward"] [arg method] [arg object]] A convenience wrapper for [example {oo::objdefine [self] forward {*}$args}] [call method [cmd "clay get"] [arg path] [opt [option "path..."]]] Pull a chunk of data from the clay system. If the last element of [emph path] is a branch (ends in a slash /), returns a recursive merge of all data from this object and it's constituent classes of the data in that branch. If the last element is a leaf, search this object for a matching leaf, or search all constituent classes for a matching leaf and return the first value found. If no value is found, returns an empty string. [call method [cmd "clay leaf"] [arg path] [opt [option "path..."]]] A modified get which is tailored to pull only leaf elements [call method [cmd "clay merge"] [arg dict] [opt [option "dict..."]]] Recursively merge the dictionaries given into the object's local clay storage. [call method [cmd "clay mixin"] [arg class] [opt [option "class..."]]] Perform [lb]oo::objdefine [lb]self[rb] mixin[rb] on this object, with a few additional rules: Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.) For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.) Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.) [call method [cmd "clay mixinmap"] [opt "[arg stub]"] [opt "[arg classes]"]] With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given, returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given classes and invoke clay mixin on the new matrix of mixed in classes. [call method [cmd "clay provenance"] [arg path] [opt [option "path..."]]] Return either [const self] if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element. [call method [cmd "clay replace"] [arg dictionary]] Replace the contents of the internal clay storage with the dictionary given. [call method [cmd "clay source"] [arg filename]] Source the given filename within the object's namespace [call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]] Merge the conents of [const value] with the object's clay storage at [const path]. [call method [cmd "InitializePublic"]] Instantiate variables. Called on object creation and during clay mixin. [list_end] [para] [section AUTHORS] Sean Woods [uri mailto:<[email protected]>][para] [vset CATEGORY oo] [include ../doctools2base/include/feedback.inc] [manpage_end] |
Added modules/clay/clay.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 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 | ### # clay.tcl # # Copyright (c) 2018 Sean Woods # # BSD License ### # @@ Meta Begin # Package clay 0.8 # Meta platform tcl # Meta summary A minimalist framework for complex TclOO development # Meta description This package introduces the method "clay" to both oo::object # Meta description and oo::class which facilitate complex interactions between objects # Meta description and their ancestor and mixed in classes. # Meta category TclOO # Meta subject framework # Meta require {Tcl 8.6} # Meta author Sean Woods # Meta license BSD # @@ Meta End ### # Amalgamated package for clay # Do not edit directly, tweak the source in build/ and rerun # build.tcl ### package provide clay 0.8 namespace eval ::clay {} ### # START: procs.tcl ### namespace eval ::clay { } set ::clay::trace 0 proc ::clay::PROC {name arglist body {ninja {}}} { if {[info commands $name] ne {}} return proc $name $arglist $body eval $ninja } if {[info commands ::PROC] eq {}} { namespace eval ::clay { namespace export PROC } namespace eval :: { namespace import ::clay::PROC } } proc ::clay::_ancestors {resultvar class} { upvar 1 $resultvar result if {$class in $result} { return } lappend result $class foreach aclass [::info class superclasses $class] { _ancestors result $aclass } } proc ::clay::ancestors {args} { set result {} set queue {} set metaclasses {} foreach class $args { set ancestors($class) {} _ancestors ancestors($class) $class } foreach class [lreverse $args] { foreach aclass $ancestors($class) { if {$aclass in $result} continue set skip 0 foreach bclass $args { if {$class eq $bclass} continue if {$aclass in $ancestors($bclass)} { set skip 1 break } } if {$skip} continue lappend result $aclass } } foreach class [lreverse $args] { foreach aclass $ancestors($class) { if {$aclass in $result} continue lappend result $aclass } } ### # Screen out classes that do not participate in clay # interactions ### set output {} foreach {item} $result { if {[catch {$item clay noop} err]} { continue } lappend output $item } return $output } proc ::clay::args_to_dict args { if {[llength $args]==1} { return [lindex $args 0] } return $args } proc ::clay::args_to_options args { set result {} foreach {var val} [args_to_dict {*}$args] { lappend result [string trim $var -:] $val } return $result } proc ::clay::dynamic_arguments {ensemble method arglist args} { set idx 0 set len [llength $args] if {$len > [llength $arglist]} { ### # Catch if the user supplies too many arguments ### set dargs 0 if {[lindex $arglist end] ni {args dictargs}} { return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]" } } foreach argdef $arglist { if {$argdef eq "args"} { ### # Perform args processing in the style of tcl ### uplevel 1 [list set args [lrange $args $idx end]] break } if {$argdef eq "dictargs"} { ### # Perform args processing in the style of tcl ### uplevel 1 [list set args [lrange $args $idx end]] ### # Perform args processing in the style of clay ### set dictargs [::clay::args_to_options {*}[lrange $args $idx end]] uplevel 1 [list set dictargs $dictargs] break } if {$idx > $len} { ### # Catch if the user supplies too few arguments ### if {[llength $argdef]==1} { return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]" } else { uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]] } } else { uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]] } incr idx } } proc ::clay::dynamic_wrongargs_message {arglist} { set result "" set dargs 0 foreach argdef $arglist { if {$argdef in {args dictargs}} { set dargs 1 break } if {[llength $argdef]==1} { append result " $argdef" } else { append result " ?[lindex $argdef 0]?" } } if { $dargs } { append result " ?option value?..." } return $result } proc ::clay::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {::dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } proc ::clay::is_null value { return [expr {$value in {{} NULL}}] } proc ::clay::leaf args { set marker [string index [lindex $args end] end] set result [path {*}${args}] if {$marker eq "/"} { return $result } return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]] } proc ::clay::K {a b} {set a} if {[info commands ::K] eq {}} { namespace eval ::clay { namespace export K } namespace eval :: { namespace import ::clay::K } } proc ::clay::noop args {} if {[info commands ::noop] eq {}} { namespace eval ::clay { namespace export noop } namespace eval :: { namespace import ::clay::noop } } proc ::clay::path args { set result {} foreach item $args { set item [string trim $item :./] foreach subitem [split $item /] { lappend result [string trim ${subitem}]/ } } return $result } proc ::clay::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { append buffer [lindex $args 0] \n } 2 { append buffer [string map {*}$args] \n } default { error "usage: putb buffername ?map? string" } } } if {[info command ::putb] eq {}} { namespace eval ::clay { namespace export putb } namespace eval :: { namespace import ::clay::putb } } proc ::clay::script_path {} { set path [file dirname [file join [pwd] [info script]]] return $path } proc ::clay::NSNormalize qualname { if {![string match ::* $qualname]} { set qualname ::clay::classes::$qualname } regsub -all {::+} $qualname "::" } proc ::clay::uuid_generate args { return [uuid generate] } namespace eval ::clay { variable option_class {} variable core_classes {::oo::class ::oo::object} } ### # END: procs.tcl ### ### # START: core.tcl ### package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things. if {[info commands irmmd5] eq {}} { if {[catch {package require odielibc}]} { package require md5 2 } } ::namespace eval ::clay { } ::namespace eval ::clay::classes { } ::namespace eval ::clay::define { } ::namespace eval ::clay::tree { } ::namespace eval ::clay::dict { } ::namespace eval ::clay::list { } ::namespace eval ::clay::uuid { } if {![info exists ::clay::idle_destroy]} { set ::clay::idle_destroy {} } ### # END: core.tcl ### ### # START: uuid.tcl ### namespace eval ::clay::uuid { namespace export uuid } proc ::clay::uuid::generate_tcl_machinfo {} { variable machinfo if {[info exists machinfo]} { return $machinfo } lappend machinfo [clock seconds]; # timestamp lappend machinfo [clock clicks]; # system incrementing counter lappend machinfo [info hostname]; # spatial unique id (poor) lappend machinfo [pid]; # additional entropy lappend machinfo [array get ::tcl_platform] ### # If we have /dev/urandom just stream 128 bits from that ### if {[file exists /dev/urandom]} { set fin [open /dev/urandom r] binary scan [read $fin 128] H* machinfo close $fin } elseif {[catch {package require nettool}]} { # More spatial information -- better than hostname. # bug 1150714: opening a server socket may raise a warning messagebox # with WinXP firewall, using ipconfig will return all IP addresses # including ipv6 ones if available. ipconfig is OK on win98+ if {[string equal $::tcl_platform(platform) "windows"]} { catch {exec ipconfig} config lappend machinfo $config } else { catch { set s [socket -server void -myaddr [info hostname] 0] ::clay::K [fconfigure $s -sockname] [close $s] } r lappend machinfo $r } if {[package provide Tk] != {}} { lappend machinfo [winfo pointerxy .] lappend machinfo [winfo id .] } } else { ### # If the nettool package works on this platform # use the stream of hardware ids from it ### lappend machinfo {*}[::nettool::hwid_list] } return $machinfo } if {[info commands irmmd5] ne {}} { proc ::clay::uuid::generate {{type {}}} { variable nextuuid set s [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"] foreach {a b} {0 7 8 11 12 15 16 19 20 31} { append r [string range $s $a $b] - } return [string tolower [string trimright $r -]] } proc ::clay::uuid::short {{type {}}} { variable nextuuid set r [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"] return [string range $r 0 16] } } else { package require md5 2 proc ::clay::uuid::raw {{type {}}} { variable nextuuid set tok [md5::MD5Init] md5::MD5Update $tok "$type [incr nextuuid($type)] [generate_tcl_machinfo]" set r [md5::MD5Final $tok] return [::clay::uuid::tostring $r] } proc ::clay::uuid::generate {{type {}}} { return [::clay::uuid::tostring [::clay::uuid::raw $type]] } proc ::clay::uuid::short {{type {}}} { set r [::clay::uuid::raw $type] binary scan $r H* s return [string range $s 0 16] } } proc ::clay::uuid::tostring {uuid} { binary scan $uuid H* s foreach {a b} {0 7 8 11 12 15 16 19 20 31} { append r [string range $s $a $b] - } return [string tolower [string trimright $r -]] } proc ::clay::uuid::fromstring {uuid} { return [binary format H* [string map {- {}} $uuid]] } proc ::clay::uuid::equal {left right} { set l [fromstring $left] set r [fromstring $right] return [string equal $l $r] } proc ::clay::uuid {cmd args} { switch -exact -- $cmd { generate { return [::clay::uuid::generate {*}$args] } short { set uuid [::clay::uuid::short {*}$args] } equal { tailcall ::clay::uuid::equal {*}$args } default { return -code error "bad option \"$cmd\":\ must be generate or equal" } } } ### # END: uuid.tcl ### ### # START: dict.tcl ### ::clay::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] } ::clay::PROC ::tcl::dict::is_dict { d } { # is it a dict, or can it be treated like one? if {[catch {dict size $d} err]} { #::set ::errorInfo {} return 0 } return 1 } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict] } ::clay::PROC ::tcl::dict::rmerge {args} { ::set result [dict create . {}] # Merge b into a, and handle nested dicts appropriately ::foreach b $args { for { k v } $b { ::set field [string trim $k :/] if {![::clay::tree::is_branch $b $k]} { # Element names that end in ":" are assumed to be literals set result $k $v } elseif { [exists $result $k] } { # key exists in a and b? let's see if both values are dicts # both are dicts, so merge the dicts if { [is_dict [get $result $k]] && [is_dict $v] } { set result $k [rmerge [get $result $k] $v] } else { set result $k $v } } else { set result $k $v } } } return $result } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge] } ::clay::PROC ::clay::tree::is_branch { dict path } { set field [lindex $path end] if {[string index $field end] eq ":"} { return 0 } if {[string index $field 0] eq "."} { return 0 } if {[string index $field end] eq "/"} { return 1 } return [dict exists $dict {*}$path .] } ::clay::PROC ::clay::tree::print {dict} { ::set result {} ::set level -1 ::clay::tree::_dictputb $level result $dict return $result } ::clay::PROC ::clay::tree::_dictputb {level varname dict} { upvar 1 $varname result incr level dict for {field value} $dict { if {$field eq "."} continue if {[clay::tree::is_branch $dict $field]} { putb result "[string repeat " " $level]$field \{" _dictputb $level result $value putb result "[string repeat " " $level]\}" } else { putb result "[string repeat " " $level][list $field $value]" } } } proc ::clay::tree::sanitize {dict} { ::set result {} ::set level -1 ::clay::tree::_sanitizeb {} result $dict return $result } proc ::clay::tree::_sanitizeb {path varname dict} { upvar 1 $varname result dict for {field value} $dict { if {$field eq "."} continue if {[clay::tree::is_branch $dict $field]} { _sanitizeb [list {*}$path $field] result $value } else { dict set result {*}$path $field $value } } } proc ::clay::tree::storage {rawpath} { set isleafvar 0 set path {} set tail [string index $rawpath end] foreach element $rawpath { set items [split [string trim $element /] /] foreach item $items { if {$item eq {}} continue lappend path $item } } return $path } proc ::clay::tree::dictset {varname args} { upvar 1 $varname result if {[llength $args] < 2} { error "Usage: ?path...? path value" } elseif {[llength $args]==2} { set rawpath [lindex $args 0] } else { set rawpath [lrange $args 0 end-1] } set value [lindex $args end] set path [storage $rawpath] set dot . set one {} dict set result $dot $one set dpath {} foreach item [lrange $path 0 end-1] { set field $item lappend dpath [string trim $item /] dict set result {*}$dpath $dot $one } set field [lindex $rawpath end] set ext [string index $field end] if {$ext eq {:} || ![dict is_dict $value]} { dict set result {*}$path $value return } if {$ext eq {/} && ![dict exists $result {*}$path $dot]} { dict set result {*}$path $dot $one } if {[dict exists $result {*}$path $dot]} { dict set result {*}$path [::clay::tree::merge [dict get $result {*}$path] $value] return } dict set result {*}$path $value } proc ::clay::tree::dictmerge {varname args} { upvar 1 $varname result set dot . set one {} dict set result $dot $one foreach dict $args { dict for {f v} $dict { set field [string trim $f /] set bbranch [clay::tree::is_branch $dict $f] if {![dict exists $result $field]} { dict set result $field $v if {$bbranch} { dict set result $field [clay::tree::merge $v] } else { dict set result $field $v } } elseif {[dict exists $result $field $dot]} { if {$bbranch} { dict set result $field [clay::tree::merge [dict get $result $field] $v] } else { dict set result $field $v } } } } return $result } proc ::clay::tree::merge {args} { ### # The result of a merge is always a dict with branches ### set dot . set one {} dict set result $dot $one set argument 0 foreach b $args { # Merge b into a, and handle nested dicts appropriately if {![dict is_dict $b]} { error "Element $b is not a dictionary" } dict for { k v } $b { if {$k eq $dot} { dict set result $dot $one continue } set bbranch [is_branch $b $k] set field [string trim $k /] if { ![dict exists $result $field] } { if {$bbranch} { dict set result $field [merge $v] } else { dict set result $field $v } } else { set abranch [dict exists $result $field $dot] if {$abranch && $bbranch} { dict set result $field [merge [dict get $result $field] $v] } else { dict set result $field $v if {$bbranch} { dict set result $field $dot $one } } } } } return $result } ::clay::PROC ::tcl::dict::isnull {dictionary args} { if {![exists $dictionary {*}$args]} {return 1} return [expr {[get $dictionary {*}$args] in {{} NULL null}}] } { namespace ensemble configure dict -map [dict replace\ [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull] } ### # END: dict.tcl ### ### # START: list.tcl ### ::clay::PROC ::clay::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 } ::clay::PROC ::clay::ldelete {varname args} { upvar 1 $varname var if ![info exists var] { return } foreach item [lsort -unique $args] { while {[set i [lsearch $var $item]]>=0} { set var [lreplace $var $i $i] } } return $var } ::clay::PROC ::clay::lrandom list { set len [llength $list] set idx [expr int(rand()*$len)] return [lindex $list $idx] } ### # END: list.tcl ### ### # START: dictargs.tcl ### namespace eval ::dictargs { } if {[info commands ::dictargs::parse] eq {}} { proc ::dictargs::parse {argdef argdict} { set result {} dict for {field info} $argdef { if {![string is alnum [string index $field 0]]} { error "$field is not a simple variable name" } upvar 1 $field _var set aliases {} if {[dict exists $argdict $field]} { set _var [dict get $argdict $field] continue } if {[dict exists $info aliases:]} { set found 0 foreach {name} [dict get $info aliases:] { if {[dict exists $argdict $name]} { set _var [dict get $argdict $name] set found 1 break } } if {$found} continue } if {[dict exists $info default:]} { set _var [dict get $info default:] continue } set mandatory 1 if {[dict exists $info mandatory:]} { set mandatory [dict get $info mandatory:] } if {$mandatory} { error "$field is required" } } } } proc ::dictargs::proc {name argspec body} { set result {} append result "::dictargs::parse \{$argspec\} \$args" \; append result $body uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result] } proc ::dictargs::method {name argspec body} { set class [lindex [::info level -1] 1] set result {} append result "::dictargs::parse \{$argspec\} \$args" \; append result $body oo::define $class method $name [list [list args [list dictargs $argspec]]] $result } ### # END: dictargs.tcl ### ### # START: dialect.tcl ### namespace eval ::clay::dialect { namespace export create foreach {flag test} { tip470 {package vsatisfies [package provide Tcl] 8.7} } { if {![info exists ::clay::dialect::has($flag)]} { set ::clay::dialect::has($flag) [eval $test] } } } proc ::clay::dialect::Push {class} { ::variable class_stack lappend class_stack $class } proc ::clay::dialect::Peek {} { ::variable class_stack return [lindex $class_stack end] } proc ::clay::dialect::Pop {} { ::variable class_stack set class_stack [lrange $class_stack 0 end-1] } if {$::clay::dialect::has(tip470)} { proc ::clay::dialect::current_class {} { return [uplevel 1 self] } } else { proc ::clay::dialect::current_class {} { tailcall Peek } } proc ::clay::dialect::create {name {parent ""}} { variable has set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name] ::namespace eval $NSPACE {::namespace eval define {}} ### # Build the "define" namespace ### if {$parent eq ""} { ### # With no "parent" language, begin with all of the keywords in # oo::define ### foreach command [info commands ::oo::define::*] { set procname [namespace tail $command] interp alias {} ${NSPACE}::define::$procname {} \ ::clay::dialect::DefineThunk $procname } # Create an empty dynamic_methods proc proc ${NSPACE}::dynamic_methods {class} {} namespace eval $NSPACE { ::namespace export dynamic_methods ::namespace eval define {::namespace export *} } set ANCESTORS {} } else { ### # If we have a parent language, that language already has the # [oo::define] keywords as well as additional keywords and behaviors. # We should begin with that ### set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent] apply [list parent { ::namespace export dynamic_methods ::namespace import -force ${parent}::dynamic_methods } $NSPACE] $pnspace apply [list parent { ::namespace import -force ${parent}::define::* ::namespace export * } ${NSPACE}::define] $pnspace set ANCESTORS [list ${pnspace}::object] } ### # Build our dialect template functions ### proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] { ### # To facilitate library reloading, allow # a dialect to create a class from DEFINE ### set class [::clay::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass] if {[info commands $class] eq {}} { %NSPACE%::class create $class {*}${args} } else { ::clay::dialect::Define %NSPACE% $class {*}${args} } }] interp alias {} ${NSPACE}::define::current_class {} \ ::clay::dialect::current_class interp alias {} ${NSPACE}::define::aliases {} \ ::clay::dialect::Aliases $NSPACE interp alias {} ${NSPACE}::define::superclass {} \ ::clay::dialect::SuperClass $NSPACE if {[info command ${NSPACE}::class] ne {}} { ::rename ${NSPACE}::class {} } ### # Build the metaclass for our language ### ::oo::class create ${NSPACE}::class { superclass ::clay::dialect::MotherOfAllMetaClasses } # Wire up the create method to add in the extra argument we need; the # MotherOfAllMetaClasses will know what to do with it. ::oo::objdefine ${NSPACE}::class \ method create {name {definitionScript ""}} \ "next \$name [list ${NSPACE}::define] \$definitionScript" ### # Build the mother of all classes. Note that $ANCESTORS is already # guaranteed to be a list in canonical form. ### uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { %NSPACE%::class create %NSPACE%::object { superclass %ANCESTORS% # Put MOACish stuff in here } }] if { "${NSPACE}::class" ni $::clay::dialect::core_classes } { lappend ::clay::dialect::core_classes "${NSPACE}::class" } if { "${NSPACE}::object" ni $::clay::dialect::core_classes } { lappend ::clay::dialect::core_classes "${NSPACE}::object" } } proc ::clay::dialect::NSNormalize {namespace qualname} { if {![string match ::* $qualname]} { set qualname ${namespace}::$qualname } regsub -all {::+} $qualname "::" } proc ::clay::dialect::DefineThunk {target args} { tailcall ::oo::define [Peek] $target {*}$args } proc ::clay::dialect::Canonical {namespace NSpace class} { namespace upvar $namespace cname cname #if {[string match ::* $class]} { # return $class #} if {[info exists cname($class)]} { return $cname($class) } if {[info exists ::clay::dialect::cname($class)]} { return $::clay::dialect::cname($class) } if {[info exists ::clay::dialect::cname(${NSpace}::${class})]} { return $::clay::dialect::cname(${NSpace}::${class}) } foreach item [list "${NSpace}::$class" "::$class"] { if {[info commands $item] ne {}} { return $item } } return ${NSpace}::$class } proc ::clay::dialect::Define {namespace class args} { Push $class try { if {[llength $args]==1} { namespace eval ${namespace}::define [lindex $args 0] } else { ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end] } ${namespace}::dynamic_methods $class } finally { Pop } } proc ::clay::dialect::Aliases {namespace args} { set class [Peek] namespace upvar $namespace cname cname set NSpace [join [lrange [split $class ::] 1 end-2] ::] set cname($class) $class foreach name $args { set cname($name) $class #set alias $name set alias [NSNormalize $NSpace $name] # Add a local metaclass reference if {![info exists ::clay::dialect::cname($alias)]} { lappend ::clay::dialect::aliases($class) $alias ## # Add a global reference, first come, first served ## set ::clay::dialect::cname($alias) $class } } } proc ::clay::dialect::SuperClass {namespace args} { set class [Peek] namespace upvar $namespace class_info class_info dict set class_info($class) superclass 1 set ::clay::dialect::cname($class) $class set NSpace [join [lrange [split $class ::] 1 end-2] ::] set unique {} foreach item $args { set Item [Canonical $namespace $NSpace $item] dict set unique $Item $item } set root ${namespace}::object if {$class ne $root} { dict set unique $root $root } tailcall ::oo::define $class superclass {*}[dict keys $unique] } if {[info command ::clay::dialect::MotherOfAllMetaClasses] eq {}} { ::oo::class create ::clay::dialect::MotherOfAllMetaClasses { superclass ::oo::class constructor {define definitionScript} { $define [self] { superclass } $define [self] $definitionScript } method aliases {} { if {[info exists ::clay::dialect::aliases([self])]} { return $::clay::dialect::aliases([self]) } } } } namespace eval ::clay::dialect { variable core_classes {::oo::class ::oo::object} } ### # END: dialect.tcl ### ### # START: metaclass.tcl ### ::clay::dialect::create ::clay proc ::clay::dynamic_methods class { foreach command [info commands [namespace current]::dynamic_methods_*] { $command $class } } proc ::clay::dynamic_methods_class {thisclass} { set methods {} set mdata [$thisclass clay find class_typemethod] foreach {method info} $mdata { if {$method eq {.}} continue set method [string trimright $method :/-] if {$method in $methods} continue lappend methods $method set arglist [dict getnull $info arglist] set body [dict getnull $info body] ::oo::objdefine $thisclass method $method $arglist $body } } proc ::clay::define::Array {name {values {}}} { set class [current_class] set name [string trim $name :/] $class clay branch array $name dict for {var val} $values { $class clay set array/ $name $var $val } } proc ::clay::define::Delegate {name info} { set class [current_class] foreach {field value} $info { $class clay set component/ [string trim $name :/]/ $field $value } } proc ::clay::define::constructor {arglist rawbody} { set body { my variable DestroyEvent set DestroyEvent 0 ::clay::object_create [self] [info object class [self]] # Initialize public variables and options my InitializePublic } append body $rawbody set class [current_class] ::oo::define $class constructor $arglist $body } proc ::clay::define::Class_Method {name arglist body} { set class [current_class] $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body] } proc ::clay::define::class_method {name arglist body} { set class [current_class] $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body] } proc ::clay::define::clay {args} { set class [current_class] if {[lindex $args 0] in "cget set branch"} { $class clay {*}$args } else { $class clay set {*}$args } } proc ::clay::define::destructor rawbody { set body { # Run the destructor once and only once set self [self] my variable DestroyEvent if {$DestroyEvent} return set DestroyEvent 1 ::clay::object_destroy $self } append body $rawbody ::oo::define [current_class] destructor $body } proc ::clay::define::Dict {name {values {}}} { set class [current_class] set name [string trim $name :/] $class clay branch dict $name foreach {var val} $values { $class clay set dict/ $name/ $var $val } } proc ::clay::define::Option {name args} { set class [current_class] set dictargs {default {}} foreach {var val} [::clay::args_to_dict {*}$args] { dict set dictargs [string trim $var -:/] $val } set name [string trimleft $name -] ### # Option Class handling ### set optclass [dict getnull $dictargs class] if {$optclass ne {}} { foreach {f v} [$class clay find option_class $optclass] { if {![dict exists $dictargs $f]} { dict set dictargs $f $v } } if {$optclass eq "variable"} { variable $name [dict getnull $dictargs default] } } foreach {f v} $dictargs { $class clay set option $name $f $v } } proc ::clay::define::Method {name argstyle argspec body} { set class [current_class] set result {} switch $argstyle { dictargs { append result "::dictargs::parse \{$argspec\} \$args" \; } } append result $body oo::define $class method $name [list [list args [list dictargs $argspec]]] $result } proc ::clay::define::Option_Class {name args} { set class [current_class] set dictargs {default {}} set name [string trimleft $name -:] foreach {f v} [::clay::args_to_dict {*}$args] { $class clay set option_class $name [string trim $f -/:] $v } } proc ::clay::define::Variable {name {default {}}} { set class [current_class] set name [string trimright $name :/] $class clay set variable/ $name $default } proc ::clay::object_create {objname {class {}}} { #if {$::clay::trace>0} { # puts [list $objname CREATE] #} } proc ::clay::object_rename {object newname} { if {$::clay::trace>0} { puts [list $object RENAME -> $newname] } } proc ::clay::object_destroy objname { if {$::clay::trace>0} { puts [list $objname DESTROY] } #::cron::object_destroy $objname } ### # END: metaclass.tcl ### ### # START: ensemble.tcl ### ::namespace eval ::clay::define { } proc ::clay::ensemble_methodbody {ensemble einfo} { set default standard set preamble {} set eswitch {} if {[dict exists $einfo default]} { set emethodinfo [dict get $einfo default] set argspec [dict getnull $emethodinfo argspec] set realbody [dict getnull $emethodinfo body] set argstyle [dict getnull $emethodinfo argstyle] if {$argstyle eq "dictargs"} { set body "\n ::dictargs::parse \{$argspec\} \$args" } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} { set body {} } else { set body "\n ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args" } append body "\n " [string trim $realbody] " \n" set default $body dict unset einfo default } foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] { set submethod [string trim $msubmethod :/-] if {$submethod eq "_body"} continue if {$submethod eq "_preamble"} { set preamble [dict getnull $esubmethodinfo body] continue } set argspec [dict getnull $esubmethodinfo argspec] set realbody [dict getnull $esubmethodinfo body] set argstyle [dict getnull $esubmethodinfo argstyle] if {[string length [string trim $realbody]] eq {}} { dict set eswitch $submethod {} } else { if {$argstyle eq "dictargs"} { set body "\n ::dictargs::parse \{$argspec\} \$args" } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} { set body {} } else { set body "\n ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args" } append body "\n " [string trim $realbody] " \n" if {$submethod eq "default"} { set default $body } else { foreach alias [dict getnull $esubmethodinfo aliases] { dict set eswitch $alias - } dict set eswitch $submethod $body } } } set methodlist [lsort -dictionary [dict keys $eswitch]] if {![dict exists $eswitch <list>]} { dict set eswitch <list> {return $methodlist} } if {$default eq "standard"} { set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\"" } dict set eswitch default $default set mbody {} append mbody $preamble \n append mbody \n [list set methodlist $methodlist] append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]" append mbody \n {return -options $opts $result} return $mbody } ::proc ::clay::define::Ensemble {rawmethod args} { if {[llength $args]==2} { lassign $args argspec body set argstyle tcl } elseif {[llength $args]==3} { lassign $args argstyle argspec body } else { error "Usage: Ensemble name ?argstyle? argspec body" } set class [current_class] #if {$::clay::trace>2} { # puts [list $class Ensemble $rawmethod $argspec $body] #} set mlist [split $rawmethod "::"] set ensemble [string trim [lindex $mlist 0] :/] set mensemble ${ensemble}/ if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} { set method _body ### # Simple method, needs no parsing, but we do need to record we have one ### if {$argstyle eq "dictargs"} { set argspec [list args $argspec] } $class clay set method_ensemble/ $mensemble _body [dict create argspec $argspec body $body argstyle $argstyle] if {$::clay::trace>2} { puts [list $class clay set method_ensemble/ $mensemble _body ...] } set method $rawmethod if {$::clay::trace>2} { puts [list $class Ensemble $rawmethod $argspec $body] set rawbody $body set body {puts [list [self] $class [self method]]} append body \n $rawbody } if {$argstyle eq "dictargs"} { set rawbody $body set body "::dictargs::parse \{$argspec\} \$args\; " append body $rawbody } ::oo::define $class method $rawmethod $argspec $body return } set method [join [lrange $mlist 2 end] "::"] $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create argspec $argspec body $body argstyle $argstyle] if {$::clay::trace>2} { puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/] ...] } } ### # END: ensemble.tcl ### ### # START: class.tcl ### ::oo::define ::clay::class { method clay {submethod args} { my variable clay if {![info exists clay]} { set clay {} } switch $submethod { ancestors { tailcall ::clay::ancestors [self] } branch { set path [::clay::tree::storage $args] if {![dict exists $clay {*}$path .]} { dict set clay {*}$path . {} } } exists { if {![info exists clay]} { return 0 } set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return 1 } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return 1 } return 0 } dump { return $clay } dget { if {![info exists clay]} { return {} } set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] } return {} } is_branch { set path [::clay::tree::storage $args] return [dict exists $clay {*}$path .] } getnull - get { if {![info exists clay]} { return {} } set path [::clay::tree::storage $args] if {[llength $path]==0} { return $clay } if {[dict exists $clay {*}$path .]} { return [::clay::tree::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] } return {} } find { set path [::clay::tree::storage $args] if {![info exists clay]} { set clay {} } set clayorder [::clay::ancestors [self]] set found 0 if {[llength $path]==0} { set result [dict create . {}] foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } return [::clay::tree::sanitize $result] } foreach class $clayorder { if {[$class clay exists {*}$path .]} { # Found a branch break set found 1 break } if {[$class clay exists {*}$path]} { # Found a leaf. Return that value immediately return [$class clay get {*}$path] } if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} { return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:] } } if {!$found} { return {} } set result {} # Leaf searches return one data field at a time # Search in our local dict # Search in the in our list of classes for an answer foreach class [lreverse $clayorder] { ::clay::tree::dictmerge result [$class clay dget {*}$path] } return [::clay::tree::sanitize $result] } merge { foreach arg $args { ::clay::tree::dictmerge clay {*}$arg } } noop { # Do nothing. Used as a sign of clay savviness } search { foreach aclass [::clay::ancestors [self]] { if {[$aclass clay exists {*}$args]} { return [$aclass clay get {*}$args] } } } set { ::clay::tree::dictset clay {*}$args } unset { dict unset clay {*}$args } default { dict $submethod clay {*}$args } } } } ### # END: class.tcl ### ### # START: object.tcl ### ::oo::define ::clay::object { method clay {submethod args} { my variable clay claycache clayorder config option_canonical if {![info exists clay]} {set clay {}} if {![info exists claycache]} {set claycache {}} if {![info exists config]} {set config {}} if {![info exists clayorder] || [llength $clayorder]==0} { set clayorder {} if {[dict exists $clay cascade]} { dict for {f v} [dict get $clay cascade] { if {$f eq "."} continue if {[info commands $v] ne {}} { lappend clayorder $v } } } lappend clayorder {*}[::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] } switch $submethod { ancestors { return $clayorder } branch { set path [::clay::tree::storage $args] if {![dict exists $clay {*}$path .]} { dict set clay {*}$path . {} } } cget { # Leaf searches return one data field at a time # Search in our local dict if {[llength $args]==1} { set field [string trim [lindex $args 0] -:/] if {[info exists option_canonical($field)]} { set field $option_canonical($field) } if {[dict exists $config $field]} { return [dict get $config $field] } } set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path]} { if {[dict exists $claycache {*}$path .]} { return [dict remove [dict get $claycache {*}$path] .] } else { return [dict get $claycache {*}$path] } } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } if {[$class clay exists const {*}$path]} { set value [$class clay get const {*}$path] dict set claycache {*}$path $value return $value } if {[$class clay exists option {*}$path default]} { set value [$class clay get option {*}$path default] dict set claycache {*}$path $value return $value } } return {} } delegate { if {![dict exists $clay .delegate <class>]} { dict set clay .delegate <class> [info object class [self]] } if {[llength $args]==0} { return [dict get $clay .delegate] } if {[llength $args]==1} { set stub <[string trim [lindex $args 0] <>]> if {![dict exists $clay .delegate $stub]} { return {} } return [dict get $clay .delegate $stub] } if {([llength $args] % 2)} { error "Usage: delegate OR delegate stub OR delegate stub OBJECT ?stub OBJECT? ..." } foreach {stub object} $args { set stub <[string trim $stub <>]> dict set clay .delegate $stub $object oo::objdefine [self] forward ${stub} $object oo::objdefine [self] export ${stub} } } dump { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } ensemble_map { set ensemble [lindex $args 0] my variable claycache set mensemble [string trim $ensemble :/] if {[dict exists $claycache method_ensemble $mensemble]} { return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]] } set emap [my clay dget method_ensemble $mensemble] dict set claycache method_ensemble $mensemble $emap return [clay::tree::sanitize $emap] } eval { set script [lindex $args 0] set buffer {} set thisline {} foreach line [split $script \n] { append thisline $line if {![info complete $thisline]} { append thisline \n continue } set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} continue if {[string length $thisline]==0} continue if {[lindex $thisline 0] eq "my"} { # Line already calls out "my", accept verbatim append buffer $thisline \n } elseif {[string range $thisline 0 2] eq "::"} { # Fully qualified commands accepted verbatim append buffer $thisline \n } elseif { append buffer "my $thisline" \n } set thisline {} } eval $buffer } evolve - initialize { my InitializePublic } exists { # Leaf searches return one data field at a time # Search in our local dict set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path]} { return 1 } # Search in our local cache if {[dict exists $claycache {*}$path]} { return 2 } set count 2 # Search in the in our list of classes for an answer foreach class $clayorder { incr count if {[$class clay exists {*}$path]} { return $count } } return 0 } flush { set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] } forward { oo::objdefine [self] forward {*}$args } dget { set path [::clay::tree::storage $args] if {[llength $path]==0} { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return $result } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [dict get $claycache {*}$path] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result [dict getnull $clay {*}$path] foreach class $clayorder { if {![$class clay exists {*}$path .]} continue ::clay::tree::dictmerge result [$class clay dget {*}$path] } #if {[dict exists $clay {*}$path .]} { # ::clay::tree::dictmerge result #} dict set claycache {*}$path $result return $result } getnull - get { set path [::clay::tree::storage $args] if {[llength $path]==0} { # Do a full dump of clay data set result {} # Search in the in our list of classes for an answer foreach class $clayorder { ::clay::tree::dictmerge result [$class clay dump] } ::clay::tree::dictmerge result $clay return [::clay::tree::sanitize $result] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [::clay::tree::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} { # Path is a leaf return [dict get $clay {*}$path] } set found 0 set branch [dict exists $clay {*}$path .] foreach class $clayorder { if {[$class clay exists {*}$path .]} { set found 1 break } if {!$branch && [$class clay exists {*}$path]} { set result [$class clay dget {*}$path] dict set claycache {*}$path $result return $result } } # Path is a branch set result [dict getnull $clay {*}$path] #foreach class [lreverse $clayorder] { # if {![$class clay exists {*}$path .]} continue # ::clay::tree::dictmerge result [$class clay dget {*}$path] #} foreach class $clayorder { if {![$class clay exists {*}$path .]} continue ::clay::tree::dictmerge result [$class clay dget {*}$path] } #if {[dict exists $clay {*}$path .]} { # ::clay::tree::dictmerge result [dict get $clay {*}$path] #} dict set claycache {*}$path $result return [clay::tree::sanitize $result] } leaf { # Leaf searches return one data field at a time # Search in our local dict set path [::clay::tree::storage $args] if {[dict exists $clay {*}$path .]} { return [clay::tree::sanitize [dict get $clay {*}$path]] } if {[dict exists $clay {*}$path]} { return [dict get $clay {*}$path] } # Search in our local cache if {[dict exists $claycache {*}$path .]} { return [clay::tree::sanitize [dict get $claycache {*}$path]] } if {[dict exists $claycache {*}$path]} { return [dict get $claycache {*}$path] } # Search in the in our list of classes for an answer foreach class $clayorder { if {[$class clay exists {*}$path]} { set value [$class clay get {*}$path] dict set claycache {*}$path $value return $value } } } merge { foreach arg $args { ::clay::tree::dictmerge clay {*}$arg } } mixin { ### # Mix in the class ### set prior [info object mixins [self]] set newmixin {} foreach item $args { lappend newmixin ::[string trimleft $item :] } set newmap $args foreach class $prior { if {$class ni $newmixin} { set script [$class clay search mixin/ unmap-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]" } } } } ::oo::objdefine [self] mixin {*}$args ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### my InitializePublic foreach class $newmixin { if {$class ni $prior} { set script [$class clay search mixin/ map-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]" } } } } foreach class $newmixin { set script [$class clay search mixin/ react-script] if {[string length $script]} { if {[catch $script err errdat]} { puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]" } break } } } mixinmap { my variable clay if {![dict exists $clay .mixin]} { dict set clay .mixin {} } if {[llength $args]==0} { return [dict get $clay .mixin] } elseif {[llength $args]==1} { return [dict getnull $clay .mixin [lindex $args 0]] } else { dict for {slot classes} $args { dict set clay .mixin $slot $classes } set classlist {} dict for {item class} [dict get $clay .mixin] { if {$class ne {}} { lappend classlist $class } } my clay mixin {*}[lreverse $classlist] } } provenance { if {[dict exists $clay {*}$args]} { return self } foreach class $clayorder { if {[$class clay exists {*}$args]} { return $class } } return {} } replace { set clay [lindex $args 0] } source { source [lindex $args 0] } set { #puts [list [self] clay SET {*}$args] set claycache {} ::clay::tree::dictset clay {*}$args } default { dict $submethod clay {*}$args } } } method InitializePublic {} { my variable clayorder clay claycache config option_canonical set claycache {} set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]] if {![info exists clay]} { set clay {} } if {![info exists config]} { set config {} } dict for {var value} [my clay get variable] { if { $var in {. clay} } continue set var [string trim $var :/] my variable $var if {![info exists $var]} { if {$::clay::trace>2} {puts [list initialize variable $var $value]} set $var $value } } dict for {var value} [my clay get dict/] { if { $var in {. clay} } continue set var [string trim $var :/] my variable $var if {![info exists $var]} { set $var {} } foreach {f v} $value { if {$f eq "."} continue if {![dict exists ${var} $f]} { if {$::clay::trace>2} {puts [list initialize dict $var $f $v]} dict set ${var} $f $v } } } foreach {var value} [my clay get array/] { if { $var in {. clay} } continue set var [string trim $var :/] if { $var eq {clay} } continue my variable $var if {![info exists $var]} { array set $var {} } foreach {f v} $value { if {![array exists ${var}($f)]} { if {$f eq "."} continue if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]} set ${var}($f) $v } } } foreach {field info} [my clay get option/] { if { $field in {. clay} } continue set field [string trim $field -/:] foreach alias [dict getnull $info aliases] { set option_canonical($alias) $field } if {[dict exists $config $field]} continue set getcmd [dict getnull $info default-command] if {$getcmd ne {}} { set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]] } else { set value [dict getnull $info default] } dict set config $field $value set setcmd [dict getnull $info set-command] if {$setcmd ne {}} { {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd] } } my variable clayorder clay claycache if {[info exists clay]} { set emap [dict getnull $clay method_ensemble] } else { set emap {} } foreach class [lreverse $clayorder] { ### # Build a compsite map of all ensembles defined by the object's current # class as well as all of the classes being mixed in ### dict for {mensemble einfo} [$class clay get method_ensemble] { if {$mensemble eq {.}} continue set ensemble [string trim $mensemble :/] if {$::clay::trace>2} {puts [list Defining $ensemble from $class]} dict for {method info} $einfo { if {$method eq {.}} continue if {![dict is_dict $info]} { puts [list WARNING: class: $class method: $method not dict: $info] continue } dict set info source $class if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]} dict set emap $ensemble $method $info } } } foreach {ensemble einfo} $emap { #if {[dict exists $einfo _body]} continue set body [::clay::ensemble_methodbody $ensemble $einfo] if {$::clay::trace>2} { set rawbody $body set body {puts [list [self] <object> [self method]]} append body \n $rawbody } oo::objdefine [self] method $ensemble {{method default} args} $body } } } ::clay::object clay branch array ::clay::object clay branch mixin ::clay::object clay branch option ::clay::object clay branch dict clay ::clay::object clay set variable DestroyEvent 0 ### # END: object.tcl ### ### # START: event.tcl ### ::namespace eval ::clay::event { } proc ::clay::destroy args { if {![info exists ::clay::idle_destroy]} { set ::clay::idle_destroy {} } foreach object $args { if {$object in $::clay::idle_destroy} continue lappend ::clay::idle_destroy $object } } proc ::clay::cleanup {} { if {![info exists ::clay::idle_destroy]} return foreach obj $::clay::idle_destroy { if {[info commands $obj] ne {}} { catch {$obj destroy} } } set ::clay::idle_destroy {} } proc ::clay::event::cancel {self {task *}} { variable timer_event variable timer_script foreach {id event} [array get timer_event $self:$task] { ::after cancel $event set timer_event($id) {} set timer_script($id) {} } } proc ::clay::event::generate {self event args} { set wholist [Notification_list $self $event] if {$wholist eq {}} return set dictargs [::oo::meta::args_to_options {*}$args] set info $dictargs set strict 0 set debug 0 set sender $self dict with dictargs {} dict set info id [::clay::event::nextid] dict set info origin $self dict set info sender $sender dict set info rcpt {} foreach who $wholist { catch {::clay::event::notify $who $self $event $info} } } proc ::clay::event::nextid {} { return "event#[format %0.8x [incr ::clay::event_count]]" } proc ::clay::event::Notification_list {self event {stackvar {}}} { set notify_list {} foreach {obj patternlist} [array get ::clay::object_subscribe] { if {$obj eq $self} continue if {$obj in $notify_list} continue set match 0 foreach {objpat eventlist} $patternlist { if {![string match $objpat $self]} continue foreach eventpat $eventlist { if {![string match $eventpat $event]} continue set match 1 break } if {$match} { break } } if {$match} { lappend notify_list $obj } } return $notify_list } proc ::clay::event::notify {rcpt sender event eventinfo} { if {[info commands $rcpt] eq {}} return if {$::clay::trace} { puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo] } $rcpt notify $event $sender $eventinfo } proc ::clay::event::process {self handle script} { variable timer_event variable timer_script array unset timer_event $self:$handle array unset timer_script $self:$handle set err [catch {uplevel #0 $script} result errdat] if $err { puts "BGError: $self $handle $script ERR: $result [dict get $errdat -errorinfo] ***" } } proc ::clay::event::schedule {self handle interval script} { variable timer_event variable timer_script if {$::clay::trace} { puts [list $self schedule $handle $interval] } if {[info exists timer_event($self:$handle)]} { if {$script eq $timer_script($self:$handle)} { return } ::after cancel $timer_event($self:$handle) } set timer_script($self:$handle) $script set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]] } proc ::clay::event::subscribe {self who event} { upvar #0 ::clay::object_subscribe($self) subscriptions if {![info exists subscriptions]} { set subscriptions {} } set match 0 foreach {objpat eventlist} $subscriptions { if {![string match $objpat $who]} continue foreach eventpat $eventlist { if {[string match $eventpat $event]} { # This rule already exists return } } } dict lappend subscriptions $who $event } proc ::clay::event::unsubscribe {self args} { upvar #0 ::clay::object_subscribe($self) subscriptions if {![info exists subscriptions]} { return } switch [llength $args] { 1 { set event [lindex $args 0] if {$event eq "*"} { # Shortcut, if the set subscriptions {} } else { set newlist {} foreach {objpat eventlist} $subscriptions { foreach eventpat $eventlist { if {[string match $event $eventpat]} continue dict lappend newlist $objpat $eventpat } } set subscriptions $newlist } } 2 { set who [lindex $args 0] set event [lindex $args 1] if {$who eq "*" && $event eq "*"} { set subscriptions {} } else { set newlist {} foreach {objpat eventlist} $subscriptions { if {[string match $who $objpat]} { foreach eventpat $eventlist { if {[string match $event $eventpat]} continue dict lappend newlist $objpat $eventpat } } } set subscriptions $newlist } } } } ### # END: event.tcl ### namespace eval ::clay { namespace export * } |
Added modules/clay/clay.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 | namespace eval ::oo::dialect {} set ::oo::dialect::has(tip470) 0 # clay.test - Copyright (c) 2018 Sean Woods # ------------------------------------------------------------------------- set MODDIR [file dirname [file dirname [file join [pwd] [info script]]]] if {[file exists [file join $MODDIR devtools testutilities.tcl]]} { # Running inside tcllib set TCLLIBMOD $MODDIR } else { set TCLLIBMOD [file join $MODDIR .. .. tcllib modules] } source [file join $TCLLIBMOD devtools testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2 testsNeed TclOO 1 support {} testing { useLocal clay.tcl clay } set ::clay::trace 0 # ------------------------------------------------------------------------- # Handle multiple implementation testing # array set preserve [array get ::clay::uuid::accel] proc implementations {} { variable ::clay::uuid::accel foreach {a v} [array get accel] {if {$v} {lappend r $a}} lappend r tcl; set r } proc select_implementation {impl} { variable ::clay::uuid::accel foreach e [array names accel] { set accel($e) 0 } if {[string compare "tcl" $impl] != 0} { set accel($impl) 1 } } proc reset_implementation {} { variable ::clay::uuid::accel array set accel [array get ::preserve] } # ------------------------------------------------------------------------- # Setup any constraints # # ------------------------------------------------------------------------- # Now the package specific tests.... # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- foreach impl [implementations] { select_implementation $impl test uuid-1.0-$impl "uuid requires args" { list [catch {clay::uuid} msg] } {1} test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" { list [catch {string length [clay::uuid generate]} msg] $msg } {0 36} test uuid-1.2-$impl "uuid comparison of uuid with self should be true" { list [catch { set a [clay::uuid generate] clay::uuid equal $a $a } msg] $msg } {0 1} test uuid-1.3-$impl "uuid comparison of two different uuids should be false" { list [catch { set a [clay::uuid generate] set b [clay::uuid generate] clay::uuid equal $a $b } msg] $msg } {0 0} reset_implementation } # Modification History: ### # Modification 2018-10-30 # Fixed an error in our ancestry mapping and developed tests to # ensure we are actually following in the order TclOO follows methods ### # Modification 2018-10-21 # The clay metaclass no longer exports the clay method # to oo::class and oo::object, and clay::ancestors no # longer returns any class that lacks the clay method ### # Modification 2018-10-10 # clay::ancestors now rigged to descend into all classes depth-first # and then place metaclasses at the end of the search ### # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- # Test Helpers ### proc dict_compare {a b} { set result {} set A {} dict for {f v} $a { set f [string trim $f :/] if {$f eq {.}} continue dict set A $f $v } set B {} dict for {f v} $b { set f [string trim $f :/] if {$f eq {.}} continue dict set B $f $v } dict for {f v} $A { if {[dict exists $B $f]} { if {[dict get $B $f] ne $v} { lappend result [list B $f [dict get $B $f] [list != $v]] } } else { lappend result [list B $f $v missing] } } dict for {f v} $B { if {![dict exists $A $f]} { lappend result [list A $f $v missing] } } return $result } test dict-compare-001 {Test our testing method} { dict_compare {} {} } {} test dict-compare-002 {Test our testing method} { dict_compare {a 1} {} } {{B a 1 missing}} test dict-compare-003 {Test our testing method} { dict_compare {a 1 b 2} {a 1 b 2} } {} test dict-compare-003.a {Test our testing method} { dict_compare {a 1 b 2} {b 2 a 1 } } {} test dict-compare-003.b {Test our testing method} { dict_compare {b 2 a 1} {a 1 b 2} } {} test dict-compare-004 {Test our testing method} { dict_compare {a: 1 b: 2} {a 1 b 2} } {} test dict-compare-005 {Test our testing method} { dict_compare {a 1 b 3} {a 1 b 2} } {{B b 2 {!= 3}}} ### # Test canonical mapping ### test {test-storage-0001} {Test ::clay::tree::storage with foo bar baz} { clay::tree::storage {foo bar baz} } {foo bar baz} test {test-storage-0002} {Test ::clay::tree::storage with foo bar baz/} { clay::tree::storage {foo bar baz/} } {foo bar baz} test {test-storage-0003} {Test ::clay::tree::storage with foo bar .} { clay::tree::storage {foo bar .} } {foo bar .} test {test-storage-0004} {Test ::clay::tree::storage with foo/ bar/ .} { clay::tree::storage {foo/ bar/ .} } {foo bar .} test {test-storage-0005} {Test ::clay::tree::storage with foo . bar . baz .} { clay::tree::storage {foo . bar . baz .} } {foo . bar . baz .} test {test-storage-0006} {Test ::clay::tree::storage with foo bar baz bat:} { clay::tree::storage {foo bar baz bat:} } {foo bar baz bat:} test {test-storage-0007} {Test ::clay::tree::storage with foo:} { clay::tree::storage {foo:} } {foo:} test {test-storage-0008} {Test ::clay::tree::storage with foo/bar/baz/bat:} { clay::tree::storage {foo/bar/baz/bat:} } {foo bar baz bat:} dict set r foo/ bar/ baz 1 dict set s foo/ bar/ baz 0 set t [clay::tree::merge $r $s] test rmerge-0001 {Test that the root is marked as a branch} { dict get $t foo bar baz } 0 set r [dict create] clay::tree::dictmerge r { foo/ { bar/ { baz 1 bing: 2 bang { bim 3 boom 4 } womp: {a 1 b 2} } } } test dictmerge-0001 {Test that the root is marked as a branch} { dict exists $r . } 1 test dictmerge-0002 {Test that branch foo is marked correctly} { dict exists $r foo . } 1 test dictmerge-0003 {Test that branch bar is marked correctly} { dict exists $r foo bar . } 1 test dictmerge-0004 {Test that leaf foo/bar/bang is not marked as branch despite being a dict} { dict exists $r foo bar bang . } 0 test dictmerge-0004 {Test that leaf foo/bar/bang/bim exists} { dict exists $r foo bar bang bim } 1 test dictmerge-0005 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 1 ### # Replace bang with bang/ ### clay::tree::dictmerge r { foo/ { bar/ { bang/ { whoop 1 } } } } test dictmerge-0006 {Test that leaf foo/bar/bang/bim ceases to exist} { dict exists $r foo bar bang bim } 0 test dictmerge-0007 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 0 test dictmerge-0008 {Test that leaf foo/bar/bang is now a branch} { dict exists $r foo bar bang . } 1 test branch-0001 {Test that foo/ is a branch} { clay::tree::is_branch $r foo/ } 1 test branch-0002 {Test that foo is a branch} { clay::tree::is_branch $r foo } 1 test branch-0003 {Test that foo/bar/ is a branch} { clay::tree::is_branch $r {foo/ bar/} } 1 test branch-0004 {Test that foo bar is not branch} { clay::tree::is_branch $r {foo bar} } 1 test branch-0004 {Test that foo/ bar is not branch} { clay::tree::is_branch $r {foo/ bar} } 0 test {test-branch-0001} {Test that foo is_branch = 1} { clay::tree::is_branch $r { foo} } 1 test {test-branch-0002} {Test that foo: is_branch = 0} { clay::tree::is_branch $r { foo:} } 0 test {test-branch-0003} {Test that foo/ is_branch = 1} { clay::tree::is_branch $r { foo/} } 1 test {test-branch-0004} {Test that .foo is_branch = 0} { clay::tree::is_branch $r { .foo} } 0 test {test-branch-0005} {Test that foo bar is_branch = 1} { clay::tree::is_branch $r {foo bar} } 1 test {test-branch-0006} {Test that foo bar: is_branch = 0} { clay::tree::is_branch $r {foo bar:} } 0 test {test-branch-0007} {Test that foo bar/ is_branch = 1} { clay::tree::is_branch $r {foo bar/} } 1 test {test-branch-0008} {Test that foo .bar is_branch = 0} { clay::tree::is_branch $r {foo .bar} } 0 test {test-branch-0009} {Test that foo bar baz is_branch = 0} { clay::tree::is_branch $r {foo bar baz} } 0 test {test-branch-0010} {Test that foo bar baz: is_branch = 0} { clay::tree::is_branch $r {foo bar baz:} } 0 test {test-branch-0011} {Test that foo bar baz/ is_branch = 1} { clay::tree::is_branch $r {foo bar baz/} } 1 test {test-branch-0012} {Test that foo bar .baz is_branch = 0} { clay::tree::is_branch $r {foo bar .baz} } 0 test {test-branch-0013} {Test that foo bar bing is_branch = 0} { clay::tree::is_branch $r {foo bar bing} } 0 test {test-branch-0014} {Test that foo bar bing: is_branch = 0} { clay::tree::is_branch $r {foo bar bing:} } 0 test {test-branch-0015} {Test that foo bar bing/ is_branch = 1} { clay::tree::is_branch $r {foo bar bing/} } 1 test {test-branch-0016} {Test that foo bar .bing is_branch = 0} { clay::tree::is_branch $r {foo bar .bing} } 0 test {test-branch-0017} {Test that foo bar bang is_branch = 1} { clay::tree::is_branch $r {foo bar bang} } 1 test {test-branch-0018} {Test that foo bar bang: is_branch = 0} { clay::tree::is_branch $r {foo bar bang:} } 0 test {test-branch-0019} {Test that foo bar bang/ is_branch = 1} { clay::tree::is_branch $r {foo bar bang/} } 1 test {test-branch-0020} {Test that foo bar .bang is_branch = 0} { clay::tree::is_branch $r {foo bar .bang} } 0 test {test-branch-0021} {Test that foo bar bang whoop is_branch = 0} { clay::tree::is_branch $r {foo bar bang whoop} } 0 test {test-branch-0022} {Test that foo bar bang whoop: is_branch = 0} { clay::tree::is_branch $r {foo bar bang whoop:} } 0 test {test-branch-0023} {Test that foo bar bang whoop/ is_branch = 1} { clay::tree::is_branch $r {foo bar bang whoop/} } 1 test {test-branch-0024} {Test that foo bar bang .whoop is_branch = 0} { clay::tree::is_branch $r {foo bar bang .whoop} } 0 # ------------------------------------------------------------------------- # dictmerge Testing - oometa unset -nocomplain foo clay::tree::dictmerge foo { option/ { color/ { label Color default green } } } clay::tree::dictmerge foo { option/ { color/ { default purple } } } test oometa-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color default } purple test oometa-0002 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color label } Color unset -nocomplain foo set foo {. {}} ::clay::tree::dictmerge foo {. {} color {. {} default green label Color}} ::clay::tree::dictmerge foo {. {} color {. {} default purple}} test oometa-0003 {Recursive merge problem from oometa/clay find} { dict get $foo color default } purple test oometa-0004 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color unset -nocomplain foo set foo {. {}} ::clay::tree::dictmerge foo {. {} color {. {} default purple}} ::clay::tree::dictmerge foo {. {} color {. {} default green label Color}} test oometa-0005 {Recursive merge problem from oometa/clay find} { dict get $foo color default } green test oometa-0006 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color test oometa-0008 {Un-Sanitized output} { set foo } {. {} color {. {} default green label Color}} test oometa-0009 {Sanitize} { clay::tree::sanitize $foo } {color {default green label Color}} # ------------------------------------------------------------------------- # dictmerge Testing - clay unset -nocomplain foo test clay-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { ::clay::tree::dictmerge foo set foo } {. {}} unset -nocomplain foo ::clay::tree::dictset foo bar/ baz/ bell bang test clay-0002 {For new entries dictmerge is essentially a set} { dict get $foo bar baz bell } {bang} ::clay::tree::dictset foo bar/ baz/ boom/ bang test clay-0003 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz bell } {bang} test clay-0004 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz boom } {bang} ::clay::tree::dictset foo bar/ baz/ bop {color green flavor strawberry} test clay-0005 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color green flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bop {color yellow} test clay-0006 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color yellow} ::clay::tree::dictset foo bar/ baz/ bang/ {color green flavor strawberry} test clay-0007a {Branches are merged} { dict get $foo bar baz bang } {. {} color green flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ color yellow test clay-0007b {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ {color blue} test clay-0007c {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ shape: {Sort of round} test clay-0007d {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo bar/ baz/ bang/ color yellow test clay-0007e {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo bar/ baz/ bang/ {color blue} test clay-0007f {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo dict my_var 10 ::clay::tree::dictset foo dict my_other_var 9 test clay-0007g {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9} ::clay::tree::dictset foo dict/ my_other_other_var 8 test clay-0007h {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9 my_other_other_var 8} ::clay::tree::dictmerge foo {option/ {color {type color} flavor {sense taste}}} ::clay::tree::dictmerge foo {option/ {format {default ascii}}} test clay-0008 {Whole dicts are merged} { dict get $foo option color } {type color} test clay-0009 {Whole dicts are merged} { dict get $foo option flavor } {sense taste} test clay-0010 {Whole dicts are merged} { dict get $foo option format } {default ascii} ### # Tests for the httpd module ### test clay-0010 {Test that leaves are merged properly} set bar {} ::clay::tree::dictmerge bar { proxy/ {port 10101 host myhost.localhost} } ::clay::tree::dictmerge bar { mimetxt {Host: localhost Content_Type: text/plain Content-Length: 15 } http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}} mixin {reply ::test::content.echo} prefix /echo proxy_port 10010 proxy/ {host localhost} } test clay-0011 {Whole dicts are merged} { dict get $bar proxy_port } {10010} test clay-0012 {Whole dicts are merged} { dict get $bar http CONTENT_LENGTH } 15 test clay-0013 {Whole dicts are merged} { dict get $bar proxy host } localhost test clay-0014 {Whole dicts are merged} { dict get $bar proxy port } 10101 ### # Dialect Testing ### ::clay::dialect::create ::alpha proc ::alpha::define::is_alpha {} { dict set ::testinfo([current_class]) is_alpha 1 } ::alpha::define ::alpha::object { is_alpha } ::clay::dialect::create ::bravo ::alpha proc ::bravo::define::is_bravo {} { dict set ::testinfo([current_class]) is_bravo 1 } ::bravo::define ::bravo::object { is_bravo } ::clay::dialect::create ::charlie ::bravo proc ::charlie::define::is_charlie {} { dict set ::testinfo([current_class]) is_charlie 1 } ::charlie::define ::charlie::object { is_charlie } ::clay::dialect::create ::delta ::charlie proc ::delta::define::is_delta {} { dict set ::testinfo([current_class]) is_delta 1 } ::delta::define ::delta::object { is_delta } ::delta::class create adam { is_alpha is_bravo is_charlie is_delta } test oodialect-keyword-001 {Testing keyword application} { set ::testinfo(::adam) } {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1} test oodialect-keyword-002 {Testing keyword application} { set ::testinfo(::alpha::object) } {is_alpha 1} test oodialect-keyword-003 {Testing keyword application} { set ::testinfo(::bravo::object) } {is_bravo 1} test oodialect-keyword-004 {Testing keyword application} { set ::testinfo(::charlie::object) } {is_charlie 1} test oodialect-keyword-005 {Testing keyword application} { set ::testinfo(::delta::object) } {is_delta 1} ### # Declare an object from a namespace ### namespace eval ::test1 { ::alpha::class create a { aliases A is_alpha } ::alpha::define b { aliases B BEE is_alpha } ::alpha::class create ::c { aliases C is_alpha } ::alpha::define ::d { aliases D is_alpha } } test oodialect-naming-001 {Testing keyword application} { set ::testinfo(::test1::a) } {is_alpha 1} test oodialect-naming-002 {Testing keyword application} { set ::testinfo(::test1::b) } {is_alpha 1} test oodialect-naming-003 {Testing keyword application} { set ::testinfo(::c) } {is_alpha 1} test oodialect-naming-004 {Testing keyword application} { set ::testinfo(::d) } {is_alpha 1} test oodialect-aliasing-001 {Testing keyword application} { namespace eval ::test1 { ::alpha::define e { superclass A } } } ::test1::e test oodialect-aliasing-002 {Testing keyword application} { namespace eval ::test1 { ::bravo::define f { superclass A } } } ::test1::f test oodialect-aliasing-003 {Testing aliase method on class} { ::test1::a aliases } {::test1::A} ### # Test modified 2018-10-21 ### test oodialect-ancestry-003 {Testing heritage} { ::clay::ancestors ::test1::f } {} ### # Test modified 2018-10-21 ### test oodialect-ancestry-004 {Testing heritage} { ::clay::ancestors ::alpha::object } {} ### # Test modified 2018-10-21 ### test oodialect-ancestry-005 {Testing heritage} { ::clay::ancestors ::delta::object } {} # ------------------------------------------------------------------------- # clay submodule testing # ------------------------------------------------------------------------- # Test canonical path building set path {const/ foo/ bar/ baz/} test oo-clay-path-0001 "Test path: const foo bar baz" { ::clay::path const foo bar baz } $path test oo-clay-path-0002 "Test path: const/ foo/ bar/ baz" { ::clay::path const/ foo/ bar/ baz } $path test oo-clay-path-0003 "Test path: const/foo/bar/baz" { ::clay::path const/foo/bar/baz } $path test oo-clay-path-0004 "Test path: const/foo bar/baz" { ::clay::path const/foo bar/baz } $path test oo-clay-path-0005 "Test path: const/foo/bar baz" { ::clay::path const/foo/bar baz } $path test oo-clay-path-0006 "Test path: const foo/bar/baz" { ::clay::path const foo/bar/baz } $path test oo-clay-path-0007 "Test path: const foo bar/baz" { ::clay::path const foo bar/baz } $path test oo-clay-path-0008 "Test path: const/foo bar baz" { ::clay::path const/foo bar baz } $path set path {const/ foo/ bar/ baz/ bing} test oo-clay-leaf-0001 "Test leaf: const foo bar baz bing" { ::clay::leaf const foo bar baz bing } $path test oo-clay-leaf-0002 "Test leaf: const/ foo/ bar/ baz/ bing" { ::clay::leaf const/ foo/ bar/ baz/ bing } $path test oo-clay-leaf-0003 "Test leaf: const/foo/bar/baz/bing" { ::clay::leaf const/foo/bar/baz/bing } $path test oo-clay-leaf-0004 "Test leaf: const/foo bar/baz/bing:" { ::clay::leaf const/foo bar/baz/bing: } $path test oo-clay-leaf-0005 "Test leaf: const/foo/bar baz bing" { ::clay::leaf const/foo/bar baz bing } $path test oo-clay-leaf-0006 "Test leaf: const/foo/bar baz bing:" { ::clay::leaf const/foo/bar baz bing: } $path test oo-clay-leaf-0007 "Test leaf: const foo/bar/baz/bing" { ::clay::leaf const foo/bar/baz/bing } $path test oo-clay-leaf-0008 "Test leaf: const foo bar/baz/bing" { ::clay::leaf const foo bar/baz/bing } $path test oo-clay-leaf-0009 "Test leaf: const/foo bar baz bing" { ::clay::leaf const/foo bar baz bing } $path namespace eval ::foo {} clay::define ::foo::classa { clay set const color blue clay set const/flavor strawberry clay set {const/ sound} zoink clay set info/ { animal no building no subelement {pedantic yes} } } test oo-class-clay-method-0001 "Test ::foo::classa const/ color exists" { ::foo::classa clay exists const/ color } 1 test oo-class-clay-method-0001 "Test ::foo::classa const/ color value" { ::foo::classa clay get const/ color } {blue} test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor exists" { ::foo::classa clay exists const/ flavor } 1 test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor value" { ::foo::classa clay get const/ flavor } {strawberry} test oo-class-clay-method-0005 "Test ::foo::classa const/ sound exists" { ::foo::classa clay exists const/ sound } 1 test oo-class-clay-method-0005 "Test ::foo::classa const/ sound value" { ::foo::classa clay get const/ sound } {zoink} test oo-class-clay-method-0007 "Test ::foo::classa info/ animal exists" { ::foo::classa clay exists info/ animal } 1 test oo-class-clay-method-0007 "Test ::foo::classa info/ animal value" { ::foo::classa clay get info/ animal } {no} test oo-class-clay-method-0009 "Test ::foo::classa info/ building exists" { ::foo::classa clay exists info/ building } 1 test oo-class-clay-method-0009 "Test ::foo::classa info/ building value" { ::foo::classa clay get info/ building } {no} test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement exists" { ::foo::classa clay exists info/ subelement } 1 test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement value" { ::foo::classa clay get info/ subelement } {pedantic yes} clay::define ::foo::classb { clay set const/ color black clay set const/ flavor vanilla clay set const/ feeling dread clay set info/ subelement {spoon yes} } test oo-class-clay-method-0013 "Test ::foo::classb const/ color exists" { ::foo::classb clay exists const/ color } 1 test oo-class-clay-method-0013 "Test ::foo::classb const/ color value" { ::foo::classb clay get const/ color } {black} test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor exists" { ::foo::classb clay exists const/ flavor } 1 test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor value" { ::foo::classb clay get const/ flavor } {vanilla} test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling exists" { ::foo::classb clay exists const/ feeling } 1 test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling value" { ::foo::classb clay get const/ feeling } {dread} test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement exists" { ::foo::classb clay exists info/ subelement } 1 test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement value" { ::foo::classb clay get info/ subelement } {spoon yes} clay::define ::foo::class.ab { superclass ::foo::classb ::foo::classa } clay::define ::foo::class.ba { superclass ::foo::classa ::foo::classb } # ------------------------------------------------------------------------- # OBJECT of ::foo::classa set OBJECTA [::foo::classa new] ### # Test object degation ### proc ::foo::fakeobject {a b} { return [expr {$a + $b}] } ::clay::object create TEST TEST clay delegate funct ::foo::fakeobject test oo-object-delegate-001 {Test object delegation} { ::TEST clay delegate } {<class> ::clay::object <funct> ::foo::fakeobject} test oo-object-delegate-002 {Test object delegation} { ::TEST clay delegate funct } {::foo::fakeobject} test oo-object-delegate-002a {Test object delegation} { ::TEST clay delegate <funct> } {::foo::fakeobject} test oo-object-delegate-003 {Test object delegation} { ::TEST <funct> 1 1 } {2} test oo-object-delegate-004 {Test object delegation} { ::TEST <funct> 10 -7 } {3} # Replace the function out from under proc ::foo::fakeobject {a b} { return [expr {$a * $b}] } test oo-object-delegate-005 {Test object delegation} { ::TEST <funct> 10 -7 } {-70} # Object with ::foo::classa mixed in set MIXINA [::oo::object new] oo::objdefine $MIXINA mixin ::foo::classa test oo-object-clay-method-native-0001 {Test native object gets the property const//color} { $OBJECTA clay get const/ color } {blue} test oo-object-clay-method-mixin-0001 {Test mixin object gets the property const//color} { $MIXINA clay get const/ color } {blue} test oo-object-clay-method-native-0002 {Test native object gets the property const//flavor} { $OBJECTA clay get const/ flavor } {strawberry} test oo-object-clay-method-mixin-0002 {Test mixin object gets the property const//flavor} { $MIXINA clay get const/ flavor } {strawberry} test oo-object-clay-method-native-0003 {Test native object gets the property const//sound} { $OBJECTA clay get const/ sound } {zoink} test oo-object-clay-method-mixin-0003 {Test mixin object gets the property const//sound} { $MIXINA clay get const/ sound } {zoink} test oo-object-clay-method-native-0004 {Test native object gets the property info//animal} { $OBJECTA clay get info/ animal } {no} test oo-object-clay-method-mixin-0004 {Test mixin object gets the property info//animal} { $MIXINA clay get info/ animal } {no} test oo-object-clay-method-native-0005 {Test native object gets the property info//building} { $OBJECTA clay get info/ building } {no} test oo-object-clay-method-mixin-0005 {Test mixin object gets the property info//building} { $MIXINA clay get info/ building } {no} test oo-object-clay-method-native-0006 {Test native object gets the property info//subelement} { $OBJECTA clay get info/ subelement } {pedantic yes} test oo-object-clay-method-mixin-0006 {Test mixin object gets the property info//subelement} { $MIXINA clay get info/ subelement } {pedantic yes} # ------------------------------------------------------------------------- # OBJECT of ::foo::classb set OBJECTB [::foo::classb new] # Object with ::foo::classb mixed in set MIXINB [::oo::object new] oo::objdefine $MIXINB mixin ::foo::classb test oo-object-clay-method-native-0007 {Test native object gets the property const//color} { $OBJECTB clay get const/ color } {black} test oo-object-clay-method-mixin-0007 {Test mixin object gets the property const//color} { $MIXINB clay get const/ color } {black} test oo-object-clay-method-native-0008 {Test native object gets the property const//flavor} { $OBJECTB clay get const/ flavor } {vanilla} test oo-object-clay-method-mixin-0008 {Test mixin object gets the property const//flavor} { $MIXINB clay get const/ flavor } {vanilla} test oo-object-clay-method-native-0009 {Test native object gets the property const//feeling} { $OBJECTB clay get const/ feeling } {dread} test oo-object-clay-method-mixin-0009 {Test mixin object gets the property const//feeling} { $MIXINB clay get const/ feeling } {dread} test oo-object-clay-method-native-0010 {Test native object gets the property info//subelement} { $OBJECTB clay get info/ subelement } {spoon yes} test oo-object-clay-method-mixin-0010 {Test mixin object gets the property info//subelement} { $MIXINB clay get info/ subelement } {spoon yes} # ------------------------------------------------------------------------- # OBJECT descended from ::foo::classa ::foo::classb set OBJECTAB [::foo::class.ab new] # Object where classes were mixed in ::foo::classa ::foo::classb set MIXINAB [::oo::object new] # Test modified 2018-10-30, mixin order was wrong before oo::objdefine $MIXINAB mixin ::foo::classb ::foo::classa test oo-object-clay-method-native-0011 {Test native object gets the property const//color} { $OBJECTAB clay get const/ color } {black} test oo-object-clay-method-mixin-0011 {Test mixin object gets the property const//color} { $MIXINAB clay get const/ color } {black} test oo-object-clay-method-native-0012 {Test native object gets the property const//flavor} { $OBJECTAB clay get const/ flavor } {vanilla} test oo-object-clay-method-mixin-0012 {Test mixin object gets the property const//flavor} { $MIXINAB clay get const/ flavor } {vanilla} test oo-object-clay-method-native-0013 {Test native object gets the property const//feeling} { $OBJECTAB clay get const/ feeling } {dread} test oo-object-clay-method-mixin-0013 {Test mixin object gets the property const//feeling} { $MIXINAB clay get const/ feeling } {dread} test oo-object-clay-method-native-0014 {Test native object gets the property const//sound} { $OBJECTAB clay get const/ sound } {zoink} test oo-object-clay-method-mixin-0014 {Test mixin object gets the property const//sound} { $MIXINAB clay get const/ sound } {zoink} test oo-object-clay-method-native-0015 {Test native object gets the property info//subelement} { $OBJECTAB clay get info/ subelement } {spoon yes} test oo-object-clay-method-mixin-0015 {Test mixin object gets the property info//subelement} { $MIXINAB clay get info/ subelement } {spoon yes} test oo-object-clay-method-native-0016 {Test native object gets the property info//animal} { $OBJECTAB clay get info/ animal } {no} test oo-object-clay-method-mixin-0016 {Test mixin object gets the property info//animal} { $MIXINAB clay get info/ animal } {no} test oo-object-clay-method-native-0017 {Test native object gets the property info//building} { $OBJECTAB clay get info/ building } {no} test oo-object-clay-method-mixin-0017 {Test mixin object gets the property info//building} { $MIXINAB clay get info/ building } {no} # ------------------------------------------------------------------------- # OBJECT descended from ::foo::classb ::foo::classa set OBJECTBA [::foo::class.ba new] # Object where classes were mixed in ::foo::classb ::foo::classa set MIXINBA [::oo::object new] # Test modified 2018-10-30, mixin order was wrong before oo::objdefine $MIXINBA mixin ::foo::classa ::foo::classb test oo-object-clay-method-native-0018 {Test native object gets the property} { $OBJECTBA clay get const/ color } {blue} test oo-object-clay-method-mixin-0018 {Test mixin object gets the property} { $MIXINBA clay get const/ color } {blue} test oo-object-clay-method-native-0019 {Test native object gets the property} { $OBJECTBA clay get const/ flavor } {strawberry} test oo-object-clay-method-mixin-0019 {Test mixin object gets the property} { $MIXINBA clay get const/ flavor } {strawberry} test oo-object-clay-method-native-0020 {Test native object gets the property} { $OBJECTBA clay get const/ sound } {zoink} test oo-object-clay-method-mixin-0020 {Test mixin object gets the property} { $MIXINBA clay get const/ sound } {zoink} test oo-object-clay-method-native-0021 {Test native object gets the property} { $OBJECTBA clay get const/ feeling } {dread} test oo-object-clay-method-mixin-0021 {Test mixin object gets the property} { $MIXINBA clay get const/ feeling } {dread} test oo-object-clay-method-native-0022 {Test native object gets the property} { $OBJECTBA clay get info/ animal } {no} test oo-object-clay-method-mixin-0022 {Test mixin object gets the property} { $MIXINBA clay get info/ animal } {no} test oo-object-clay-method-native-0023 {Test native object gets the property} { $OBJECTBA clay get info/ building } {no} test oo-object-clay-method-mixin-0023 {Test mixin object gets the property} { $MIXINBA clay get info/ building } {no} test oo-object-clay-method-native-0024 {Test native object gets the property} { $OBJECTBA clay get info/ subelement } {pedantic yes} test oo-object-clay-method-mixin-0024 {Test mixin object gets the property} { $MIXINBA clay get info/ subelement } {pedantic yes} ### # put a do-nothing constructor on the books ### ::clay::define ::clay::object { constructor args {} } oo::objdefine ::clay::object method foo args { return bar } test clay-core-method-0001 {Test that adding methods to the core ::clay::object class works} { ::clay::object foo } {bar} namespace eval ::TEST {} ::clay::define ::TEST::myclass { clay color red clay flavor strawberry } ### # Test adding a clay property ### test clay-class-clay-0001 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclass clay get color } red test clay-class-clay-0002 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclass clay get flavor } strawberry ### # Test that objects of the class get the same properties ### set OBJ [::clay::object new {}] set OBJ2 [::TEST::myclass new {}] test clay-object-clay-a-0001 {Test that objects not thee class do not get properties} { $OBJ clay get color } {} test clay-object-clay-a-0002 {Test that objects not thee class do not get properties} { $OBJ clay get flavor } {} test clay-object-clay-a-0003 {Test that objects of the class get properties} { $OBJ2 clay get color } red test clay-object-clay-a-0004 {Test that objects of the class get properties} { $OBJ2 clay get flavor } strawberry ### # Test modified 2018-10-21 ### test clay-object-clay-a-0005 {Test the clay ancestors function} { $OBJ clay ancestors } {::clay::object} ### # Test modified 2018-10-21 ### test clay-object-clay-a-0006 {Test the clay ancestors function} { $OBJ2 clay ancestors } {::TEST::myclass ::clay::object} test clay-object-clay-a-0007 {Test the clay provenance function} { $OBJ2 clay provenance flavor } ::TEST::myclass ### # Test that object local setting override the class ### test clay-object-clay-a-0008 {Test that object local setting override the class} { $OBJ2 clay set color purple $OBJ2 clay get color } purple test clay-object-clay-a-0009 {Test that object local setting override the class} { $OBJ2 clay provenance color } self ::clay::define ::TEST::myclasse { superclass ::TEST::myclass clay color blue method do args { return "I did $args" } Ensemble which::color {} { return [my clay get color] } clay set method_ensemble which color aliases farbe } ### # Test clay information is passed town to subclasses ### test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclasse clay get color } blue test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} { ::TEST::myclasse clay get flavor } {} test clay-class-clay-0005 {Test that clay statements from the ancestors of this class are found with the FIND method} { ::TEST::myclasse clay find flavor } {strawberry} ### # Test that properties reach objects ### set OBJ3 [::TEST::myclasse new {}] test clay-object-clay-b-0001 {Test that objects of the class get properties} { $OBJ3 clay get color } blue test clay-object-clay-b-0002 {Test the clay provenance function} { $OBJ3 clay provenance color } ::TEST::myclasse test clay-object-clay-b-0003 {Test that objects of the class get properties} { $OBJ3 clay get flavor } strawberry test clay-object-clay-b-0004 {Test the clay provenance function} { $OBJ3 clay provenance flavor } ::TEST::myclass ### # Test modified 2018-10-21 ### test clay-object-clay-b-0005 {Test the clay provenance function} { $OBJ3 clay ancestors } {::TEST::myclasse ::TEST::myclass ::clay::object} ### # Test defining a standard method ### test clay-object-method-0001 {Test and standard method} { $OBJ3 do this really cool thing } {I did this really cool thing} test clay-object-method-0003 {Test an ensemble} { $OBJ3 which color } blue # Test setting properties test clay-object-method-0004 {Test an ensemble} { $OBJ3 clay set color black $OBJ3 which color } black # Test setting properties test clay-object-method-0004 {Test an ensemble alias} { $OBJ3 which farbe } black ### # Test that if you try to replace a global command you get an error ### test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body { ::clay::define open { method bar {} { return foo } } } -returnCodes {error} -result "::open does not refer to an object" ::clay::define fubar { method bar {} { return foo } } test clay-nspace-0002 {Test a non qualified class ends up in the current namespace} { info commands ::fubar } {::fubar} namespace eval ::cluster { ::clay::define fubar { method bar {} { return foo } } ::clay::define ::clay::pot { method bar {} { return foo } } } test clay-nspace-0003 {Test a non qualified class ends up in the current namespace} { info commands ::cluster::fubar } {::cluster::fubar} test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} { info commands ::clay::pot } {::clay::pot} #set ::clay::trace 3 ### # Mixin tests ### ### # Define a core class ### ::clay::define ::TEST::thing { method do args { return "I did $args" } } ::clay::define ::TEST::vegetable { clay color unknown clay flavor unknown Ensemble which::flavor {} { return [my clay get flavor] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::animal { clay color unknown clay sound unknown Ensemble which::sound {} { return [my clay get sound] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::species.cat { superclass ::TEST::animal clay sound meow } ::clay::define ::TEST::coloring.calico { clay color calico } ::clay::define ::TEST::condition.dark { Ensemble which::color {} { return grey } } ::clay::define ::TEST::mood.happy { Ensemble which::sound {} { return purr } } test clay-object-0001 {Test than an object is created when clay::define is invoked} { info commands ::TEST::mood.happy } ::TEST::mood.happy set OBJ [::TEST::thing new] test clay-mixin-a-0001 {Test that prior to a mixin an ensemble doesn't exist} -body { $OBJ which color } -returnCodes error -result {unknown method "which": must be clay, destroy or do} test clay-mixin-a-0002 {Test and standard method from an ancestor} { $OBJ do this really cool thing } {I did this really cool thing} $OBJ clay mixinmap species ::TEST::animal test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {unknown} test clay-mixin-b-0003 {Test that an ensemble is created during a mixin} -body {$OBJ which flavor} -returnCodes {error} -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-21 ### test clay-mixin-b-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::animal ::TEST::thing ::clay::object} ### # Replacing a mixin replaces the behaviors ### $OBJ clay mixinmap species ::TEST::vegetable test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-c-0002 {Test that an ensemble is created during a mixin} -body {$OBJ which sound} -returnCodes {error} -result {unknown method which sound. Valid: color flavor} test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} { $OBJ which flavor } {unknown} ### # Test Modified: 2018-10-21 ### test clay-mixin-c-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::vegetable ::TEST::thing ::clay::object} ### # Replacing a mixin $OBJ clay mixinmap species ::TEST::species.cat test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} -body {$OBJ which flavor} -returnCodes {error} -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-30, 2018-10-21, 2018-10-10 ### test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} { $OBJ clay ancestors } {::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object} $OBJ clay mixinmap coloring ::TEST::coloring.calico test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {calico} test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-f-0003 {Test that an ensemble is created during a mixin} -body {$OBJ which flavor} -returnCodes {error} -result {unknown method which flavor. Valid: color sound} ### # Test modified 2018-10-30, 2018-10-21, 2018-10-10 ### test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} { $OBJ clay ancestors } {::TEST::coloring.calico ::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object} test clay-mixin-f-0005 {Test that clay data from a mixin works} { $OBJ clay provenance color } {::TEST::coloring.calico} ### # Test variable initialization ### ::clay::define ::TEST::has_var { Variable my_variable 10 method get_my_variable {} { my variable my_variable return $my_variable } } set OBJ [::TEST::has_var new] test clay-class-variable-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get variable/ my_variable } {10} # Modified 2018-10-30 (order is different) test clay-class-variable-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get variable } {my_variable 10 DestroyEvent 0} # Modified 2018-10-30 (order is different) test clay-class-variable-0003 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget variable } {. {} my_variable 10 DestroyEvent 0} test clay-class-variable-0004 {Test that variables declared in the class definition are initialized} { $OBJ get_my_variable } 10 ### # Test array initialization ### ::clay::define ::TEST::has_array { Array my_array {timeout 10} method get_my_array {field} { my variable my_array return $my_array($field) } } set OBJ [::TEST::has_array new] test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get array } {my_array {timeout 10}} test clay-class-array-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget array } {. {} my_array {. {} timeout 10}} test clay-class-array-0003 {Test that variables declared in the class definition are initialized} { $OBJ get_my_array timeout } 10 ::clay::define ::TEST::has_more_array { superclass ::TEST::has_array Array my_array {color blue} } test clay-class-array-0008 {Test that the parser injected the right value in the right place for clay to catch it} { ::TEST::has_more_array clay get array } {my_array {color blue}} test clay-class-array-0009 {Test that the parser injected the right value in the right place for clay to catch it} { ::TEST::has_more_array clay find array } {my_array {timeout 10 color blue}} # Modified 2018-10-30 (order is different) set BOBJ [::TEST::has_more_array new] test clay-class-array-0004 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay get array } {my_array {color blue timeout 10}} # Modified 2018-10-30 (order is different) test clay-class-array-0005 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay dget array } {. {} my_array {. {} color blue timeout 10}} test clay-class-arrau-0006 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_array timeout } 10 test clay-class-arrau-0007 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_array color } blue ::clay::define ::TEST::has_empty_array { Array my_array {} method my_array_exists {} { my variable my_array return [info exists my_array] } method get {field} { my variable my_array return $my_array($field) } method set {field value} { my variable my_array set my_array($field) $value } } test clay-class-array-0008 {Test that an declaration of an array with no values produces and empty array} { set COBJ [::TEST::has_empty_array new] $COBJ my_array_exists } 1 test clay-class-array-0009 {Test that an declaration of an array with no values produces and empty array} { $COBJ set test "A random value" $COBJ get test } {A random value} ### # Test dict initialization ### ::clay::define ::TEST::has_dict { Dict my_dict {timeout 10} method get_my_dict {args} { my variable my_dict if {[llength $args]==0} { return $my_dict } return [dict get $my_dict {*}$args] } } set OBJ [::TEST::has_dict new] test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get dict } {my_dict {timeout 10}} test clay-class-dict-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget dict } {. {} my_dict {. {} timeout 10}} test clay-class-dict-0003 {Test that variables declared in the class definition are initialized} { $OBJ get_my_dict timeout } 10 test clay-class-dict-0004 {Test that an empty dict is annotated} { $OBJ clay get dict } {my_dict {timeout 10}} ::clay::define ::TEST::has_more_dict { superclass ::TEST::has_dict Dict my_dict {color blue} } set BOBJ [::TEST::has_more_dict new] # Modified 2018-10-30 test clay-class-dict-0004 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay get dict } {my_dict {color blue timeout 10}} # Modified 2018-10-30 test clay-class-dict-0005 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay dget dict } {. {} my_dict {. {} color blue timeout 10}} test clay-class-dict-0006 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_dict timeout } 10 test clay-class-dict-0007 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_dict color } blue ::clay::define ::TEST::has_empty_dict { Dict my_empty_dict {} method get_my_empty_dict {args} { my variable my_empty_dict if {[llength $args]==0} { return $my_empty_dict } return [dict get $my_empty_dict {*}$args] } } set COBJ [::TEST::has_empty_dict new] test clay-class-dict-0008 {Test that the parser injected the right value in the right place for clay to catch it} { $COBJ clay dget dict } {my_empty_dict {. {}}} test clay-class-dict-0009 {Test that an empty dict is initialized} { $COBJ get_my_empty_dict } {} ### # Test object delegation ### ::clay::define ::TEST::organelle { method add args { set total 0 foreach item $args { set total [expr {$total+$item}] } return $total } } ::clay::define ::TEST::master { constructor {} { set mysub [namespace current]::sub ::TEST::organelle create $mysub my clay delegate sub $mysub } } set OBJ [::TEST::master new] ### # Test that delegation is working ### test clay-delegation-0001 {Test an array driven ensemble} { $OBJ <sub> add 5 5 } 10 ### # Test the Ensemble keyword ### ::clay::define ::TEST::with_ensemble { Ensemble myensemble {pattern args} { set ensemble [self method] set emap [my clay ensemble_map $ensemble] set mlist [dict keys $emap [string tolower $pattern]] if {[llength $mlist] != 1} { error "Couldn't figure out what to do with $pattern" } set method [lindex $mlist 0] set argspec [dict get $emap $method argspec] set body [dict get $emap $method body] if {$argspec ni {args {}}} { ::clay::dynamic_arguments $ensemble $method [list $argspec] {*}$args } eval $body } Ensemble myensemble::go args { return 1 } } ::clay::define ::TEST::with_ensemble.dance { Ensemble myensemble::dance args { return 1 } } ::clay::define ::TEST::with_ensemble.cannot_dance { Ensemble myensemble::dance args { return 0 } } set OBJA [::clay::object new] set OBJB [::clay::object new] $OBJA clay mixinmap core ::TEST::with_ensemble friends ::TEST::with_ensemble.dance $OBJB clay mixinmap core ::TEST::with_ensemble friends ::TEST::with_ensemble.cannot_dance # Test go test clay-dynamic-ensemble-0001 {Test ensemble with static method} { $OBJA myensemble go } {1} test clay-dynamic-ensemble-0002 {Test ensemble with static method} { $OBJB myensemble go } {1} # Test dance test clay-dynamic-ensemble-0003 {Test ensemble with static method} { $OBJA myensemble dance } {1} test clay-dynamic-ensemble-0004 {Test ensemble with static method} { $OBJB myensemble dance } {0} ### # Class method testing ### clay::class create WidgetClass { Class_Method working {} { return {Works} } Class_Method unknown args { set tkpath [lindex $args 0] if {[string index $tkpath 0] eq "."} { set obj [my new $tkpath {*}[lrange $args 1 end]] $obj tkalias $tkpath return $tkpath } next {*}$args } constructor {TkPath args} { my variable hull set hull $TkPath my clay delegate hull $TkPath } method tkalias tkname { set oldname $tkname my variable tkalias set tkalias $tkname set self [self] set hullwidget [::info object namespace $self]::tkwidget my clay delegate tkwidget $hullwidget #rename ::$tkalias $hullwidget my clay delegate hullwidget $hullwidget #::tool::object_rename [self] ::$tkalias rename [self] ::$tkalias #my Hull_Bind $tkname return $hullwidget } } test tool-class-method-000 {Test that class methods actually work...} { WidgetClass working } {Works} test tool-class-method-001 {Test Tk style creator} { WidgetClass .foo .foo clay delegate hull } {.foo} ::clay::define WidgetNewClass { superclass WidgetClass } test tool-class-method-002 {Test Tk style creator inherited by morph} { WidgetNewClass .bar .bar clay delegate hull } {.bar} ### # Test ensemble inheritence ### clay::define NestedClassA { Ensemble do::family {} { return NestedClassA } Ensemble do::something {} { return A } Ensemble do::whop {} { return A } } clay::define NestedClassB { superclass NestedClassA Ensemble do::family {} { set r [next family] lappend r NestedClassB return $r } Ensemble do::whop {} { return B } } clay::define NestedClassC { superclass NestedClassB Ensemble do::somethingelse {} { return C } } clay::define NestedClassD { superclass NestedClassB Ensemble do::somethingelse {} { return D } } clay::define NestedClassE { superclass NestedClassD NestedClassC } clay::define NestedClassF { superclass NestedClassC NestedClassD } NestedClassC create NestedObjectC ### # These tests no longer work because method ensembles are now dynamically # generated by object, that are not attached to the class anymore # #### #test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} { # NestedObjectC do family #} {::NestedClassA ::NestedClassB ::NestedClassC} test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} { NestedObjectC do whop } {B} test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} { NestedObjectC do something } {A} NestedClassE create NestedObjectE NestedClassF create NestedObjectF test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} { NestedObjectE do somethingelse } {D} test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} { NestedObjectF do somethingelse } {C} ### # Set of tests to exercise the mixinmap system ### clay::define MixinMainClass { Variable mainvar unchanged Ensemble test::which {} { my variable mainvar return $mainvar } Ensemble test::main args { puts [list this is main $method $args] } } set mixoutscript {my test untool $class} set mixinscript {my test tool $class} clay::define MixinTool { Variable toolvar unchanged.mixin clay set mixin/ unmap-script $mixoutscript clay set mixin/ map-script $mixinscript clay set mixin/ name {Generic Tool} Ensemble test::untool class { my variable toolvar mainvar set mainvar {} set toolvar {} } Ensemble test::tool class { my variable toolvar mainvar set mainvar [$class clay get mixin name] set toolvar [$class clay get mixin name] } } clay::define MixinToolA { superclass MixinTool clay set mixin/ name {Tool A} } clay::define MixinToolB { superclass MixinTool clay set mixin/ name {Tool B} method test_newfunc {} { return "B" } } test tool-mixinspec-001 {Test application of mixin specs} { MixinTool clay get mixin map-script } $mixinscript test tool-mixinspec-002 {Test application of mixin specs} { MixinToolA clay get mixin map-script } {} test tool-mixinspec-003 {Test application of mixin specs} { MixinToolA clay find mixin map-script } $mixinscript test tool-mixinspec-004 {Test application of mixin specs} { MixinToolB clay find mixin map-script } $mixinscript MixinMainClass create mixintest test tool-mixinmap-001 {Test object prior to mixins} { mixintest test which } {unchanged} mixintest clay mixinmap tool MixinToolA test tool-mixinmap-002 {Test mixin map script ran} { mixintest test which } {Tool A} mixintest clay mixinmap tool MixinToolB test tool-mixinmap-003 {Test mixin map script ran} { mixintest test which } {Tool B} test tool-mixinmap-003 {Test mixin map script ran} { mixintest test_newfunc } {B} mixintest clay mixinmap tool {} test tool-mixinmap-004 {Test object prior to mixins} { mixintest test which } {} clay::define ::clay::object { method path {} { return [self class] } } clay::define ::MixinRoot { clay set opts core root clay set opts option unset clay set opts color unset Ensemble info::root {} { return MixinRoot } Ensemble info::shade {} { return avacodo } Ensemble info::default {} { return Undefined } method did {} { return MixinRoot } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinOption1 { clay set opts option option1 Ensemble info::option {} { return MixinOption1 } Ensemble info::other {} { return MixinOption1 } method did {} { return MixinOption1 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinOption2 { superclass ::MixinOption1 clay set opts option option2 Ensemble info::option {} { return MixinOption2 } method did {} { return MixinOption2 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinColor1 { clay set opts color blue Ensemble info::color {} { return MixinColor1 } Ensemble info::shade {} { return blue } method did {} { return MixinColor1 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinColor2 { clay set opts color green Ensemble info::color {} { return MixinColor2 } Ensemble info::shade {} { return green } method did {} { return MixinColor2 } method path {} { return [list [self class] {*}[next]] } } set obj [clay::object new] $obj clay mixinmap root ::MixinRoot test tool-prototype-0001-0001 {Mixin core} { $obj info root } {MixinRoot} test tool-prototype-0001-0002 {Mixin core} { $obj info option } {Undefined} test tool-prototype-0001-0003 {Mixin core} { $obj info color } {Undefined} test tool-prototype-0001-0004 {Mixin core} { $obj info other } {Undefined} test tool-prototype-0001-0005 {Mixin core} { $obj info shade } {avacodo} test tool-prototype-0001-0006 {Mixin core} { $obj did } {MixinRoot} test tool-prototype-0001-0007 {Mixin core} { $obj path } {::MixinRoot ::clay::object} test tool-prototype-0001-0008 {Mixin core} { $obj clay get opts } {core root option unset color unset} test tool-prototype-0001-0009 {Mixin core} { $obj clay get opts core } {root} test tool-prototype-0001-0010 {Mixin core} { $obj clay get opts option } {unset} test tool-prototype-0001-0011 {Mixin core} { $obj clay get opts color } {unset} test tool-prototype-0001-0012 {Mixin core} { $obj clay ancestors } {::MixinRoot ::clay::object} $obj clay mixinmap option ::MixinOption1 test tool-prototype-0002-0001 {Mixin option1} { $obj info root } {MixinRoot} test tool-prototype-0002-0002 {Mixin option1} { $obj info option } {MixinOption1} test tool-prototype-0002-0003 {Mixin option1} { $obj info color } {Undefined} test tool-prototype-0002-0004 {Mixin option1} { $obj info other } {MixinOption1} test tool-prototype-0002-0005 {Mixin option1} { $obj info shade } {avacodo} test tool-prototype-0002-0006 {Mixin option1} { $obj did } {MixinOption1} test tool-prototype-0002-0007 {Mixin option1} { $obj path } {::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0002-0008 {Mixin option1} { $obj clay get opts } {option option1 core root color unset} test tool-prototype-0002-0009 {Mixin option1} { $obj clay get opts core } {root} test tool-prototype-0002-0010 {Mixin option1} { $obj clay get opts option } {option1} test tool-prototype-0002-0011 {Mixin option1} { $obj clay get opts color } {unset} test tool-prototype-0002-0012 {Mixin option1} { $obj clay ancestors } {::MixinOption1 ::MixinRoot ::clay::object} set obj2 [clay::object new] $obj2 clay mixinmap root ::MixinRoot option ::MixinOption1 $obj clay mixinmap option ::MixinOption1 test tool-prototype-0003-0001 {Mixin option1 - clean object} { $obj2 info root } {MixinRoot} test tool-prototype-0003-0002 {Mixin option1 - clean object} { $obj2 info option } {MixinOption1} test tool-prototype-0003-0003 {Mixin option1 - clean object} { $obj2 info color } {Undefined} test tool-prototype-0003-0004 {Mixin option1 - clean object} { $obj2 info other } {MixinOption1} test tool-prototype-0003-0005 {Mixin option1 - clean object} { $obj2 info shade } {avacodo} test tool-prototype-0003-0006 {Mixin option1 - clean object} { $obj2 did } {MixinOption1} test tool-prototype-0003-0007 {Mixin option1 - clean object} { $obj2 path } {::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0003-0008 {Mixin option1 - clean object} { $obj2 clay get opts } {option option1 core root color unset} test tool-prototype-0003-0009 {Mixin option1 - clean object} { $obj2 clay get opts core } {root} test tool-prototype-0003-0010 {Mixin option1 - clean object} { $obj2 clay get opts option } {option1} test tool-prototype-0003-0011 {Mixin option1 - clean object} { $obj2 clay get opts color } {unset} test tool-prototype-0003-0012 {Mixin option1 - clean object} { $obj2 clay ancestors } {::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap option ::MixinOption2 test tool-prototype-0004-0001 {Mixin option2} { $obj info root } {MixinRoot} test tool-prototype-0004-0002 {Mixin option2} { $obj info option } {MixinOption2} test tool-prototype-0004-0003 {Mixin option2} { $obj info color } {Undefined} test tool-prototype-0004-0004 {Mixin option2} { $obj info other } {MixinOption1} test tool-prototype-0004-0005 {Mixin option2} { $obj info shade } {avacodo} test tool-prototype-0004-0006 {Mixin option2} { $obj did } {MixinOption2} test tool-prototype-0004-0007 {Mixin option2} { $obj path } {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0004-0008 {Mixin option2} { $obj clay get opts } {option option2 core root color unset} test tool-prototype-0004-0009 {Mixin option2} { $obj clay get opts core } {root} test tool-prototype-0004-0010 {Mixin option2} { $obj clay get opts option } {option2} test tool-prototype-0004-0011 {Mixin option2} { $obj clay get opts color } {unset} test tool-prototype-0004-0012 {Mixin option2} { $obj clay ancestors } {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap color MixinColor1 test tool-prototype-0005-0001 {Mixin color1} { $obj info root } {MixinRoot} test tool-prototype-0005-0002 {Mixin color1} { $obj info option } {MixinOption2} test tool-prototype-0005-0003 {Mixin color1} { $obj info color } {MixinColor1} test tool-prototype-0005-0004 {Mixin color1} { $obj info other } {MixinOption1} test tool-prototype-0005-0005 {Mixin color1} { $obj info shade } {blue} test tool-prototype-0005-0006 {Mixin color1} { $obj did } {MixinColor1} test tool-prototype-0005-0007 {Mixin color1} { $obj path } {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0005-0008 {Mixin color1} { $obj clay get opts } {color blue option option2 core root} test tool-prototype-0005-0009 {Mixin color1} { $obj clay get opts core } {root} test tool-prototype-0005-0010 {Mixin color1} { $obj clay get opts option } {option2} test tool-prototype-0005-0011 {Mixin color1} { $obj clay get opts color } {blue} test tool-prototype-0005-0012 {Mixin color1} { $obj clay ancestors } {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap color MixinColor2 test tool-prototype-0006-0001 {Mixin color2} { $obj info root } {MixinRoot} test tool-prototype-0006-0002 {Mixin color2} { $obj info option } {MixinOption2} test tool-prototype-0006-0003 {Mixin color2} { $obj info color } {MixinColor2} test tool-prototype-0006-0004 {Mixin color2} { $obj info other } {MixinOption1} test tool-prototype-0006-0005 {Mixin color2} { $obj info shade } {green} test tool-prototype-0006-0006 {Mixin color2} { $obj clay get opts } {color green option option2 core root} test tool-prototype-0006-0007 {Mixin color2} { $obj clay get opts core } {root} test tool-prototype-0006-0008 {Mixin color2} { $obj clay get opts option } {option2} test tool-prototype-0006-0009 {Mixin color2} { $obj clay get opts color } {green} test tool-prototype-0006-0010 {Mixin color2} { $obj clay ancestors } {::MixinColor2 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap option MixinOption1 test tool-prototype-0007-0001 {Mixin color2 + Option1} { $obj info root } {MixinRoot} test tool-prototype-0007-0002 {Mixin color2 + Option1} { $obj info option } {MixinOption1} test tool-prototype-0007-0003 {Mixin color2 + Option1} { $obj info color } {MixinColor2} test tool-prototype-0007-0004 {Mixin color2 + Option1} { $obj info other } {MixinOption1} test tool-prototype-0007-0005 {Mixin color2 + Option1} { $obj info shade } {green} test tool-prototype-0007-0006 {Mixin color2 + Option1} { $obj clay get opts } {color green option option1 core root} test tool-prototype-0007-0007 {Mixin color2 + Option1} { $obj clay get opts core } {root} test tool-prototype-0007-0008 {Mixin color2 + Option1} { $obj clay get opts option } {option1} test tool-prototype-0007-0009 {Mixin color2 + Option1} { $obj clay get opts color } {green} test tool-prototype-0007-0010 {Mixin color2 + Option1} { $obj clay ancestors } {::MixinColor2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap option {} test tool-prototype-0008-0001 {Mixin color2 + no option} { $obj info root } {MixinRoot} test tool-prototype-0008-0002 {Mixin color2 + no option} { $obj info option } {Undefined} test tool-prototype-0008-0003 {Mixin color2 + no option} { $obj info color } {MixinColor2} test tool-prototype-0008-0004 {Mixin color2 + no option} { $obj info other } {Undefined} test tool-prototype-0008-0005 {Mixin color2 + no option} { $obj info shade } {green} test tool-prototype-0008-0006 {Mixin color2 + no option} { $obj clay get opts } {color green core root option unset} test tool-prototype-0008-0007 {Mixin color2 + no option} { $obj clay get opts core } {root} test tool-prototype-0008-0008 {Mixin color2 + no option} { $obj clay get opts option } {unset} test tool-prototype-0008-0009 {Mixin color2 + no option} { $obj clay get opts color } {green} test tool-prototype-0008-0010 {Mixin color2 + no option} { $obj clay ancestors } {::MixinColor2 ::MixinRoot ::clay::object} $obj clay mixinmap color {} test tool-prototype-0009-0001 {Mixin core (return to normal)} { $obj info root } {MixinRoot} test tool-prototype-0009-0002 {Mixin core (return to normal)} { $obj info option } {Undefined} test tool-prototype-0009-0003 {Mixin core (return to normal)} { $obj info color } {Undefined} test tool-prototype-0009-0004 {Mixin core (return to normal)} { $obj info other } {Undefined} test tool-prototype-0009-0005 {Mixin core (return to normal)} { $obj info shade } {avacodo} test tool-prototype-0009-0006 {Mixin core (return to normal)} { $obj clay get opts } {core root option unset color unset} test tool-prototype-0009-0007 {Mixin core (return to normal)} { $obj clay get opts core } {root} test tool-prototype-0009-0008 {Mixin core (return to normal)} { $obj clay get opts option } {unset} test tool-prototype-0009-0009 {Mixin core (return to normal)} { $obj clay get opts color } {unset} test tool-prototype-0009-0010 {Mixin core (return to normal)} { $obj clay ancestors } {::MixinRoot ::clay::object} ### # Tip479 Tests ### clay::define tip479class { Method newitem dictargs { id {type: number} color {default: green} shape {options: {round square}} flavor {default: grape} } { my variable items foreach {f v} $args { dict set items $id $f $v } if {"color" ni [dict keys $args]} { dict set items $id color $color } return [dict get $items $id] } method itemget {id field} { my variable items return [dict get $id $field] } } set obj [tip479class new] test tip479-001 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 1 color orange shape round } {id 1 color orange shape round} # Fail because we left off a mandatory argument test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -errorCode NONE -body { $obj newitem id 2 } -result {shape is required} ### # Leave off a value that has a default # note: Method had special handling for color, but not flavor ### test tip479-003 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 3 shape round } {id 3 shape round color green} ### # Add extra arguments ### test tip479-004 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 4 shape round trim leather } {id 4 shape round trim leather color green} clay::define tip479classE { Ensemble item::new dictargs { id {type: number} color {default: green} shape {options: {round square}} flavor {default: grape} } { my variable items foreach {f v} $args { dict set items $id $f $v } if {"color" ni [dict keys $args]} { dict set items $id color $color } return [dict get $items $id] } Ensemble item::get {id field} { my variable items return [dict get $id $field] } } set obj [tip479classE new] test tip479-001 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 1 color orange shape round } {id 1 color orange shape round} # Fail because we left off a mandatory argument test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -errorCode NONE -body { $obj item new id 2 } -result {shape is required} ### # Leave off a value that has a default # note: Method had special handling for color, but not flavor ### test tip479-003 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 3 shape round } {id 3 shape round color green} ### # Add extra arguments ### test tip479-004 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 4 shape round trim leather } {id 4 shape round trim leather color green} testsuiteCleanup # Local variables: # mode: tcl # indent-tabs-mode: nil # End: if {![package vsatisfies [package provide Tcl] 8.7]} {return} puts "Repeating tests with 8.7 features" namespace eval ::oo::dialect {} set ::oo::dialect::has(tip470) 1 # clay.test - Copyright (c) 2018 Sean Woods # ------------------------------------------------------------------------- set MODDIR [file dirname [file dirname [file join [pwd] [info script]]]] if {[file exists [file join $MODDIR devtools testutilities.tcl]]} { # Running inside tcllib set TCLLIBMOD $MODDIR } else { set TCLLIBMOD [file join $MODDIR .. .. tcllib modules] } source [file join $TCLLIBMOD devtools testutilities.tcl] testsNeedTcl 8.6 testsNeedTcltest 2 testsNeed TclOO 1 support {} testing { useLocal clay.tcl clay } set ::clay::trace 0 # ------------------------------------------------------------------------- # Handle multiple implementation testing # array set preserve [array get ::clay::uuid::accel] proc implementations {} { variable ::clay::uuid::accel foreach {a v} [array get accel] {if {$v} {lappend r $a}} lappend r tcl; set r } proc select_implementation {impl} { variable ::clay::uuid::accel foreach e [array names accel] { set accel($e) 0 } if {[string compare "tcl" $impl] != 0} { set accel($impl) 1 } } proc reset_implementation {} { variable ::clay::uuid::accel array set accel [array get ::preserve] } # ------------------------------------------------------------------------- # Setup any constraints # # ------------------------------------------------------------------------- # Now the package specific tests.... # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- foreach impl [implementations] { select_implementation $impl test uuid-1.0-$impl "uuid requires args" { list [catch {clay::uuid} msg] } {1} test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" { list [catch {string length [clay::uuid generate]} msg] $msg } {0 36} test uuid-1.2-$impl "uuid comparison of uuid with self should be true" { list [catch { set a [clay::uuid generate] clay::uuid equal $a $a } msg] $msg } {0 1} test uuid-1.3-$impl "uuid comparison of two different uuids should be false" { list [catch { set a [clay::uuid generate] set b [clay::uuid generate] clay::uuid equal $a $b } msg] $msg } {0 0} reset_implementation } # Modification History: ### # Modification 2018-10-30 # Fixed an error in our ancestry mapping and developed tests to # ensure we are actually following in the order TclOO follows methods ### # Modification 2018-10-21 # The clay metaclass no longer exports the clay method # to oo::class and oo::object, and clay::ancestors no # longer returns any class that lacks the clay method ### # Modification 2018-10-10 # clay::ancestors now rigged to descend into all classes depth-first # and then place metaclasses at the end of the search ### # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- # Test Helpers ### proc dict_compare {a b} { set result {} set A {} dict for {f v} $a { set f [string trim $f :/] if {$f eq {.}} continue dict set A $f $v } set B {} dict for {f v} $b { set f [string trim $f :/] if {$f eq {.}} continue dict set B $f $v } dict for {f v} $A { if {[dict exists $B $f]} { if {[dict get $B $f] ne $v} { lappend result [list B $f [dict get $B $f] [list != $v]] } } else { lappend result [list B $f $v missing] } } dict for {f v} $B { if {![dict exists $A $f]} { lappend result [list A $f $v missing] } } return $result } test dict-compare-001 {Test our testing method} { dict_compare {} {} } {} test dict-compare-002 {Test our testing method} { dict_compare {a 1} {} } {{B a 1 missing}} test dict-compare-003 {Test our testing method} { dict_compare {a 1 b 2} {a 1 b 2} } {} test dict-compare-003.a {Test our testing method} { dict_compare {a 1 b 2} {b 2 a 1 } } {} test dict-compare-003.b {Test our testing method} { dict_compare {b 2 a 1} {a 1 b 2} } {} test dict-compare-004 {Test our testing method} { dict_compare {a: 1 b: 2} {a 1 b 2} } {} test dict-compare-005 {Test our testing method} { dict_compare {a 1 b 3} {a 1 b 2} } {{B b 2 {!= 3}}} ### # Test canonical mapping ### test {test-storage-0001} {Test ::clay::tree::storage with foo bar baz} { clay::tree::storage {foo bar baz} } {foo bar baz} test {test-storage-0002} {Test ::clay::tree::storage with foo bar baz/} { clay::tree::storage {foo bar baz/} } {foo bar baz} test {test-storage-0003} {Test ::clay::tree::storage with foo bar .} { clay::tree::storage {foo bar .} } {foo bar .} test {test-storage-0004} {Test ::clay::tree::storage with foo/ bar/ .} { clay::tree::storage {foo/ bar/ .} } {foo bar .} test {test-storage-0005} {Test ::clay::tree::storage with foo . bar . baz .} { clay::tree::storage {foo . bar . baz .} } {foo . bar . baz .} test {test-storage-0006} {Test ::clay::tree::storage with foo bar baz bat:} { clay::tree::storage {foo bar baz bat:} } {foo bar baz bat:} test {test-storage-0007} {Test ::clay::tree::storage with foo:} { clay::tree::storage {foo:} } {foo:} test {test-storage-0008} {Test ::clay::tree::storage with foo/bar/baz/bat:} { clay::tree::storage {foo/bar/baz/bat:} } {foo bar baz bat:} dict set r foo/ bar/ baz 1 dict set s foo/ bar/ baz 0 set t [clay::tree::merge $r $s] test rmerge-0001 {Test that the root is marked as a branch} { dict get $t foo bar baz } 0 set r [dict create] clay::tree::dictmerge r { foo/ { bar/ { baz 1 bing: 2 bang { bim 3 boom 4 } womp: {a 1 b 2} } } } test dictmerge-0001 {Test that the root is marked as a branch} { dict exists $r . } 1 test dictmerge-0002 {Test that branch foo is marked correctly} { dict exists $r foo . } 1 test dictmerge-0003 {Test that branch bar is marked correctly} { dict exists $r foo bar . } 1 test dictmerge-0004 {Test that leaf foo/bar/bang is not marked as branch despite being a dict} { dict exists $r foo bar bang . } 0 test dictmerge-0004 {Test that leaf foo/bar/bang/bim exists} { dict exists $r foo bar bang bim } 1 test dictmerge-0005 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 1 ### # Replace bang with bang/ ### clay::tree::dictmerge r { foo/ { bar/ { bang/ { whoop 1 } } } } test dictmerge-0006 {Test that leaf foo/bar/bang/bim ceases to exist} { dict exists $r foo bar bang bim } 0 test dictmerge-0007 {Test that leaf foo/bar/bang/boom exists} { dict exists $r foo bar bang boom } 0 test dictmerge-0008 {Test that leaf foo/bar/bang is now a branch} { dict exists $r foo bar bang . } 1 test branch-0001 {Test that foo/ is a branch} { clay::tree::is_branch $r foo/ } 1 test branch-0002 {Test that foo is a branch} { clay::tree::is_branch $r foo } 1 test branch-0003 {Test that foo/bar/ is a branch} { clay::tree::is_branch $r {foo/ bar/} } 1 test branch-0004 {Test that foo bar is not branch} { clay::tree::is_branch $r {foo bar} } 1 test branch-0004 {Test that foo/ bar is not branch} { clay::tree::is_branch $r {foo/ bar} } 0 test {test-branch-0001} {Test that foo is_branch = 1} { clay::tree::is_branch $r { foo} } 1 test {test-branch-0002} {Test that foo: is_branch = 0} { clay::tree::is_branch $r { foo:} } 0 test {test-branch-0003} {Test that foo/ is_branch = 1} { clay::tree::is_branch $r { foo/} } 1 test {test-branch-0004} {Test that .foo is_branch = 0} { clay::tree::is_branch $r { .foo} } 0 test {test-branch-0005} {Test that foo bar is_branch = 1} { clay::tree::is_branch $r {foo bar} } 1 test {test-branch-0006} {Test that foo bar: is_branch = 0} { clay::tree::is_branch $r {foo bar:} } 0 test {test-branch-0007} {Test that foo bar/ is_branch = 1} { clay::tree::is_branch $r {foo bar/} } 1 test {test-branch-0008} {Test that foo .bar is_branch = 0} { clay::tree::is_branch $r {foo .bar} } 0 test {test-branch-0009} {Test that foo bar baz is_branch = 0} { clay::tree::is_branch $r {foo bar baz} } 0 test {test-branch-0010} {Test that foo bar baz: is_branch = 0} { clay::tree::is_branch $r {foo bar baz:} } 0 test {test-branch-0011} {Test that foo bar baz/ is_branch = 1} { clay::tree::is_branch $r {foo bar baz/} } 1 test {test-branch-0012} {Test that foo bar .baz is_branch = 0} { clay::tree::is_branch $r {foo bar .baz} } 0 test {test-branch-0013} {Test that foo bar bing is_branch = 0} { clay::tree::is_branch $r {foo bar bing} } 0 test {test-branch-0014} {Test that foo bar bing: is_branch = 0} { clay::tree::is_branch $r {foo bar bing:} } 0 test {test-branch-0015} {Test that foo bar bing/ is_branch = 1} { clay::tree::is_branch $r {foo bar bing/} } 1 test {test-branch-0016} {Test that foo bar .bing is_branch = 0} { clay::tree::is_branch $r {foo bar .bing} } 0 test {test-branch-0017} {Test that foo bar bang is_branch = 1} { clay::tree::is_branch $r {foo bar bang} } 1 test {test-branch-0018} {Test that foo bar bang: is_branch = 0} { clay::tree::is_branch $r {foo bar bang:} } 0 test {test-branch-0019} {Test that foo bar bang/ is_branch = 1} { clay::tree::is_branch $r {foo bar bang/} } 1 test {test-branch-0020} {Test that foo bar .bang is_branch = 0} { clay::tree::is_branch $r {foo bar .bang} } 0 test {test-branch-0021} {Test that foo bar bang whoop is_branch = 0} { clay::tree::is_branch $r {foo bar bang whoop} } 0 test {test-branch-0022} {Test that foo bar bang whoop: is_branch = 0} { clay::tree::is_branch $r {foo bar bang whoop:} } 0 test {test-branch-0023} {Test that foo bar bang whoop/ is_branch = 1} { clay::tree::is_branch $r {foo bar bang whoop/} } 1 test {test-branch-0024} {Test that foo bar bang .whoop is_branch = 0} { clay::tree::is_branch $r {foo bar bang .whoop} } 0 # ------------------------------------------------------------------------- # dictmerge Testing - oometa unset -nocomplain foo clay::tree::dictmerge foo { option/ { color/ { label Color default green } } } clay::tree::dictmerge foo { option/ { color/ { default purple } } } test oometa-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color default } purple test oometa-0002 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { dict get $foo option color label } Color unset -nocomplain foo set foo {. {}} ::clay::tree::dictmerge foo {. {} color {. {} default green label Color}} ::clay::tree::dictmerge foo {. {} color {. {} default purple}} test oometa-0003 {Recursive merge problem from oometa/clay find} { dict get $foo color default } purple test oometa-0004 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color unset -nocomplain foo set foo {. {}} ::clay::tree::dictmerge foo {. {} color {. {} default purple}} ::clay::tree::dictmerge foo {. {} color {. {} default green label Color}} test oometa-0005 {Recursive merge problem from oometa/clay find} { dict get $foo color default } green test oometa-0006 {Recursive merge problem from oometa/clay find} { dict get $foo color label } Color test oometa-0008 {Un-Sanitized output} { set foo } {. {} color {. {} default green label Color}} test oometa-0009 {Sanitize} { clay::tree::sanitize $foo } {color {default green label Color}} # ------------------------------------------------------------------------- # dictmerge Testing - clay unset -nocomplain foo test clay-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} { ::clay::tree::dictmerge foo set foo } {. {}} unset -nocomplain foo ::clay::tree::dictset foo bar/ baz/ bell bang test clay-0002 {For new entries dictmerge is essentially a set} { dict get $foo bar baz bell } {bang} ::clay::tree::dictset foo bar/ baz/ boom/ bang test clay-0003 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz bell } {bang} test clay-0004 {For entries that do exist a zipper merge is performed} { dict get $foo bar baz boom } {bang} ::clay::tree::dictset foo bar/ baz/ bop {color green flavor strawberry} test clay-0005 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color green flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bop {color yellow} test clay-0006 {Leaves are replaced even if they look like a dict} { dict get $foo bar baz bop } {color yellow} ::clay::tree::dictset foo bar/ baz/ bang/ {color green flavor strawberry} test clay-0007a {Branches are merged} { dict get $foo bar baz bang } {. {} color green flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ color yellow test clay-0007b {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ {color blue} test clay-0007c {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry} ::clay::tree::dictset foo bar/ baz/ bang/ shape: {Sort of round} test clay-0007d {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo bar/ baz/ bang/ color yellow test clay-0007e {Branches are merged} { dict get $foo bar baz bang } {. {} color yellow flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo bar/ baz/ bang/ {color blue} test clay-0007f {Branches are merged} { dict get $foo bar baz bang } {. {} color blue flavor strawberry shape: {Sort of round}} ::clay::tree::dictset foo dict my_var 10 ::clay::tree::dictset foo dict my_other_var 9 test clay-0007g {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9} ::clay::tree::dictset foo dict/ my_other_other_var 8 test clay-0007h {Branches are merged} { dict get $foo dict } {. {} my_var 10 my_other_var 9 my_other_other_var 8} ::clay::tree::dictmerge foo {option/ {color {type color} flavor {sense taste}}} ::clay::tree::dictmerge foo {option/ {format {default ascii}}} test clay-0008 {Whole dicts are merged} { dict get $foo option color } {type color} test clay-0009 {Whole dicts are merged} { dict get $foo option flavor } {sense taste} test clay-0010 {Whole dicts are merged} { dict get $foo option format } {default ascii} ### # Tests for the httpd module ### test clay-0010 {Test that leaves are merged properly} set bar {} ::clay::tree::dictmerge bar { proxy/ {port 10101 host myhost.localhost} } ::clay::tree::dictmerge bar { mimetxt {Host: localhost Content_Type: text/plain Content-Length: 15 } http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}} mixin {reply ::test::content.echo} prefix /echo proxy_port 10010 proxy/ {host localhost} } test clay-0011 {Whole dicts are merged} { dict get $bar proxy_port } {10010} test clay-0012 {Whole dicts are merged} { dict get $bar http CONTENT_LENGTH } 15 test clay-0013 {Whole dicts are merged} { dict get $bar proxy host } localhost test clay-0014 {Whole dicts are merged} { dict get $bar proxy port } 10101 ### # Dialect Testing ### ::clay::dialect::create ::alpha proc ::alpha::define::is_alpha {} { dict set ::testinfo([current_class]) is_alpha 1 } ::alpha::define ::alpha::object { is_alpha } ::clay::dialect::create ::bravo ::alpha proc ::bravo::define::is_bravo {} { dict set ::testinfo([current_class]) is_bravo 1 } ::bravo::define ::bravo::object { is_bravo } ::clay::dialect::create ::charlie ::bravo proc ::charlie::define::is_charlie {} { dict set ::testinfo([current_class]) is_charlie 1 } ::charlie::define ::charlie::object { is_charlie } ::clay::dialect::create ::delta ::charlie proc ::delta::define::is_delta {} { dict set ::testinfo([current_class]) is_delta 1 } ::delta::define ::delta::object { is_delta } ::delta::class create adam { is_alpha is_bravo is_charlie is_delta } test oodialect-keyword-001 {Testing keyword application} { set ::testinfo(::adam) } {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1} test oodialect-keyword-002 {Testing keyword application} { set ::testinfo(::alpha::object) } {is_alpha 1} test oodialect-keyword-003 {Testing keyword application} { set ::testinfo(::bravo::object) } {is_bravo 1} test oodialect-keyword-004 {Testing keyword application} { set ::testinfo(::charlie::object) } {is_charlie 1} test oodialect-keyword-005 {Testing keyword application} { set ::testinfo(::delta::object) } {is_delta 1} ### # Declare an object from a namespace ### namespace eval ::test1 { ::alpha::class create a { aliases A is_alpha } ::alpha::define b { aliases B BEE is_alpha } ::alpha::class create ::c { aliases C is_alpha } ::alpha::define ::d { aliases D is_alpha } } test oodialect-naming-001 {Testing keyword application} { set ::testinfo(::test1::a) } {is_alpha 1} test oodialect-naming-002 {Testing keyword application} { set ::testinfo(::test1::b) } {is_alpha 1} test oodialect-naming-003 {Testing keyword application} { set ::testinfo(::c) } {is_alpha 1} test oodialect-naming-004 {Testing keyword application} { set ::testinfo(::d) } {is_alpha 1} test oodialect-aliasing-001 {Testing keyword application} { namespace eval ::test1 { ::alpha::define e { superclass A } } } ::test1::e test oodialect-aliasing-002 {Testing keyword application} { namespace eval ::test1 { ::bravo::define f { superclass A } } } ::test1::f test oodialect-aliasing-003 {Testing aliase method on class} { ::test1::a aliases } {::test1::A} ### # Test modified 2018-10-21 ### test oodialect-ancestry-003 {Testing heritage} { ::clay::ancestors ::test1::f } {} ### # Test modified 2018-10-21 ### test oodialect-ancestry-004 {Testing heritage} { ::clay::ancestors ::alpha::object } {} ### # Test modified 2018-10-21 ### test oodialect-ancestry-005 {Testing heritage} { ::clay::ancestors ::delta::object } {} # ------------------------------------------------------------------------- # clay submodule testing # ------------------------------------------------------------------------- # Test canonical path building set path {const/ foo/ bar/ baz/} test oo-clay-path-0001 "Test path: const foo bar baz" { ::clay::path const foo bar baz } $path test oo-clay-path-0002 "Test path: const/ foo/ bar/ baz" { ::clay::path const/ foo/ bar/ baz } $path test oo-clay-path-0003 "Test path: const/foo/bar/baz" { ::clay::path const/foo/bar/baz } $path test oo-clay-path-0004 "Test path: const/foo bar/baz" { ::clay::path const/foo bar/baz } $path test oo-clay-path-0005 "Test path: const/foo/bar baz" { ::clay::path const/foo/bar baz } $path test oo-clay-path-0006 "Test path: const foo/bar/baz" { ::clay::path const foo/bar/baz } $path test oo-clay-path-0007 "Test path: const foo bar/baz" { ::clay::path const foo bar/baz } $path test oo-clay-path-0008 "Test path: const/foo bar baz" { ::clay::path const/foo bar baz } $path set path {const/ foo/ bar/ baz/ bing} test oo-clay-leaf-0001 "Test leaf: const foo bar baz bing" { ::clay::leaf const foo bar baz bing } $path test oo-clay-leaf-0002 "Test leaf: const/ foo/ bar/ baz/ bing" { ::clay::leaf const/ foo/ bar/ baz/ bing } $path test oo-clay-leaf-0003 "Test leaf: const/foo/bar/baz/bing" { ::clay::leaf const/foo/bar/baz/bing } $path test oo-clay-leaf-0004 "Test leaf: const/foo bar/baz/bing:" { ::clay::leaf const/foo bar/baz/bing: } $path test oo-clay-leaf-0005 "Test leaf: const/foo/bar baz bing" { ::clay::leaf const/foo/bar baz bing } $path test oo-clay-leaf-0006 "Test leaf: const/foo/bar baz bing:" { ::clay::leaf const/foo/bar baz bing: } $path test oo-clay-leaf-0007 "Test leaf: const foo/bar/baz/bing" { ::clay::leaf const foo/bar/baz/bing } $path test oo-clay-leaf-0008 "Test leaf: const foo bar/baz/bing" { ::clay::leaf const foo bar/baz/bing } $path test oo-clay-leaf-0009 "Test leaf: const/foo bar baz bing" { ::clay::leaf const/foo bar baz bing } $path namespace eval ::foo {} clay::define ::foo::classa { clay set const color blue clay set const/flavor strawberry clay set {const/ sound} zoink clay set info/ { animal no building no subelement {pedantic yes} } } test oo-class-clay-method-0001 "Test ::foo::classa const/ color exists" { ::foo::classa clay exists const/ color } 1 test oo-class-clay-method-0001 "Test ::foo::classa const/ color value" { ::foo::classa clay get const/ color } {blue} test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor exists" { ::foo::classa clay exists const/ flavor } 1 test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor value" { ::foo::classa clay get const/ flavor } {strawberry} test oo-class-clay-method-0005 "Test ::foo::classa const/ sound exists" { ::foo::classa clay exists const/ sound } 1 test oo-class-clay-method-0005 "Test ::foo::classa const/ sound value" { ::foo::classa clay get const/ sound } {zoink} test oo-class-clay-method-0007 "Test ::foo::classa info/ animal exists" { ::foo::classa clay exists info/ animal } 1 test oo-class-clay-method-0007 "Test ::foo::classa info/ animal value" { ::foo::classa clay get info/ animal } {no} test oo-class-clay-method-0009 "Test ::foo::classa info/ building exists" { ::foo::classa clay exists info/ building } 1 test oo-class-clay-method-0009 "Test ::foo::classa info/ building value" { ::foo::classa clay get info/ building } {no} test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement exists" { ::foo::classa clay exists info/ subelement } 1 test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement value" { ::foo::classa clay get info/ subelement } {pedantic yes} clay::define ::foo::classb { clay set const/ color black clay set const/ flavor vanilla clay set const/ feeling dread clay set info/ subelement {spoon yes} } test oo-class-clay-method-0013 "Test ::foo::classb const/ color exists" { ::foo::classb clay exists const/ color } 1 test oo-class-clay-method-0013 "Test ::foo::classb const/ color value" { ::foo::classb clay get const/ color } {black} test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor exists" { ::foo::classb clay exists const/ flavor } 1 test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor value" { ::foo::classb clay get const/ flavor } {vanilla} test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling exists" { ::foo::classb clay exists const/ feeling } 1 test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling value" { ::foo::classb clay get const/ feeling } {dread} test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement exists" { ::foo::classb clay exists info/ subelement } 1 test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement value" { ::foo::classb clay get info/ subelement } {spoon yes} clay::define ::foo::class.ab { superclass ::foo::classb ::foo::classa } clay::define ::foo::class.ba { superclass ::foo::classa ::foo::classb } # ------------------------------------------------------------------------- # OBJECT of ::foo::classa set OBJECTA [::foo::classa new] ### # Test object degation ### proc ::foo::fakeobject {a b} { return [expr {$a + $b}] } ::clay::object create TEST TEST clay delegate funct ::foo::fakeobject test oo-object-delegate-001 {Test object delegation} { ::TEST clay delegate } {<class> ::clay::object <funct> ::foo::fakeobject} test oo-object-delegate-002 {Test object delegation} { ::TEST clay delegate funct } {::foo::fakeobject} test oo-object-delegate-002a {Test object delegation} { ::TEST clay delegate <funct> } {::foo::fakeobject} test oo-object-delegate-003 {Test object delegation} { ::TEST <funct> 1 1 } {2} test oo-object-delegate-004 {Test object delegation} { ::TEST <funct> 10 -7 } {3} # Replace the function out from under proc ::foo::fakeobject {a b} { return [expr {$a * $b}] } test oo-object-delegate-005 {Test object delegation} { ::TEST <funct> 10 -7 } {-70} # Object with ::foo::classa mixed in set MIXINA [::oo::object new] oo::objdefine $MIXINA mixin ::foo::classa test oo-object-clay-method-native-0001 {Test native object gets the property const//color} { $OBJECTA clay get const/ color } {blue} test oo-object-clay-method-mixin-0001 {Test mixin object gets the property const//color} { $MIXINA clay get const/ color } {blue} test oo-object-clay-method-native-0002 {Test native object gets the property const//flavor} { $OBJECTA clay get const/ flavor } {strawberry} test oo-object-clay-method-mixin-0002 {Test mixin object gets the property const//flavor} { $MIXINA clay get const/ flavor } {strawberry} test oo-object-clay-method-native-0003 {Test native object gets the property const//sound} { $OBJECTA clay get const/ sound } {zoink} test oo-object-clay-method-mixin-0003 {Test mixin object gets the property const//sound} { $MIXINA clay get const/ sound } {zoink} test oo-object-clay-method-native-0004 {Test native object gets the property info//animal} { $OBJECTA clay get info/ animal } {no} test oo-object-clay-method-mixin-0004 {Test mixin object gets the property info//animal} { $MIXINA clay get info/ animal } {no} test oo-object-clay-method-native-0005 {Test native object gets the property info//building} { $OBJECTA clay get info/ building } {no} test oo-object-clay-method-mixin-0005 {Test mixin object gets the property info//building} { $MIXINA clay get info/ building } {no} test oo-object-clay-method-native-0006 {Test native object gets the property info//subelement} { $OBJECTA clay get info/ subelement } {pedantic yes} test oo-object-clay-method-mixin-0006 {Test mixin object gets the property info//subelement} { $MIXINA clay get info/ subelement } {pedantic yes} # ------------------------------------------------------------------------- # OBJECT of ::foo::classb set OBJECTB [::foo::classb new] # Object with ::foo::classb mixed in set MIXINB [::oo::object new] oo::objdefine $MIXINB mixin ::foo::classb test oo-object-clay-method-native-0007 {Test native object gets the property const//color} { $OBJECTB clay get const/ color } {black} test oo-object-clay-method-mixin-0007 {Test mixin object gets the property const//color} { $MIXINB clay get const/ color } {black} test oo-object-clay-method-native-0008 {Test native object gets the property const//flavor} { $OBJECTB clay get const/ flavor } {vanilla} test oo-object-clay-method-mixin-0008 {Test mixin object gets the property const//flavor} { $MIXINB clay get const/ flavor } {vanilla} test oo-object-clay-method-native-0009 {Test native object gets the property const//feeling} { $OBJECTB clay get const/ feeling } {dread} test oo-object-clay-method-mixin-0009 {Test mixin object gets the property const//feeling} { $MIXINB clay get const/ feeling } {dread} test oo-object-clay-method-native-0010 {Test native object gets the property info//subelement} { $OBJECTB clay get info/ subelement } {spoon yes} test oo-object-clay-method-mixin-0010 {Test mixin object gets the property info//subelement} { $MIXINB clay get info/ subelement } {spoon yes} # ------------------------------------------------------------------------- # OBJECT descended from ::foo::classa ::foo::classb set OBJECTAB [::foo::class.ab new] # Object where classes were mixed in ::foo::classa ::foo::classb set MIXINAB [::oo::object new] # Test modified 2018-10-30, mixin order was wrong before oo::objdefine $MIXINAB mixin ::foo::classb ::foo::classa test oo-object-clay-method-native-0011 {Test native object gets the property const//color} { $OBJECTAB clay get const/ color } {black} test oo-object-clay-method-mixin-0011 {Test mixin object gets the property const//color} { $MIXINAB clay get const/ color } {black} test oo-object-clay-method-native-0012 {Test native object gets the property const//flavor} { $OBJECTAB clay get const/ flavor } {vanilla} test oo-object-clay-method-mixin-0012 {Test mixin object gets the property const//flavor} { $MIXINAB clay get const/ flavor } {vanilla} test oo-object-clay-method-native-0013 {Test native object gets the property const//feeling} { $OBJECTAB clay get const/ feeling } {dread} test oo-object-clay-method-mixin-0013 {Test mixin object gets the property const//feeling} { $MIXINAB clay get const/ feeling } {dread} test oo-object-clay-method-native-0014 {Test native object gets the property const//sound} { $OBJECTAB clay get const/ sound } {zoink} test oo-object-clay-method-mixin-0014 {Test mixin object gets the property const//sound} { $MIXINAB clay get const/ sound } {zoink} test oo-object-clay-method-native-0015 {Test native object gets the property info//subelement} { $OBJECTAB clay get info/ subelement } {spoon yes} test oo-object-clay-method-mixin-0015 {Test mixin object gets the property info//subelement} { $MIXINAB clay get info/ subelement } {spoon yes} test oo-object-clay-method-native-0016 {Test native object gets the property info//animal} { $OBJECTAB clay get info/ animal } {no} test oo-object-clay-method-mixin-0016 {Test mixin object gets the property info//animal} { $MIXINAB clay get info/ animal } {no} test oo-object-clay-method-native-0017 {Test native object gets the property info//building} { $OBJECTAB clay get info/ building } {no} test oo-object-clay-method-mixin-0017 {Test mixin object gets the property info//building} { $MIXINAB clay get info/ building } {no} # ------------------------------------------------------------------------- # OBJECT descended from ::foo::classb ::foo::classa set OBJECTBA [::foo::class.ba new] # Object where classes were mixed in ::foo::classb ::foo::classa set MIXINBA [::oo::object new] # Test modified 2018-10-30, mixin order was wrong before oo::objdefine $MIXINBA mixin ::foo::classa ::foo::classb test oo-object-clay-method-native-0018 {Test native object gets the property} { $OBJECTBA clay get const/ color } {blue} test oo-object-clay-method-mixin-0018 {Test mixin object gets the property} { $MIXINBA clay get const/ color } {blue} test oo-object-clay-method-native-0019 {Test native object gets the property} { $OBJECTBA clay get const/ flavor } {strawberry} test oo-object-clay-method-mixin-0019 {Test mixin object gets the property} { $MIXINBA clay get const/ flavor } {strawberry} test oo-object-clay-method-native-0020 {Test native object gets the property} { $OBJECTBA clay get const/ sound } {zoink} test oo-object-clay-method-mixin-0020 {Test mixin object gets the property} { $MIXINBA clay get const/ sound } {zoink} test oo-object-clay-method-native-0021 {Test native object gets the property} { $OBJECTBA clay get const/ feeling } {dread} test oo-object-clay-method-mixin-0021 {Test mixin object gets the property} { $MIXINBA clay get const/ feeling } {dread} test oo-object-clay-method-native-0022 {Test native object gets the property} { $OBJECTBA clay get info/ animal } {no} test oo-object-clay-method-mixin-0022 {Test mixin object gets the property} { $MIXINBA clay get info/ animal } {no} test oo-object-clay-method-native-0023 {Test native object gets the property} { $OBJECTBA clay get info/ building } {no} test oo-object-clay-method-mixin-0023 {Test mixin object gets the property} { $MIXINBA clay get info/ building } {no} test oo-object-clay-method-native-0024 {Test native object gets the property} { $OBJECTBA clay get info/ subelement } {pedantic yes} test oo-object-clay-method-mixin-0024 {Test mixin object gets the property} { $MIXINBA clay get info/ subelement } {pedantic yes} ### # put a do-nothing constructor on the books ### ::clay::define ::clay::object { constructor args {} } oo::objdefine ::clay::object method foo args { return bar } test clay-core-method-0001 {Test that adding methods to the core ::clay::object class works} { ::clay::object foo } {bar} namespace eval ::TEST {} ::clay::define ::TEST::myclass { clay color red clay flavor strawberry } ### # Test adding a clay property ### test clay-class-clay-0001 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclass clay get color } red test clay-class-clay-0002 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclass clay get flavor } strawberry ### # Test that objects of the class get the same properties ### set OBJ [::clay::object new {}] set OBJ2 [::TEST::myclass new {}] test clay-object-clay-a-0001 {Test that objects not thee class do not get properties} { $OBJ clay get color } {} test clay-object-clay-a-0002 {Test that objects not thee class do not get properties} { $OBJ clay get flavor } {} test clay-object-clay-a-0003 {Test that objects of the class get properties} { $OBJ2 clay get color } red test clay-object-clay-a-0004 {Test that objects of the class get properties} { $OBJ2 clay get flavor } strawberry ### # Test modified 2018-10-21 ### test clay-object-clay-a-0005 {Test the clay ancestors function} { $OBJ clay ancestors } {::clay::object} ### # Test modified 2018-10-21 ### test clay-object-clay-a-0006 {Test the clay ancestors function} { $OBJ2 clay ancestors } {::TEST::myclass ::clay::object} test clay-object-clay-a-0007 {Test the clay provenance function} { $OBJ2 clay provenance flavor } ::TEST::myclass ### # Test that object local setting override the class ### test clay-object-clay-a-0008 {Test that object local setting override the class} { $OBJ2 clay set color purple $OBJ2 clay get color } purple test clay-object-clay-a-0009 {Test that object local setting override the class} { $OBJ2 clay provenance color } self ::clay::define ::TEST::myclasse { superclass ::TEST::myclass clay color blue method do args { return "I did $args" } Ensemble which::color {} { return [my clay get color] } clay set method_ensemble which color aliases farbe } ### # Test clay information is passed town to subclasses ### test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} { ::TEST::myclasse clay get color } blue test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} { ::TEST::myclasse clay get flavor } {} test clay-class-clay-0005 {Test that clay statements from the ancestors of this class are found with the FIND method} { ::TEST::myclasse clay find flavor } {strawberry} ### # Test that properties reach objects ### set OBJ3 [::TEST::myclasse new {}] test clay-object-clay-b-0001 {Test that objects of the class get properties} { $OBJ3 clay get color } blue test clay-object-clay-b-0002 {Test the clay provenance function} { $OBJ3 clay provenance color } ::TEST::myclasse test clay-object-clay-b-0003 {Test that objects of the class get properties} { $OBJ3 clay get flavor } strawberry test clay-object-clay-b-0004 {Test the clay provenance function} { $OBJ3 clay provenance flavor } ::TEST::myclass ### # Test modified 2018-10-21 ### test clay-object-clay-b-0005 {Test the clay provenance function} { $OBJ3 clay ancestors } {::TEST::myclasse ::TEST::myclass ::clay::object} ### # Test defining a standard method ### test clay-object-method-0001 {Test and standard method} { $OBJ3 do this really cool thing } {I did this really cool thing} test clay-object-method-0003 {Test an ensemble} { $OBJ3 which color } blue # Test setting properties test clay-object-method-0004 {Test an ensemble} { $OBJ3 clay set color black $OBJ3 which color } black # Test setting properties test clay-object-method-0004 {Test an ensemble alias} { $OBJ3 which farbe } black ### # Test that if you try to replace a global command you get an error ### test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body { ::clay::define open { method bar {} { return foo } } } -returnCodes {error} -result "::open does not refer to an object" ::clay::define fubar { method bar {} { return foo } } test clay-nspace-0002 {Test a non qualified class ends up in the current namespace} { info commands ::fubar } {::fubar} namespace eval ::cluster { ::clay::define fubar { method bar {} { return foo } } ::clay::define ::clay::pot { method bar {} { return foo } } } test clay-nspace-0003 {Test a non qualified class ends up in the current namespace} { info commands ::cluster::fubar } {::cluster::fubar} test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} { info commands ::clay::pot } {::clay::pot} #set ::clay::trace 3 ### # Mixin tests ### ### # Define a core class ### ::clay::define ::TEST::thing { method do args { return "I did $args" } } ::clay::define ::TEST::vegetable { clay color unknown clay flavor unknown Ensemble which::flavor {} { return [my clay get flavor] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::animal { clay color unknown clay sound unknown Ensemble which::sound {} { return [my clay get sound] } Ensemble which::color {} { return [my clay get color] } } ::clay::define ::TEST::species.cat { superclass ::TEST::animal clay sound meow } ::clay::define ::TEST::coloring.calico { clay color calico } ::clay::define ::TEST::condition.dark { Ensemble which::color {} { return grey } } ::clay::define ::TEST::mood.happy { Ensemble which::sound {} { return purr } } test clay-object-0001 {Test than an object is created when clay::define is invoked} { info commands ::TEST::mood.happy } ::TEST::mood.happy set OBJ [::TEST::thing new] test clay-mixin-a-0001 {Test that prior to a mixin an ensemble doesn't exist} -body { $OBJ which color } -returnCodes error -result {unknown method "which": must be clay, destroy or do} test clay-mixin-a-0002 {Test and standard method from an ancestor} { $OBJ do this really cool thing } {I did this really cool thing} $OBJ clay mixinmap species ::TEST::animal test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {unknown} test clay-mixin-b-0003 {Test that an ensemble is created during a mixin} -body {$OBJ which flavor} -returnCodes {error} -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-21 ### test clay-mixin-b-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::animal ::TEST::thing ::clay::object} ### # Replacing a mixin replaces the behaviors ### $OBJ clay mixinmap species ::TEST::vegetable test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-c-0002 {Test that an ensemble is created during a mixin} -body {$OBJ which sound} -returnCodes {error} -result {unknown method which sound. Valid: color flavor} test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} { $OBJ which flavor } {unknown} ### # Test Modified: 2018-10-21 ### test clay-mixin-c-0004 {Test that mixins resolve in the correct order} { $OBJ clay ancestors } {::TEST::vegetable ::TEST::thing ::clay::object} ### # Replacing a mixin $OBJ clay mixinmap species ::TEST::species.cat test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {unknown} test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} -body {$OBJ which flavor} -returnCodes {error} -result {unknown method which flavor. Valid: color sound} ### # Test Modified: 2018-10-30, 2018-10-21, 2018-10-10 ### test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} { $OBJ clay ancestors } {::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object} $OBJ clay mixinmap coloring ::TEST::coloring.calico test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} { $OBJ which color } {calico} test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} { $OBJ which sound } {meow} test clay-mixin-f-0003 {Test that an ensemble is created during a mixin} -body {$OBJ which flavor} -returnCodes {error} -result {unknown method which flavor. Valid: color sound} ### # Test modified 2018-10-30, 2018-10-21, 2018-10-10 ### test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} { $OBJ clay ancestors } {::TEST::coloring.calico ::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object} test clay-mixin-f-0005 {Test that clay data from a mixin works} { $OBJ clay provenance color } {::TEST::coloring.calico} ### # Test variable initialization ### ::clay::define ::TEST::has_var { Variable my_variable 10 method get_my_variable {} { my variable my_variable return $my_variable } } set OBJ [::TEST::has_var new] test clay-class-variable-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get variable/ my_variable } {10} # Modified 2018-10-30 (order is different) test clay-class-variable-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get variable } {my_variable 10 DestroyEvent 0} # Modified 2018-10-30 (order is different) test clay-class-variable-0003 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget variable } {. {} my_variable 10 DestroyEvent 0} test clay-class-variable-0004 {Test that variables declared in the class definition are initialized} { $OBJ get_my_variable } 10 ### # Test array initialization ### ::clay::define ::TEST::has_array { Array my_array {timeout 10} method get_my_array {field} { my variable my_array return $my_array($field) } } set OBJ [::TEST::has_array new] test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get array } {my_array {timeout 10}} test clay-class-array-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget array } {. {} my_array {. {} timeout 10}} test clay-class-array-0003 {Test that variables declared in the class definition are initialized} { $OBJ get_my_array timeout } 10 ::clay::define ::TEST::has_more_array { superclass ::TEST::has_array Array my_array {color blue} } test clay-class-array-0008 {Test that the parser injected the right value in the right place for clay to catch it} { ::TEST::has_more_array clay get array } {my_array {color blue}} test clay-class-array-0009 {Test that the parser injected the right value in the right place for clay to catch it} { ::TEST::has_more_array clay find array } {my_array {timeout 10 color blue}} # Modified 2018-10-30 (order is different) set BOBJ [::TEST::has_more_array new] test clay-class-array-0004 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay get array } {my_array {color blue timeout 10}} # Modified 2018-10-30 (order is different) test clay-class-array-0005 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay dget array } {. {} my_array {. {} color blue timeout 10}} test clay-class-arrau-0006 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_array timeout } 10 test clay-class-arrau-0007 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_array color } blue ::clay::define ::TEST::has_empty_array { Array my_array {} method my_array_exists {} { my variable my_array return [info exists my_array] } method get {field} { my variable my_array return $my_array($field) } method set {field value} { my variable my_array set my_array($field) $value } } test clay-class-array-0008 {Test that an declaration of an array with no values produces and empty array} { set COBJ [::TEST::has_empty_array new] $COBJ my_array_exists } 1 test clay-class-array-0009 {Test that an declaration of an array with no values produces and empty array} { $COBJ set test "A random value" $COBJ get test } {A random value} ### # Test dict initialization ### ::clay::define ::TEST::has_dict { Dict my_dict {timeout 10} method get_my_dict {args} { my variable my_dict if {[llength $args]==0} { return $my_dict } return [dict get $my_dict {*}$args] } } set OBJ [::TEST::has_dict new] test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay get dict } {my_dict {timeout 10}} test clay-class-dict-0002 {Test that the parser injected the right value in the right place for clay to catch it} { $OBJ clay dget dict } {. {} my_dict {. {} timeout 10}} test clay-class-dict-0003 {Test that variables declared in the class definition are initialized} { $OBJ get_my_dict timeout } 10 test clay-class-dict-0004 {Test that an empty dict is annotated} { $OBJ clay get dict } {my_dict {timeout 10}} ::clay::define ::TEST::has_more_dict { superclass ::TEST::has_dict Dict my_dict {color blue} } set BOBJ [::TEST::has_more_dict new] # Modified 2018-10-30 test clay-class-dict-0004 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay get dict } {my_dict {color blue timeout 10}} # Modified 2018-10-30 test clay-class-dict-0005 {Test that the parser injected the right value in the right place for clay to catch it} { $BOBJ clay dget dict } {. {} my_dict {. {} color blue timeout 10}} test clay-class-dict-0006 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_dict timeout } 10 test clay-class-dict-0007 {Test that variables declared in the class definition are initialized} { $BOBJ get_my_dict color } blue ::clay::define ::TEST::has_empty_dict { Dict my_empty_dict {} method get_my_empty_dict {args} { my variable my_empty_dict if {[llength $args]==0} { return $my_empty_dict } return [dict get $my_empty_dict {*}$args] } } set COBJ [::TEST::has_empty_dict new] test clay-class-dict-0008 {Test that the parser injected the right value in the right place for clay to catch it} { $COBJ clay dget dict } {my_empty_dict {. {}}} test clay-class-dict-0009 {Test that an empty dict is initialized} { $COBJ get_my_empty_dict } {} ### # Test object delegation ### ::clay::define ::TEST::organelle { method add args { set total 0 foreach item $args { set total [expr {$total+$item}] } return $total } } ::clay::define ::TEST::master { constructor {} { set mysub [namespace current]::sub ::TEST::organelle create $mysub my clay delegate sub $mysub } } set OBJ [::TEST::master new] ### # Test that delegation is working ### test clay-delegation-0001 {Test an array driven ensemble} { $OBJ <sub> add 5 5 } 10 ### # Test the Ensemble keyword ### ::clay::define ::TEST::with_ensemble { Ensemble myensemble {pattern args} { set ensemble [self method] set emap [my clay ensemble_map $ensemble] set mlist [dict keys $emap [string tolower $pattern]] if {[llength $mlist] != 1} { error "Couldn't figure out what to do with $pattern" } set method [lindex $mlist 0] set argspec [dict get $emap $method argspec] set body [dict get $emap $method body] if {$argspec ni {args {}}} { ::clay::dynamic_arguments $ensemble $method [list $argspec] {*}$args } eval $body } Ensemble myensemble::go args { return 1 } } ::clay::define ::TEST::with_ensemble.dance { Ensemble myensemble::dance args { return 1 } } ::clay::define ::TEST::with_ensemble.cannot_dance { Ensemble myensemble::dance args { return 0 } } set OBJA [::clay::object new] set OBJB [::clay::object new] $OBJA clay mixinmap core ::TEST::with_ensemble friends ::TEST::with_ensemble.dance $OBJB clay mixinmap core ::TEST::with_ensemble friends ::TEST::with_ensemble.cannot_dance # Test go test clay-dynamic-ensemble-0001 {Test ensemble with static method} { $OBJA myensemble go } {1} test clay-dynamic-ensemble-0002 {Test ensemble with static method} { $OBJB myensemble go } {1} # Test dance test clay-dynamic-ensemble-0003 {Test ensemble with static method} { $OBJA myensemble dance } {1} test clay-dynamic-ensemble-0004 {Test ensemble with static method} { $OBJB myensemble dance } {0} ### # Class method testing ### clay::class create WidgetClass { Class_Method working {} { return {Works} } Class_Method unknown args { set tkpath [lindex $args 0] if {[string index $tkpath 0] eq "."} { set obj [my new $tkpath {*}[lrange $args 1 end]] $obj tkalias $tkpath return $tkpath } next {*}$args } constructor {TkPath args} { my variable hull set hull $TkPath my clay delegate hull $TkPath } method tkalias tkname { set oldname $tkname my variable tkalias set tkalias $tkname set self [self] set hullwidget [::info object namespace $self]::tkwidget my clay delegate tkwidget $hullwidget #rename ::$tkalias $hullwidget my clay delegate hullwidget $hullwidget #::tool::object_rename [self] ::$tkalias rename [self] ::$tkalias #my Hull_Bind $tkname return $hullwidget } } test tool-class-method-000 {Test that class methods actually work...} { WidgetClass working } {Works} test tool-class-method-001 {Test Tk style creator} { WidgetClass .foo .foo clay delegate hull } {.foo} ::clay::define WidgetNewClass { superclass WidgetClass } test tool-class-method-002 {Test Tk style creator inherited by morph} { WidgetNewClass .bar .bar clay delegate hull } {.bar} ### # Test ensemble inheritence ### clay::define NestedClassA { Ensemble do::family {} { return NestedClassA } Ensemble do::something {} { return A } Ensemble do::whop {} { return A } } clay::define NestedClassB { superclass NestedClassA Ensemble do::family {} { set r [next family] lappend r NestedClassB return $r } Ensemble do::whop {} { return B } } clay::define NestedClassC { superclass NestedClassB Ensemble do::somethingelse {} { return C } } clay::define NestedClassD { superclass NestedClassB Ensemble do::somethingelse {} { return D } } clay::define NestedClassE { superclass NestedClassD NestedClassC } clay::define NestedClassF { superclass NestedClassC NestedClassD } NestedClassC create NestedObjectC ### # These tests no longer work because method ensembles are now dynamically # generated by object, that are not attached to the class anymore # #### #test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} { # NestedObjectC do family #} {::NestedClassA ::NestedClassB ::NestedClassC} test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} { NestedObjectC do whop } {B} test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} { NestedObjectC do something } {A} NestedClassE create NestedObjectE NestedClassF create NestedObjectF test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} { NestedObjectE do somethingelse } {D} test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} { NestedObjectF do somethingelse } {C} ### # Set of tests to exercise the mixinmap system ### clay::define MixinMainClass { Variable mainvar unchanged Ensemble test::which {} { my variable mainvar return $mainvar } Ensemble test::main args { puts [list this is main $method $args] } } set mixoutscript {my test untool $class} set mixinscript {my test tool $class} clay::define MixinTool { Variable toolvar unchanged.mixin clay set mixin/ unmap-script $mixoutscript clay set mixin/ map-script $mixinscript clay set mixin/ name {Generic Tool} Ensemble test::untool class { my variable toolvar mainvar set mainvar {} set toolvar {} } Ensemble test::tool class { my variable toolvar mainvar set mainvar [$class clay get mixin name] set toolvar [$class clay get mixin name] } } clay::define MixinToolA { superclass MixinTool clay set mixin/ name {Tool A} } clay::define MixinToolB { superclass MixinTool clay set mixin/ name {Tool B} method test_newfunc {} { return "B" } } test tool-mixinspec-001 {Test application of mixin specs} { MixinTool clay get mixin map-script } $mixinscript test tool-mixinspec-002 {Test application of mixin specs} { MixinToolA clay get mixin map-script } {} test tool-mixinspec-003 {Test application of mixin specs} { MixinToolA clay find mixin map-script } $mixinscript test tool-mixinspec-004 {Test application of mixin specs} { MixinToolB clay find mixin map-script } $mixinscript MixinMainClass create mixintest test tool-mixinmap-001 {Test object prior to mixins} { mixintest test which } {unchanged} mixintest clay mixinmap tool MixinToolA test tool-mixinmap-002 {Test mixin map script ran} { mixintest test which } {Tool A} mixintest clay mixinmap tool MixinToolB test tool-mixinmap-003 {Test mixin map script ran} { mixintest test which } {Tool B} test tool-mixinmap-003 {Test mixin map script ran} { mixintest test_newfunc } {B} mixintest clay mixinmap tool {} test tool-mixinmap-004 {Test object prior to mixins} { mixintest test which } {} clay::define ::clay::object { method path {} { return [self class] } } clay::define ::MixinRoot { clay set opts core root clay set opts option unset clay set opts color unset Ensemble info::root {} { return MixinRoot } Ensemble info::shade {} { return avacodo } Ensemble info::default {} { return Undefined } method did {} { return MixinRoot } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinOption1 { clay set opts option option1 Ensemble info::option {} { return MixinOption1 } Ensemble info::other {} { return MixinOption1 } method did {} { return MixinOption1 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinOption2 { superclass ::MixinOption1 clay set opts option option2 Ensemble info::option {} { return MixinOption2 } method did {} { return MixinOption2 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinColor1 { clay set opts color blue Ensemble info::color {} { return MixinColor1 } Ensemble info::shade {} { return blue } method did {} { return MixinColor1 } method path {} { return [list [self class] {*}[next]] } } clay::define ::MixinColor2 { clay set opts color green Ensemble info::color {} { return MixinColor2 } Ensemble info::shade {} { return green } method did {} { return MixinColor2 } method path {} { return [list [self class] {*}[next]] } } set obj [clay::object new] $obj clay mixinmap root ::MixinRoot test tool-prototype-0001-0001 {Mixin core} { $obj info root } {MixinRoot} test tool-prototype-0001-0002 {Mixin core} { $obj info option } {Undefined} test tool-prototype-0001-0003 {Mixin core} { $obj info color } {Undefined} test tool-prototype-0001-0004 {Mixin core} { $obj info other } {Undefined} test tool-prototype-0001-0005 {Mixin core} { $obj info shade } {avacodo} test tool-prototype-0001-0006 {Mixin core} { $obj did } {MixinRoot} test tool-prototype-0001-0007 {Mixin core} { $obj path } {::MixinRoot ::clay::object} test tool-prototype-0001-0008 {Mixin core} { $obj clay get opts } {core root option unset color unset} test tool-prototype-0001-0009 {Mixin core} { $obj clay get opts core } {root} test tool-prototype-0001-0010 {Mixin core} { $obj clay get opts option } {unset} test tool-prototype-0001-0011 {Mixin core} { $obj clay get opts color } {unset} test tool-prototype-0001-0012 {Mixin core} { $obj clay ancestors } {::MixinRoot ::clay::object} $obj clay mixinmap option ::MixinOption1 test tool-prototype-0002-0001 {Mixin option1} { $obj info root } {MixinRoot} test tool-prototype-0002-0002 {Mixin option1} { $obj info option } {MixinOption1} test tool-prototype-0002-0003 {Mixin option1} { $obj info color } {Undefined} test tool-prototype-0002-0004 {Mixin option1} { $obj info other } {MixinOption1} test tool-prototype-0002-0005 {Mixin option1} { $obj info shade } {avacodo} test tool-prototype-0002-0006 {Mixin option1} { $obj did } {MixinOption1} test tool-prototype-0002-0007 {Mixin option1} { $obj path } {::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0002-0008 {Mixin option1} { $obj clay get opts } {option option1 core root color unset} test tool-prototype-0002-0009 {Mixin option1} { $obj clay get opts core } {root} test tool-prototype-0002-0010 {Mixin option1} { $obj clay get opts option } {option1} test tool-prototype-0002-0011 {Mixin option1} { $obj clay get opts color } {unset} test tool-prototype-0002-0012 {Mixin option1} { $obj clay ancestors } {::MixinOption1 ::MixinRoot ::clay::object} set obj2 [clay::object new] $obj2 clay mixinmap root ::MixinRoot option ::MixinOption1 $obj clay mixinmap option ::MixinOption1 test tool-prototype-0003-0001 {Mixin option1 - clean object} { $obj2 info root } {MixinRoot} test tool-prototype-0003-0002 {Mixin option1 - clean object} { $obj2 info option } {MixinOption1} test tool-prototype-0003-0003 {Mixin option1 - clean object} { $obj2 info color } {Undefined} test tool-prototype-0003-0004 {Mixin option1 - clean object} { $obj2 info other } {MixinOption1} test tool-prototype-0003-0005 {Mixin option1 - clean object} { $obj2 info shade } {avacodo} test tool-prototype-0003-0006 {Mixin option1 - clean object} { $obj2 did } {MixinOption1} test tool-prototype-0003-0007 {Mixin option1 - clean object} { $obj2 path } {::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0003-0008 {Mixin option1 - clean object} { $obj2 clay get opts } {option option1 core root color unset} test tool-prototype-0003-0009 {Mixin option1 - clean object} { $obj2 clay get opts core } {root} test tool-prototype-0003-0010 {Mixin option1 - clean object} { $obj2 clay get opts option } {option1} test tool-prototype-0003-0011 {Mixin option1 - clean object} { $obj2 clay get opts color } {unset} test tool-prototype-0003-0012 {Mixin option1 - clean object} { $obj2 clay ancestors } {::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap option ::MixinOption2 test tool-prototype-0004-0001 {Mixin option2} { $obj info root } {MixinRoot} test tool-prototype-0004-0002 {Mixin option2} { $obj info option } {MixinOption2} test tool-prototype-0004-0003 {Mixin option2} { $obj info color } {Undefined} test tool-prototype-0004-0004 {Mixin option2} { $obj info other } {MixinOption1} test tool-prototype-0004-0005 {Mixin option2} { $obj info shade } {avacodo} test tool-prototype-0004-0006 {Mixin option2} { $obj did } {MixinOption2} test tool-prototype-0004-0007 {Mixin option2} { $obj path } {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0004-0008 {Mixin option2} { $obj clay get opts } {option option2 core root color unset} test tool-prototype-0004-0009 {Mixin option2} { $obj clay get opts core } {root} test tool-prototype-0004-0010 {Mixin option2} { $obj clay get opts option } {option2} test tool-prototype-0004-0011 {Mixin option2} { $obj clay get opts color } {unset} test tool-prototype-0004-0012 {Mixin option2} { $obj clay ancestors } {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap color MixinColor1 test tool-prototype-0005-0001 {Mixin color1} { $obj info root } {MixinRoot} test tool-prototype-0005-0002 {Mixin color1} { $obj info option } {MixinOption2} test tool-prototype-0005-0003 {Mixin color1} { $obj info color } {MixinColor1} test tool-prototype-0005-0004 {Mixin color1} { $obj info other } {MixinOption1} test tool-prototype-0005-0005 {Mixin color1} { $obj info shade } {blue} test tool-prototype-0005-0006 {Mixin color1} { $obj did } {MixinColor1} test tool-prototype-0005-0007 {Mixin color1} { $obj path } {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} test tool-prototype-0005-0008 {Mixin color1} { $obj clay get opts } {color blue option option2 core root} test tool-prototype-0005-0009 {Mixin color1} { $obj clay get opts core } {root} test tool-prototype-0005-0010 {Mixin color1} { $obj clay get opts option } {option2} test tool-prototype-0005-0011 {Mixin color1} { $obj clay get opts color } {blue} test tool-prototype-0005-0012 {Mixin color1} { $obj clay ancestors } {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap color MixinColor2 test tool-prototype-0006-0001 {Mixin color2} { $obj info root } {MixinRoot} test tool-prototype-0006-0002 {Mixin color2} { $obj info option } {MixinOption2} test tool-prototype-0006-0003 {Mixin color2} { $obj info color } {MixinColor2} test tool-prototype-0006-0004 {Mixin color2} { $obj info other } {MixinOption1} test tool-prototype-0006-0005 {Mixin color2} { $obj info shade } {green} test tool-prototype-0006-0006 {Mixin color2} { $obj clay get opts } {color green option option2 core root} test tool-prototype-0006-0007 {Mixin color2} { $obj clay get opts core } {root} test tool-prototype-0006-0008 {Mixin color2} { $obj clay get opts option } {option2} test tool-prototype-0006-0009 {Mixin color2} { $obj clay get opts color } {green} test tool-prototype-0006-0010 {Mixin color2} { $obj clay ancestors } {::MixinColor2 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap option MixinOption1 test tool-prototype-0007-0001 {Mixin color2 + Option1} { $obj info root } {MixinRoot} test tool-prototype-0007-0002 {Mixin color2 + Option1} { $obj info option } {MixinOption1} test tool-prototype-0007-0003 {Mixin color2 + Option1} { $obj info color } {MixinColor2} test tool-prototype-0007-0004 {Mixin color2 + Option1} { $obj info other } {MixinOption1} test tool-prototype-0007-0005 {Mixin color2 + Option1} { $obj info shade } {green} test tool-prototype-0007-0006 {Mixin color2 + Option1} { $obj clay get opts } {color green option option1 core root} test tool-prototype-0007-0007 {Mixin color2 + Option1} { $obj clay get opts core } {root} test tool-prototype-0007-0008 {Mixin color2 + Option1} { $obj clay get opts option } {option1} test tool-prototype-0007-0009 {Mixin color2 + Option1} { $obj clay get opts color } {green} test tool-prototype-0007-0010 {Mixin color2 + Option1} { $obj clay ancestors } {::MixinColor2 ::MixinOption1 ::MixinRoot ::clay::object} $obj clay mixinmap option {} test tool-prototype-0008-0001 {Mixin color2 + no option} { $obj info root } {MixinRoot} test tool-prototype-0008-0002 {Mixin color2 + no option} { $obj info option } {Undefined} test tool-prototype-0008-0003 {Mixin color2 + no option} { $obj info color } {MixinColor2} test tool-prototype-0008-0004 {Mixin color2 + no option} { $obj info other } {Undefined} test tool-prototype-0008-0005 {Mixin color2 + no option} { $obj info shade } {green} test tool-prototype-0008-0006 {Mixin color2 + no option} { $obj clay get opts } {color green core root option unset} test tool-prototype-0008-0007 {Mixin color2 + no option} { $obj clay get opts core } {root} test tool-prototype-0008-0008 {Mixin color2 + no option} { $obj clay get opts option } {unset} test tool-prototype-0008-0009 {Mixin color2 + no option} { $obj clay get opts color } {green} test tool-prototype-0008-0010 {Mixin color2 + no option} { $obj clay ancestors } {::MixinColor2 ::MixinRoot ::clay::object} $obj clay mixinmap color {} test tool-prototype-0009-0001 {Mixin core (return to normal)} { $obj info root } {MixinRoot} test tool-prototype-0009-0002 {Mixin core (return to normal)} { $obj info option } {Undefined} test tool-prototype-0009-0003 {Mixin core (return to normal)} { $obj info color } {Undefined} test tool-prototype-0009-0004 {Mixin core (return to normal)} { $obj info other } {Undefined} test tool-prototype-0009-0005 {Mixin core (return to normal)} { $obj info shade } {avacodo} test tool-prototype-0009-0006 {Mixin core (return to normal)} { $obj clay get opts } {core root option unset color unset} test tool-prototype-0009-0007 {Mixin core (return to normal)} { $obj clay get opts core } {root} test tool-prototype-0009-0008 {Mixin core (return to normal)} { $obj clay get opts option } {unset} test tool-prototype-0009-0009 {Mixin core (return to normal)} { $obj clay get opts color } {unset} test tool-prototype-0009-0010 {Mixin core (return to normal)} { $obj clay ancestors } {::MixinRoot ::clay::object} ### # Tip479 Tests ### clay::define tip479class { Method newitem dictargs { id {type: number} color {default: green} shape {options: {round square}} flavor {default: grape} } { my variable items foreach {f v} $args { dict set items $id $f $v } if {"color" ni [dict keys $args]} { dict set items $id color $color } return [dict get $items $id] } method itemget {id field} { my variable items return [dict get $id $field] } } set obj [tip479class new] test tip479-001 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 1 color orange shape round } {id 1 color orange shape round} # Fail because we left off a mandatory argument test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -errorCode NONE -body { $obj newitem id 2 } -result {shape is required} ### # Leave off a value that has a default # note: Method had special handling for color, but not flavor ### test tip479-003 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 3 shape round } {id 3 shape round color green} ### # Add extra arguments ### test tip479-004 {Test that a later ensemble definition trumps a more primitive one} { $obj newitem id 4 shape round trim leather } {id 4 shape round trim leather color green} clay::define tip479classE { Ensemble item::new dictargs { id {type: number} color {default: green} shape {options: {round square}} flavor {default: grape} } { my variable items foreach {f v} $args { dict set items $id $f $v } if {"color" ni [dict keys $args]} { dict set items $id color $color } return [dict get $items $id] } Ensemble item::get {id field} { my variable items return [dict get $id $field] } } set obj [tip479classE new] test tip479-001 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 1 color orange shape round } {id 1 color orange shape round} # Fail because we left off a mandatory argument test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -errorCode NONE -body { $obj item new id 2 } -result {shape is required} ### # Leave off a value that has a default # note: Method had special handling for color, but not flavor ### test tip479-003 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 3 shape round } {id 3 shape round color green} ### # Add extra arguments ### test tip479-004 {Test that a later ensemble definition trumps a more primitive one} { $obj item new id 4 shape round trim leather } {id 4 shape round trim leather color green} testsuiteCleanup # Local variables: # mode: tcl # indent-tabs-mode: nil # End: |
Added modules/clay/pkgIndex.tcl.
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded clay 0.8 [list source [file join $dir clay.tcl]] |
Changes to modules/httpd/build/build.tcl.
1 2 3 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] | > > > > > > > > > | > | | | | | < | | | | | | | | | < | > < > > | < > > > | < | | | | > > > > > > > | 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 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] if {[file exists [file join $moddir .. .. scripts practcl.tcl]]} { source [file join $moddir .. .. scripts practcl.tcl] } elseif {[file exists [file join $moddir .. practcl build doctool.tcl]]} { source [file join $moddir .. practcl build doctool.tcl] } else { package require practcl 0.14 } ::practcl::doctool create AutoDoc set version 4.3.3 set tclversion 8.6 set module [file tail $moddir] set filename $module set fout [open [file join $moddir ${filename}.tcl] w] dict set modmap %module% $module dict set modmap %version% $version dict set modmap %tclversion% $tclversion dict set modmap %filename% $filename puts $fout [string map $modmap {### # Amalgamated package for %module% # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl %tclversion% package provide %module% %version% namespace eval ::%module% {} set ::%module%::version %version%}] # Track what files we have included so far set loaded {} lappend loaded build.tcl cgi.tcl # These files must be loaded in a particular order foreach {file} { core.tcl reply.tcl server.tcl dispatch.tcl file.tcl proxy.tcl cgi.tcl scgi.tcl websocket.tcl plugin.tcl } { lappend loaded $file puts $fout "###\n# START: [file tail $file]\n###" set content [::practcl::cat [file join $srcdir $file]] AutoDoc scan_text $content puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # These files can be loaded in any order foreach file [glob [file join $srcdir *.tcl]] { if {[file tail $file] in $loaded} continue lappend loaded $file puts "EXTRA $file" set fin [open [file join $srcdir $file] r] puts $fout "###\n# START: [file tail $file]\n###" set content [::practcl::cat [file join $srcdir $file]] AutoDoc scan_text $content puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file tail $file]\n###" } # Provide some cleanup and our final package provide puts $fout [string map $modmap { namespace eval ::%module% { namespace export * } }] close $fout ### # Build our pkgIndex.tcl file ### set fout [open [file join $moddir pkgIndex.tcl] w] puts $fout [string map $modmap { if {![package vsatisfies [package provide Tcl] %tclversion%]} {return} package ifneeded %module% %version% [list source [file join $dir %module%.tcl]] }] close $fout set manout [open [file join $moddir $filename.man] w] puts $manout [AutoDoc manpage map $modmap \ header [::practcl::cat [file join $srcdir manual.txt]] \ footer [::practcl::cat [file join $srcdir footer.txt]] \ ] close $manout |
Changes to modules/httpd/build/cgi.tcl.
|
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | ::clay::define ::httpd::content.cgi { superclass ::httpd::content.proxy method FileName {} { set uri [string trimleft [my request get REQUEST_URI] /] set path [my clay get path] set prefix [my clay get prefix] set fname [string range $uri [string length $prefix] end] if {[file exists [file join $path $fname]]} { return [file join $path $fname] } if {[file exists [file join $path $fname.fossil]]} { return [file join $path $fname.fossil] |
︙ | ︙ | |||
24 25 26 27 28 29 30 | method proxy_channel {} { ### # When delivering static content, allow web caches to save ### set local_file [my FileName] if {$local_file eq {} || ![file exist $local_file]} { | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | method proxy_channel {} { ### # When delivering static content, allow web caches to save ### set local_file [my FileName] if {$local_file eq {} || ![file exist $local_file]} { my log httpNotFound [my request get REQUEST_URI] my error 404 {Not Found} tailcall my DoOutput } if {[file isdirectory $local_file]} { ### # Produce an index page... or error ### |
︙ | ︙ | |||
48 49 50 51 52 53 54 | } foreach item $verbatim { set ::env($item) {} } foreach item [array names ::env HTTP_*] { set ::env($item) {} } | | | < | < < < < < < < < | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | } foreach item $verbatim { set ::env($item) {} } foreach item [array names ::env HTTP_*] { set ::env($item) {} } set ::env(SCRIPT_NAME) [my request get REQUEST_PATH] set ::env(SERVER_PROTOCOL) HTTP/1.0 set ::env(HOME) $::env(DOCUMENT_ROOT) foreach {f v} [my request dump] { set ::env($f) $v } set arglist $::env(QUERY_STRING) set pwd [pwd] cd [file dirname $local_file] set script_file $local_file if {[file extension $local_file] in {.fossil .fos}} { if {![file exists $local_file.cgi]} { set fout [open $local_file.cgi w] chan puts $fout "#!/usr/bin/fossil" chan puts $fout "repository: $local_file" close $fout |
︙ | ︙ | |||
88 89 90 91 92 93 94 | cd $pwd return $pipe } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} | | | < > < | 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 | cd $pwd return $pipe } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} set length [my request get CONTENT_LENGTH] if {$length} { chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 ### # Send any POST/PUT/etc content ### my ChannelCopy $chana $chanb -size $length } else { chan flush $chanb } chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] chan event $chana readable {} set replyhead [my HttpHeaders $chana] |
︙ | ︙ | |||
124 125 126 127 128 129 130 | # a standard service reply line from a web server, but # otherwise spit out the rest of the headers verbatim ### set replybuffer "HTTP/1.0 [dict get $replydat Status]\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer | < < | | | | | < < | < | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | # a standard service reply line from a web server, but # otherwise spit out the rest of the headers verbatim ### set replybuffer "HTTP/1.0 [dict get $replydat Status]\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer ### # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 } ### # For most CGI applications a directory list is vorboten ### method DirectoryListing {local_file} { my error 403 {Not Allowed} tailcall my DoOutput } } |
Changes to modules/httpd/build/core.tcl.
︙ | ︙ | |||
10 11 12 13 14 15 16 | # support the SCGI module ### package require uri package require dns package require cron package require coroutine | < | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > | 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 | # support the SCGI module ### package require uri package require dns package require cron package require coroutine package require mime package require fileutil package require websocket package require Markdown package require fileutil::magic::filetype package require clay 0.7 namespace eval httpd::content {} namespace eval ::url {} namespace eval ::httpd {} namespace eval ::scgi {} ### # A metaclass for MIME handling behavior across a live socket ### clay::define ::httpd::mime { method ChannelCopy {in out args} { set chunk 4096 set size -1 foreach {f v} $args { set [string trim $f -] $v } dict set info coroutine [info coroutine] if {$size>0 && $chunk>$size} { set chunk $size } set bytes 0 set sofar 0 set method [self method] while 1 { set command {} set error {} if {$size>=0} { incr sofar $bytes set remaining [expr {$size-$sofar}] if {$remaining <= 0} { break } elseif {$chunk > $remaining} { set chunk $remaining } } lassign [yieldto chan copy $in $out -size $chunk \ -command [list [info coroutine] $method]] \ command bytes error if {$command ne $method} { error "Subroutine $method interrupted" } if {[string length $error]} { error $error } if {[chan eof $in]} { break } } } ### # Returns a block of HTML method html_header {{title {}} args} { set result {} append result "<!DOCTYPE html>\n<HTML><HEAD>" if {$title ne {}} { append result "<TITLE>$title</TITLE>" } if {[dict exists $args stylesheet]} { append result "<link rel=\"stylesheet\" href=\"[dict get $args stylesheet]\">" } else { append result "<link rel=\"stylesheet\" href=\"/style.css\">" } append result "</HEAD><BODY>" return $result } method html_footer {args} { return "</BODY></HTML>" } method http_code_string code { set codes { 200 {Data follows} |
︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 | method HttpHeaders_Default {} { return {Status {200 OK} Content-Size 0 Content-Type {text/html; charset=UTF-8} Cache-Control {no-cache} Connection close} } ### | > > > > > > > > > > < > > > | 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 | method HttpHeaders_Default {} { return {Status {200 OK} Content-Size 0 Content-Type {text/html; charset=UTF-8} Cache-Control {no-cache} Connection close} } method HttpServerHeaders {} { return { CONTENT_LENGTH CONTENT_TYPE QUERY_STRING REMOTE_USER AUTH_TYPE REQUEST_METHOD REMOTE_ADDR REMOTE_HOST REQUEST_URI REQUEST_PATH REQUEST_VERSION DOCUMENT_ROOT QUERY_STRING REQUEST_RAW GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT SERVER_NAME SERVER_SOFTWARE SERVER_PROTOCOL } } ### # Converts a block of mime encoded text to a key/value list. If an exception is encountered, # the method will generate its own call to the [cmd error] method, and immediately invoke # the [cmd output] method to produce an error code and close the connection. ### method MimeParse mimetext { set data(mimeorder) {} foreach line [split $mimetext \n] { # This regexp picks up # key: value # MIME headers. MIME headers may be continue with a line |
︙ | ︙ | |||
193 194 195 196 197 198 199 200 201 202 203 204 205 206 | } } dict set result $ckey $data(mime,$key) } return $result } method Url_Decode data { regsub -all {\+} $data " " data regsub -all {([][$\\])} $data {\\\1} data regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data return [subst $data] } | > | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 | } } dict set result $ckey $data(mime,$key) } return $result } # De-httpizes a string. method Url_Decode data { regsub -all {\+} $data " " data regsub -all {([][$\\])} $data {\\\1} data regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data return [subst $data] } |
︙ | ︙ |
Changes to modules/httpd/build/dispatch.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 | ::clay::define ::httpd::content.redirect { method reset {} { ### # Inject the location into the HTTP headers ### my variable reply_body set reply_body {} my reply replace [my HttpHeaders_Default] my reply set Server [my <server> clay get server/ string] set msg [my clay get LOCATION] my reply set Location [my clay get LOCATION] set code [my clay get REDIRECT_CODE] if {$code eq {}} { set code 301 } my reply set Status [list $code [my http_code_string $code]] } method content {} { set template [my <server> template redirect] set msg [my clay get LOCATION] set HTTP_STATUS [my reply get Status] my puts [subst $msg] } } ::clay::define ::httpd::content.cache { method Dispatch {} { my variable chan try { my wait writable $chan chan configure $chan -translation {binary binary} chan puts -nonewline $chan [my clay get cache/ data] } on error {err info} { my <server> debug [dict get $info -errorinfo] } finally { my TransferComplete $chan } } } ::clay::define ::httpd::content.template { method content {} { if {[my request get HTTP_STATUS] ne {}} { my reply set Status [my request get HTTP_STATUS] } my puts [subst [my <server> template [my clay get template]]] } } |
Changes to modules/httpd/build/file.tcl.
1 2 3 4 5 | ### # Class to deliver Static content # When utilized, this class is fed a local filename # by the dispatcher ### | | > > > > | | | | | | | | 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 | ### # Class to deliver Static content # When utilized, this class is fed a local filename # by the dispatcher ### ::clay::define ::httpd::content.file { method FileName {} { # Some dispatchers will inject a fully qualified name during discovery if {[my clay exists FILENAME] && [file exists [my clay get FILENAME]]} { return [my clay get FILENAME] } set uri [string trimleft [my request get REQUEST_URI] /] set path [my clay get path] set prefix [my clay get prefix] set fname [string range $uri [string length $prefix] end] if {$fname in "{} index.html index.md index index.tml"} { return $path } if {[file exists [file join $path $fname]]} { return [file join $path $fname] } if {[file exists [file join $path $fname.md]]} { return [file join $path $fname.md] } if {[file exists [file join $path $fname.html]]} { return [file join $path $fname.html] } if {[file exists [file join $path $fname.tml]]} { return [file join $path $fname.tml] } return {} } method DirectoryListing {local_file} { set uri [string trimleft [my request get REQUEST_URI] /] set path [my clay get path] set prefix [my clay get prefix] set fname [string range $uri [string length $prefix] end] my puts [my html_header "Listing of /$fname/"] my puts "Listing contents of /$fname/" my puts "<TABLE>" if {$prefix ni {/ {}}} { set updir [file dirname $prefix] if {$updir ne {}} { |
︙ | ︙ | |||
53 54 55 56 57 58 59 | my puts [my html_footer] } method content {} { my variable reply_file set local_file [my FileName] if {$local_file eq {} || ![file exist $local_file]} { | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | my puts [my html_footer] } method content {} { my variable reply_file set local_file [my FileName] if {$local_file eq {} || ![file exist $local_file]} { my log httpNotFound [my request get REQUEST_URI] my error 404 {File Not Found} tailcall my DoOutput } if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} { ### # Produce an index page ### |
︙ | ︙ | |||
88 89 90 91 92 93 94 | my reply set Content-Type {text/html; charset=UTF-8} set mdtxt [::fileutil::cat $local_file] my puts [::Markdown::convert $mdtxt] } .tml { my reply set Content-Type {text/html; charset=UTF-8} set tmltxt [::fileutil::cat $local_file] | | > > > > > > | < < < < < < < | 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 | my reply set Content-Type {text/html; charset=UTF-8} set mdtxt [::fileutil::cat $local_file] my puts [::Markdown::convert $mdtxt] } .tml { my reply set Content-Type {text/html; charset=UTF-8} set tmltxt [::fileutil::cat $local_file] set headers [my request dump] dict with headers {} my puts [subst $tmltxt] } .svgz - .svg { # FU magic screws it up my reply set Content-Type {image/svg+xml} set reply_file $local_file } default { ### # Assume we are returning a binary file ### my reply set Content-Type [::fileutil::magic::filetype $local_file] set reply_file $local_file } } } method Dispatch {} { my variable reply_body reply_file reply_chan chan try { my reset # Invoke the URL implementation. my content } on error {err errdat} { my error 500 $err [dict get $errdat -errorinfo] tailcall my DoOutput } |
︙ | ︙ | |||
136 137 138 139 140 141 142 | ### set size [file size $reply_file] my reply set Content-Length $size append result [my reply output] \n chan puts -nonewline $chan $result set reply_chan [open $reply_file r] my log SendReply [list length $size] | < | < < < < < < < < < > | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | ### set size [file size $reply_file] my reply set Content-Length $size append result [my reply output] \n chan puts -nonewline $chan $result set reply_chan [open $reply_file r] my log SendReply [list length $size] ### # Output the file contents. With no -size flag, channel will copy until EOF ### chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0 my ChannelCopy $reply_chan $chan -chunk 4096 } finally { my TransferComplete $reply_chan $chan } } } |
Added modules/httpd/build/footer.txt.
> > > > > | 1 2 3 4 5 | [section AUTHORS] Sean Woods [vset CATEGORY network] [include ../doctools2base/include/feedback.inc] |
Added modules/httpd/build/manual.txt.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | [keywords WWW] [copyright {2018 Sean Woods <[email protected]>}] [moddesc {Tcl Web Server}] [titledesc {A TclOO and coroutine based web server}] [category Networking] [keywords TclOO] [keywords http] [keywords httpd] [keywords httpserver] [keywords services] [require Tcl 8.6] [require uuid] [require clay] [require coroutine] [require fileutil] [require fileutil::magic::filetype] [require websocket] [require mime] [require cron] [require uri] [require Markdown] [description] [para] This module implements a web server, suitable for embedding in an application. The server is object oriented, and contains all of the fundamentals needed for a full service website. [para] [section {Minimal Example}] Starting a web service requires starting a class of type [cmd httpd::server], and providing that server with one or more URIs to service, and [cmd httpd::reply] derived classes to generate them. [example { oo::class create ::reply.hello { method content {} { my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>" my puts "<h1>Hello World!</h1>" my puts </BODY></HTML> } } ::httpd::server create HTTPD port 8015 myaddr 127.0.0.1 doc_root ~/htdocs HTTPD plugin dispatch httpd::server::dispatch HTTPD uri add * /hello [list mixin reply.hello] }] The bare module does have facilities to hose a files from a file system. Files that end in a .tml will be substituted in the style of Tclhttpd: [example { <!-- hello.tml --> [my html_header {Hello World!}] Your Server is running. <p> The time is now [clock format [clock seconds]] [my html_footer] }] A complete example of an httpd server is in the /examples directory of Tcllib. It also show how to dispatch URIs to other processes via SCGI and HTTP proxies. [example { cd ~/tcl/sandbox/tcllib tclsh examples/httpd.tcl }] |
Changes to modules/httpd/build/plugin.tcl.
1 2 3 | ### # httpd plugin template ### | | | | | | | | | > > > > | | | > | | | | | | | < | | < < < < < < < | | < < < > | | | < < < < < < < < < < < < < | > > > > > > | > > > > > > > > > > | | | | 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 | ### # httpd plugin template ### ::clay::define ::httpd::plugin { ### # Any options will be saved to the local config file # to allow threads to pull up a snapshot of the object' configuration ### ### # Define a code snippet to run on plugin load ### clay set plugin/ load {} ### # Define a code snippet to run within the object's Headers_Process method ### clay set plugin/ headers {} ### # Define a code snippet to run within the object's dispatch method ### clay set plugin/ dispatch {} ### # Define a code snippet to run within the object's writes a local config file ### clay set plugin/ local_config {} ### # When after all the plugins are loaded # allow specially configured ones to light off a thread ### clay set plugin/ thread {} } ### # A rudimentary plugin that dispatches URLs from a dict # data structure ### ::clay::define ::httpd::plugin.dict_dispatch { clay set plugin/ dispatch { set reply [my Dispatch_Dict $data] if {[dict size $reply]} { return $reply } } ### # Implementation of the dispatcher ### method Dispatch_Dict {data} { my variable url_patterns set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0] set uri [dict get $data http REQUEST_PATH] foreach {host hostpat} $url_patterns { if {![string match $host $vhost]} continue foreach {pattern info} $hostpat { if {![string match $pattern $uri]} continue set buffer $data foreach {f v} $info { dict set buffer $f $v } return $buffer } } return {} } ### # Ensemble uri::add {vhosts patterns info} { my variable url_patterns foreach vhost $vhosts { foreach pattern $patterns { set data $info if {![dict exists $data prefix]} { dict set data prefix [my PrefixNormalize $pattern] } dict set url_patterns $vhost [string trimleft $pattern /] $data } } } Ensemble uri::direct {vhosts patterns info body} { my variable url_patterns url_stream set cbody {} if {[dict exists $info superclass]} { append cbody \n "superclass {*}[dict get $info superclass]" dict unset info superclass } append cbody \n [list method content {} $body] set class [namespace current]::${vhosts}/${patterns} set class [string map {* %} $class] ::clay::define $class $cbody dict set info mixin content $class my uri add $vhosts $patterns $info } } ::clay::define ::httpd::reply.memchan { superclass ::httpd::reply method output {} { my variable reply_body return $reply_body } method DoOutput {} {} method close {} { # Neuter the channel closing mechanism we need the channel to stay alive # until the reader sucks out the info } } ::clay::define ::httpd::plugin.local_memchan { clay set plugin/ load { package require tcl::chan::events package require tcl::chan::memchan } method local_memchan {command args} { my variable sock_to_coro switch $command { |
︙ | ︙ | |||
157 158 159 160 161 162 163 | chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ -buffering line set ip 127.0.0.1 dict set query UUID $uuid | > | | | | | | | | | | | | | | | | < < < | | | | 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 | chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ -buffering line set ip 127.0.0.1 dict set query UUID $uuid dict set query http UUID $uuid dict set query http HTTP_HOST localhost dict set query http REMOTE_ADDR 127.0.0.1 dict set query http REMOTE_HOST localhost dict set query http LOCALHOST 1 my counter url_hit dict set query http REQUEST_METHOD [lindex $args 0] set uriinfo [::uri::split [lindex $args 1]] dict set query http REQUEST_URI [lindex $args 1] dict set query http REQUEST_PATH [dict get $uriinfo path] dict set query http REQUEST_VERSION [lindex [split [lindex $args end] /] end] dict set query http DOCUMENT_ROOT [my clay get server/ doc_root] dict set query http QUERY_STRING [dict get $uriinfo query] dict set query http REQUEST_RAW $args dict set query http SERVER_PORT [my port_listening] my Headers_Process query set reply [my dispatch $query] if {[llength $reply]==0} { my log BadLocation $uuid $query my log BadLocation $uuid $query dict set query http HTTP_STATUS 404 dict set query template notfound dict set query mixin reply ::httpd::content.template } set class ::httpd::reply.memchan set pageobj [$class create ::httpd::object::$uuid [self]] if {[dict exists $reply mixin]} { set mixinmap [dict get $reply mixin] } else { set mixinmap {} } foreach item [dict keys $reply MIXIN_*] { set slot [string range $reply 6 end] dict set mixinmap [string tolower $slot] [dict get $reply $item] } $pageobj clay mixinmap {*}$mixinmap if {[dict exists $reply delegate]} { $pageobj clay delegate {*}[dict get $reply delegate] } $pageobj dispatch $sock $reply set output [$pageobj output] catch {$pageobj destroy} return $output } } |
Changes to modules/httpd/build/proxy.tcl.
|
| | | 1 2 3 4 5 6 7 8 | ::clay::define ::httpd::content.exec { variable exename [list tcl [info nameofexecutable] .tcl [info nameofexecutable]] method CgiExec {execname script arglist} { if { $::tcl_platform(platform) eq "windows"} { if {[file extension $script] eq ".exe"} { return [open "|[list $script] $arglist" r+] } else { |
︙ | ︙ | |||
56 57 58 59 60 61 62 | return $result } } if {[dict exists exename $which]} { return [dict get $exename $which] } if {$which eq "tcl"} { | | | | | | | | | > | | | < > < < < < | < < | | | | | < < | | | < < < < < | | < < < < < < < < < > | | > > | | > | 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 | return $result } } if {[dict exists exename $which]} { return [dict get $exename $which] } if {$which eq "tcl"} { if {[my clay get tcl_exe] ne {}} { dict set exename $which [my clay get tcl_exe] } else { dict set exename $which [info nameofexecutable] } } else { if {[my clay get ${which}_exe] ne {}} { dict set exename $which [my clay get ${which}_exe] } elseif {"$::tcl_platform(platform)" == "windows"} { dict set exename $which $which.exe } else { dict set exename $which $which } } set result [dict get $exename $which] if {$ext ne {}} { dict set exename $ext $result } return $result } } ### # Return data from an proxy process ### ::clay::define ::httpd::content.proxy { superclass ::httpd::content.exec method proxy_channel {} { ### # This method returns a channel to the # proxied socket/stdout/etc ### error unimplemented } method proxy_path {} { set uri [string trimleft [my request get REQUEST_URI] /] set prefix [my clay get prefix] return /[string range $uri [string length $prefix] end] } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} chan puts $chanb "[my request get REQUEST_METHOD] [my proxy_path]" set mimetxt [my clay get mimetxt] chan puts $chanb [my clay get mimetxt] set length [my request get CONTENT_LENGTH] if {$length} { chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 ### # Send any POST/PUT/etc content ### my ChannelCopy $chana $chanb -size $length } else { chan flush $chanb } chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] chan event $chana readable {} set readCount [::coroutine::util::gets_safety $chana 4096 reply_status] set replyhead [my HttpHeaders $chana] set replydat [my MimeParse $replyhead] ### # Read the first incoming line as the HTTP reply status # Return the rest of the headers verbatim ### set replybuffer "$reply_status\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer ### # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 } method Dispatch {} { my variable sock chan if {[catch {my proxy_channel} sock errdat]} { my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo] tailcall my DoOutput } if {$sock eq {}} { my error 404 {Not Found} tailcall my DoOutput } my log HttpAccess {} chan event $sock writable [info coroutine] yield try { my ProxyRequest $chan $sock my ProxyReply $sock $chan } finally { my TransferComplete $chan $sock } } } |
Changes to modules/httpd/build/reply.tcl.
1 | ### | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > | | | > > > > > > | | | | | | | | > > > > > > > > > > > > > < < < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | < | | < | < < < < < | < < < < < < < < < < < < < < | | < | > > > | | | | 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 | ### # A class which shephards a request through the process of generating a # reply. # # The socket associated with the reply is available at all times as the [arg chan] # variable. # # The process of generating a reply begins with an [cmd httpd::server] generating a # [cmd http::class] object, mixing in a set of behaviors and then invoking the reply # object's [cmd dispatch] method. # # In normal operations the [cmd dispatch] method: # # [list_begin enumerated] # [enum] # Invokes the [cmd reset] method for the object to populate default headers. # [enum] # Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket # [enum] # Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a # dict that can be read via the [cmd request] method. # [enum] # Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object. # [enum] # Invokes the [cmd content] method for the object, generating an call to the [cmd error] # method if an exception is raised. # [enum] # Invokes the [cmd output] method for the object # [list_end] # [para] # # Developers have the option of streaming output to a buffer via the [cmd puts] method of the # reply, or simply populating the [arg reply_body] variable of the object. # The information returned by the [cmd content] method is not interpreted in any way. # # If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will # auto-generate a 500 {Internal Error} message. # # A typical implementation of [cmd content] look like: # # [example { # # clay::define ::test::content.file { # superclass ::httpd::content.file # # Return a file # # Note: this is using the content.file mixin which looks for the reply_file variable # # and will auto-compute the Content-Type # method content {} { # my reset # set doc_root [my request get DOCUMENT_ROOT] # my variable reply_file # set reply_file [file join $doc_root index.html] # } # } # clay::define ::test::content.time { # # return the current system time # method content {} { # my variable reply_body # my reply set Content-Type text/plain # set reply_body [clock seconds] # } # } # clay::define ::test::content.echo { # method content {} { # my variable reply_body # my reply set Content-Type [my request get CONTENT_TYPE] # set reply_body [my PostData [my request get CONTENT_LENGTH]] # } # } # clay::define ::test::content.form_handler { # method content {} { # set form [my FormData] # my reply set Content-Type {text/html; charset=UTF-8} # my puts [my html_header {My Dynamic Page}] # my puts "<BODY>" # my puts "You Sent<p>" # my puts "<TABLE>" # foreach {f v} $form { # my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>" # } # my puts "</TABLE><p>" # my puts "Send some info:<p>" # my puts "<FORM action=/[my request get REQUEST_PATH] method POST>" # my puts "<TABLE>" # foreach field {name rank serial_number} { # set line "<TR><TH>$field</TH><TD><input name=\"$field\" " # if {[dict exists $form $field]} { # append line " value=\"[dict get $form $field]\""" # } # append line " /></TD></TR>" # my puts $line # } # my puts "</TABLE>" # my puts [my html footer] # } # } # # }] ### ::clay::define ::httpd::reply { superclass ::httpd::mime Delegate <server> { description {The server object which spawned this reply} } ### # A dictionary which will converted into the MIME headers of the reply ### Dict reply {} ### # A dictionary containing the SCGI transformed HTTP headers for the request ### Dict request { CONTENT_LENGTH 0 COOKIE {} HTTP_HOST {} REFERER {} REQUEST_URI {} REMOTE_ADDR {} REMOTE_HOST {} USER_AGENT {} SESSION {} } constructor {ServerObj args} { my variable chan dispatched_time uuid set uuid [namespace tail [self]] set dispatched_time [clock milliseconds] my clay delegate <server> $ServerObj foreach {field value} [::clay::args_to_options {*}$args] { my clay set config $field: $value } } ### # clean up on exit ### destructor { my close } ### # Close channels opened by this object ### method close {} { my variable chan if {[info exists chan] && $chan ne {}} { catch {chan event $chan readable {}} catch {chan event $chan writable {}} catch {chan flush $chan} catch {chan close $chan} set chan {} } } ### # Record a dispatch event ### method Log_Dispatched {} { my log Dispatched [dict create \ REMOTE_ADDR [my request get REMOTE_ADDR] \ REMOTE_HOST [my request get REMOTE_HOST] \ COOKIE [my request get HTTP_COOKIE] \ REFERER [my request get HTTP_REFERER] \ USER_AGENT [my request get HTTP_USER_AGENT] \ REQUEST_URI [my request get REQUEST_URI] \ HTTP_HOST [my request get HTTP_HOST] \ SESSION [my request get SESSION] \ ] } ### # Accept the handoff from the server object of the socket # [emph newsock] and feed it the state [emph datastate]. # Fields the [emph datastate] are looking for in particular are: # [para] # * [const mixin] - A key/value list of slots and classes to be mixed into the # object prior to invoking [cmd Dispatch]. # [para] # * [const http] - A key/value list of values to populate the object's [emph request] # ensemble # [para] # All other fields are passed along to the [method clay] structure of the object. ### method dispatch {newsock datastate} { my variable chan request try { set chan $newsock chan event $chan readable {} chan configure $chan -translation {auto crlf} -buffering line if {[dict exists $datastate mixin]} { set mixinmap [dict get $datastate mixin] } else { set mixinmap {} } foreach item [dict keys $datastate MIXIN_*] { set slot [string range $item 6 end] dict set mixinmap [string tolower $slot] [dict get $datastate $item] } my clay mixinmap {*}$mixinmap if {[dict exists $datastate delegate]} { my clay delegate {*}[dict get $datastate delegate] } my reset set request [my clay get dict/ request] foreach {f v} $datastate { if {[string index $f end] eq "/"} { my clay merge $f $v } else { my clay set $f $v } if {$f eq "http"} { foreach {ff vf} $v { dict set request $ff $vf } } } my Session_Load my Log_Dispatched my Dispatch } on error {err errdat} { my error 500 $err [dict get $errdat -errorinfo] my DoOutput } } method Dispatch {} { # Invoke the URL implementation. my content my DoOutput } method html_header {title args} { set result {} append result "<HTML><HEAD>" if {$title ne {}} { append result "<TITLE>$title</TITLE>" } append result "</HEAD><BODY>" append result \n {<div id="top-menu">} if {[dict exists $args banner]} { append result "<img src=\"[dict get $args banner]\">" } else { append result {<img src="/images/etoyoc-banner.jpg">} } append result {</div>} if {[dict exists $args sideimg]} { append result "\n<div name=\"sideimg\"><img align=right src=\"[dict get $args sideimg]\"></div>" } append result {<div id="content">} return $result } method html_footer {args} { set result {</div><div id="footer">} append result {</div></BODY></HTML>} } method error {code {msg {}} {errorInfo {}}} { my clay set HTTP_ERROR $code my reset set qheaders [my clay dump] set HTTP_STATUS "$code [my http_code_string $code]" dict with qheaders {} my reply replace {} my reply set Status $HTTP_STATUS my reply set Content-Type {text/html; charset=UTF-8} switch $code { 301 - 302 - 303 - 307 - 308 { my reply set Location $msg set template [my <server> template redirect] } 404 { set template [my <server> template notfound] } default { set template [my <server> template internal_error] } } my puts [subst $template] } ### # REPLACE ME: # This method is the "meat" of your application. # It writes to the result buffer via the "puts" method # and can tweak the headers via "clay put header_reply" ### method content {} { my puts [my html_header {Hello World!}] my puts "<H1>HELLO WORLD!</H1>" my puts [my html_footer] } ### # Formulate a standard HTTP status header from he string provided. ### method EncodeStatus {status} { return "HTTP/1.0 $status" } method log {type {info {}}} { my variable dispatched_time uuid my <server> log $type $uuid $info } method CoroName {} { if {[info coroutine] eq {}} { return ::httpd::object::[my clay get UUID] } } ### # Generates the the HTTP reply, streams that reply back across [arg chan], # and destroys the object. ### method DoOutput {} { my variable reply_body chan if {$chan eq {}} return catch { my wait writable $chan chan configure $chan -translation {binary binary} |
︙ | ︙ | |||
195 196 197 198 199 200 201 202 203 204 205 206 207 | } chan puts -nonewline $chan $result my log HttpAccess {} } my destroy } method FormData {} { my variable chan formdata # Run this only once if {[info exists formdata]} { return $formdata } | > > > > > > > > > < < < | < | | | 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 | } chan puts -nonewline $chan $result my log HttpAccess {} } my destroy } ### # For GET requests, converts the QUERY_DATA header into a key/value list. # # For POST requests, reads the Post data and converts that information to # a key/value list for application/x-www-form-urlencoded posts. For multipart # posts, it composites all of the MIME headers of the post to a singular key/value # list, and provides MIME_* information as computed by the [cmd mime] package, including # the MIME_TOKEN, which can be fed back into the mime package to read out the contents. ### method FormData {} { my variable chan formdata # Run this only once if {[info exists formdata]} { return $formdata } set length [my request get CONTENT_LENGTH] set formdata {} if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} { set rawtype [my request get CONTENT_TYPE] if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} { set type $rawtype } else { set type multipart } switch $type { multipart { ### # Ok, Multipart MIME is troublesome, farm out the parsing to a dedicated tool ### set body [my clay get mimetxt] append body \n [my PostData $length] set token [::mime::initialize -string $body] foreach item [::mime::getheader $token -names] { dict set formdata $item [::mime::getheader $token $item] } foreach item {content encoding params parts size} { dict set formdata MIME_[string toupper $item] [::mime::getproperty $token $item] |
︙ | ︙ | |||
243 244 245 246 247 248 249 | foreach {name value} [split $pair "="] { lappend formdata [my Url_Decode $name] [my Url_Decode $value] } } } } } else { | | > > | > > > > > > > > > > > > > > > > > > > > > > > > < < < | | > | > > > > | | | | | | | | | | | | | | | | | < | | | | | | | | | | | > > | > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | > > | > > | | > | < < > > | | | | > | | 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 | foreach {name value} [split $pair "="] { lappend formdata [my Url_Decode $name] [my Url_Decode $value] } } } } } else { foreach pair [split [my clay get QUERY_STRING] "&"] { foreach {name value} [split $pair "="] { lappend formdata [my Url_Decode $name] [my Url_Decode $value] } } } return $formdata } # Stream [arg length] bytes from the [arg chan] socket, but only of the request is a # POST or PUSH. Returns an empty string otherwise. method PostData {length} { my variable postdata # Run this only once if {[info exists postdata]} { return $postdata } set postdata {} if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} { my variable chan chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 set postdata [::coroutine::util::read $chan $length] } return $postdata } # Manage session data method Session_Load {} {} # Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel # fed to it on the command line, and then destroys the object. # # [example { # ### # # Output the body # ### # chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 # chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 # if {$length} { # ### # # Send any POST/PUT/etc content # ### # chan copy $sock $chan -size $SIZE -command [info coroutine] # yield # } # catch {close $sock} # chan flush $chan # }] method TransferComplete args { my log TransferComplete set chan {} foreach c $args { catch {chan event $c readable {}} catch {chan event $c writable {}} catch {chan flush $c} catch {chan close $c} } my destroy } # Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline # character. method puts line { my variable reply_body append reply_body $line \n } method RequestFind {field} { my variable request if {[dict exists $request $field]} { return $field } foreach item [dict keys $request] { if {[string tolower $item] eq [string tolower $field]} { return $item } } return $field } method request {subcommand args} { my variable request switch $subcommand { dump { return $request } field { tailcall my RequestFind [lindex $args 0] } get { set field [my RequestFind [lindex $args 0]] if {![dict exists $request $field]} { return {} } tailcall dict get $request $field } getnull { set field [my RequestFind [lindex $args 0]] if {![dict exists $request $field]} { return {} } tailcall dict get $request $field } exists { set field [my RequestFind [lindex $args 0]] tailcall dict exists $request $field } parse { if {[catch {my MimeParse [lindex $args 0]} result]} { my error 400 $result tailcall my DoOutput } set request $result } replace { set request [lindex $args 0] } set { dict set request {*}$args } default { error "Unknown command $subcommand. Valid: field, get, getnull, exists, parse, replace, set" } } } method reply {subcommand args} { my variable reply switch $subcommand { dump { return $reply } exists { return [dict exists $reply {*}$args] } get - getnull { return [dict getnull $reply {*}$args] } replace { set reply [my HttpHeaders_Default] if {[llength $args]==1} { foreach {f v} [lindex $args 0] { dict set reply $f $v } } else { foreach {f v} $args { dict set reply $f $v } } } output { set result {} if {![dict exists $reply Status]} { set status {200 OK} } else { set status [dict get $reply Status] } set result "[my EncodeStatus $status]\n" foreach {f v} $reply { if {$f in {Status}} continue append result "[string trimright $f :]: $v\n" } #append result \n return $result } set { dict set reply {*}$args } default { error "Unknown command $subcommand. Valid: exists, get, getnull, output, replace, set" } } } # Clear the contents of the [arg reply_body] variable, and reset all headers in the [cmd reply] # structure back to the defaults for this object. method reset {} { my variable reply_body my reply replace [my HttpHeaders_Default] my reply set Server [my <server> clay get server/ string] my reply set Date [my timestamp] set reply_body {} } # Called from the [cmd http::server] object which spawned this reply. Checks to see # if too much time has elapsed while waiting for data or generating a reply, and issues # a timeout error to the request if it has, as well as destroy the object and close the # [arg chan] socket. method timeOutCheck {} { my variable dispatched_time if {([clock seconds]-$dispatched_time)>120} { ### # Something has lasted over 2 minutes. Kill this ### catch { my error 408 {Request Timed out} my DoOutput } } } ### # Return the current system time in the format: [example {%a, %d %b %Y %T %Z}] ### method timestamp {} { return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}] } } |
Changes to modules/httpd/build/scgi.tcl.
1 2 3 | ### # Return data from an SCGI process ### | > > > > > > > | > | | | > | < > < < < < < < < | | | | | < < < < < < | < < < < < | | | | | > > | > | > < < | < < | < | | | | | | | > > | | | < | > > > | | < < < < < < < < < < < < < < < < < < < < | < < > | < < < | < | | | | | | | < > | 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 | ### # Return data from an SCGI process ### ::clay::define ::httpd::protocol.scgi { method EncodeStatus {status} { return "Status: $status" } } ::clay::define ::httpd::content.scgi { superclass ::httpd::content.proxy method scgi_info {} { ### # This method should check if a process is launched # or launch it if needed, and return a list of # HOST PORT SCRIPT_NAME ### # return {localhost 8016 /some/path} error unimplemented } method proxy_channel {} { set sockinfo [my scgi_info] if {$sockinfo eq {}} { my error 404 {Not Found} tailcall my DoOutput } lassign $sockinfo scgihost scgiport scgiscript my clay set SCRIPT_NAME $scgiscript if {![string is integer $scgiport]} { my error 404 {Not Found} tailcall my DoOutput } return [::socket $scgihost $scgiport] } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my clay get SCRIPT_NAME]] foreach {f v} [my request dump] { dict set info $f $v } set length [dict get $info CONTENT_LENGTH] set block {} foreach {f v} $info { append block [string toupper $f] \x00 $v \x00 } chan puts -nonewline $chanb "[string length $block]:$block," # Light off another coroutine #set cmd [list coroutine [my CoroName] {*}[namespace code [list my ProxyReply $chanb $chana]]] if {$length} { chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 ### # Send any POST/PUT/etc content ### my ChannelCopy $chana $chanb -size $length #chan copy $chana $chanb -size $length -command [info coroutine] } else { chan flush $chanb } chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] chan event $chana readable {} set replyhead [my HttpHeaders $chana] set replydat [my MimeParse $replyhead] ### # Convert the Status: header from the CGI process to # a standard service reply line from a web server, but # otherwise spit out the rest of the headers verbatim ### set replybuffer "HTTP/1.0 [dict get $replydat Status]\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer ### # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 } } ### # Act as an SCGI Server ### ::clay::define ::httpd::server.scgi { superclass ::httpd::server clay set socket/ buffersize 32768 clay set socket/ blocking 0 clay set socket/ translation {binary binary} method debug args { puts $args } method Connect {uuid sock ip} { yield [info coroutine] chan event $sock readable {} chan configure $sock \ -blocking 1 \ -translation {binary binary} \ -buffersize 4096 \ -buffering none my counter url_hit try { # Read the SCGI request on byte at a time until we reach a ":" dict set query http HTTP_HOST {} dict set query http CONTENT_LENGTH 0 dict set query http REQUEST_URI / dict set query http REMOTE_ADDR $ip set size {} while 1 { set char [::coroutine::util::read $sock 1] if {[chan eof $sock]} { catch {close $sock} return } if {$char eq ":"} break append size $char } # With length in hand, read the netstring encoded headers set inbuffer [::coroutine::util::read $sock [expr {$size+1}]] chan configure $sock -blocking 0 -buffersize 4096 -buffering full foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] { dict set query http $f $v } if {![dict exists $query http REQUEST_PATH]} { set uri [dict get $query http REQUEST_URI] set uriinfo [::uri::split $uri] dict set query http REQUEST_PATH [dict get $uriinfo path] } set reply [my dispatch $query] } on error {err errdat} { my debug [list uri: [dict getnull $query http REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"} catch {chan event readable $sock {}} catch {chan event writeable $sock {}} catch {chan close $sock} return } if {[dict size $reply]==0} { my log BadLocation $uuid $query dict set query http HTTP_STATUS 404 dict set query template notfound dict set query mixin reply ::httpd::content.template } try { set pageobj [::httpd::reply create ::httpd::object::$uuid [self]] dict set reply mixin protocol ::httpd::protocol.scgi $pageobj dispatch $sock $reply } on error {err errdat} { my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] catch {$pageobj destroy} catch {chan event readable $sock {}} catch {chan event writeable $sock {}} catch {chan close $sock} return } } } |
Changes to modules/httpd/build/server.tcl.
1 | ### | | < > > > | | | | | | | | > | | | | | | | > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < | < < < < < < < < < < < < | < < < < < < < | | < < | < | | | | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | | | < > > | > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | | | > > > > > > | > | > | | | | > > > > | | | | > > > | > > > > > > > > > | | | | | | | | | | > > > > > > > > > > > | | | | > > | | 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 | ### # An httpd server with a template engine and a shim to insert URL domains. # # This class is the root object of the webserver. It is responsible # for opening the socket and providing the initial connection negotiation. ### namespace eval ::httpd::object {} namespace eval ::httpd::coro {} ::clay::define ::httpd::server { superclass ::httpd::mime clay set server/ port auto clay set server/ myaddr 127.0.0.1 clay set server/ string [list TclHttpd $::httpd::version] clay set server/ name [info hostname] clay set server/ doc_root {} clay set server/ reverse_dns 0 clay set server/ configuration_file {} clay set server/ protocol {HTTP/1.1} clay set socket/ buffersize 32768 clay set socket/ translation {auto crlf} clay set reply_class ::httpd::reply Array template Dict url_patterns {} constructor { {args { port {default auto comment {Port to listen on}} myaddr {default 127.0.0.1 comment {IP address to listen on. "all" means all}} string {default auto comment {Value for SERVER_SOFTWARE in HTTP headers}} name {default auto comment {Value for SERVER_NAME in HTTP headers. Defaults to [info hostname]}} doc_root {default {} comment {File path to serve.}} reverse_dns {default 0 comment {Perform reverse DNS to convert IPs into hostnames}} configuration_file {default {} comment {Configuration file to load into server namespace}} protocol {default {HTTP/1.1} comment {Value for SERVER_PROTOCOL in HTTP headers}} }}} { if {[llength $args]==1} { set arglist [lindex $args 0] } else { set arglist $args } foreach {var val} $arglist { my clay set server/ $var $val } my start } destructor { my stop } ### # Reply to an open socket. This method builds a coroutine to manage the remainder # of the connection. The coroutine's operations are driven by the [cmd Connect] method. ### method connect {sock ip port} { ### # If an IP address is blocked drop the # connection ### if {[my Validate_Connection $sock $ip]} { catch {close $sock} return } set uuid [my Uuid_Generate] set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]] chan event $sock readable $coro } method ServerHeaders {ip http_request mimetxt} { set result {} dict set result HTTP_HOST {} dict set result CONTENT_LENGTH 0 foreach {f v} [my MimeParse $mimetxt] { set fld [string toupper [string map {- _} $f]] if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} { set qfld $fld } else { set qfld HTTP_$fld } dict set result $qfld $v } dict set result REMOTE_ADDR $ip dict set result REMOTE_HOST [my HostName $ip] dict set result REQUEST_METHOD [lindex $http_request 0] set uriinfo [::uri::split [lindex $http_request 1]] dict set result uriinfo $uriinfo dict set result REQUEST_URI [lindex $http_request 1] dict set result REQUEST_PATH [dict get $uriinfo path] dict set result REQUEST_VERSION [lindex [split [lindex $http_request end] /] end] dict set result DOCUMENT_ROOT [my clay get server/ doc_root] dict set result QUERY_STRING [dict get $uriinfo query] dict set result REQUEST_RAW $http_request dict set result SERVER_PORT [my port_listening] dict set result SERVER_NAME [my clay get server/ name] dict set result SERVER_PROTOCOL [my clay get server/ protocol] dict set result SERVER_SOFTWARE [my clay get server/ string] if {[string match 127.* $ip]} { dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}] } return $result } ### # This method reads HTTP headers, and then consults the [cmd dispatch] method to # determine if the request is valid, and/or what kind of reply to generate. Under # normal cases, an object of class [cmd ::http::reply] is created, and that class's # [cmd dispatch] method. # This action passes control of the socket to # the reply object. The reply object manages the rest of the transaction, including # closing the socket. ### method Connect {uuid sock ip} { yield [info coroutine] chan event $sock readable {} chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ -buffering line my counter url_hit try { set readCount [::coroutine::util::gets_safety $sock 4096 http_request] set mimetxt [my HttpHeaders $sock] dict set query UUID $uuid dict set query mimetxt $mimetxt dict set query mixin style [my clay get server/ style] dict set query http [my ServerHeaders $ip $http_request $mimetxt] my Headers_Process query set reply [my dispatch $query] } on error {err errdat} { my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"} catch {chan close $sock} return } if {[dict size $reply]==0} { set reply $query my log BadLocation $uuid $query dict set reply http HTTP_STATUS {404 Not Found} dict set reply template notfound dict set reply mixin reply ::httpd::content.template } set pageobj [::httpd::reply create ::httpd::object::$uuid [self]] tailcall $pageobj dispatch $sock $reply } # Increment an internal counter. method counter which { my variable counters incr counters($which) } ### # Check open connections for a time out event. ### method CheckTimeout {} { foreach obj [info commands ::httpd::object::*] { try { $obj timeOutCheck } on error {} { catch {$obj destroy} } } } method debug args {} ### # Given a key/value list of information, return a data structure describing how # the server should reply. ### method dispatch {data} { set reply [my Dispatch_Local $data] if {[dict size $reply]} { return $reply } return [my Dispatch_Default $data] } ### # Method dispatch method of last resort before returning a 404 NOT FOUND error. # The default behavior is to look for a file in [emph DOCUMENT_ROOT] which # matches the query. ### method Dispatch_Default {reply} { ### # Fallback to docroot handling ### set doc_root [dict getnull $reply http DOCUMENT_ROOT] if {$doc_root ne {}} { ### # Fall back to doc_root handling ### dict set reply prefix {} dict set reply path $doc_root dict set reply mixin reply httpd::content.file return $reply } return {} } ### # Method dispatch method invoked prior to invoking methods implemented by plugins. # If this method returns a non-empty dictionary, that structure will be passed to # the reply. The default is an empty implementation. ### method Dispatch_Local data {} ### # Introspect and possibly modify a data structure destined for a reply. This # method is invoked before invoking Header methods implemented by plugins. # The default implementation is empty. ### method Headers_Local {varname} {} ### # Introspect and possibly modify a data structure destined for a reply. This # method is built dynamically by the [cmd plugin] method. ### method Headers_Process varname {} ### # Convert an ip address to a host name. If the server/ reverse_dns flag # is false, this method simply returns the IP address back. # Internally, this method uses the [emph dns] module from tcllib. ### method HostName ipaddr { if {![my clay get server/ reverse_dns]} { return $ipaddr } set t [::dns::resolve $ipaddr] set result [::dns::name $t] ::dns::cleanup $t return $result } ### # Log an event. The input for args is free form. This method is intended # to be replaced by the user, and is a noop for a stock http::server object. ### method log args { # Do nothing for now } ### # Incorporate behaviors from a plugin. # This method dynamically rebuilds the [cmd Dispatch] and [cmd Headers] # method. For every plugin, the server looks for the following entries in # [emph "clay plugin/"]: # [para] # [emph load] - A script to invoke in the server's namespace during the [cmd plugin] method invokation. # [para] # [emph dispatch] - A script to stitch into the server's [cmd Dispatch] method. # [para] # [emph headers] - A script to stitch into the server's [cmd Headers] method. # [para] # [emph thread] - A script to stitch into the server's [cmd Thread_start] method. ### method plugin {slot {class {}}} { if {$class eq {}} { set class ::httpd::plugin.$slot } if {[info command $class] eq {}} { error "Class $class for plugin $slot does not exist" } my clay mixinmap $slot $class set mixinmap [my clay mixinmap] ### # Perform action on load ### set script [$class clay search plugin/ load] eval $script ### # rebuild the dispatch method ### set body "\n try \{" append body \n { set reply [my Dispatch_Local $data] if {[dict size $reply]} {return $reply} } foreach {slot class} $mixinmap { set script [$class clay search plugin/ dispatch] if {[string length $script]} { append body \n "# SLOT $slot" append body \n $script } } append body \n { return [my Dispatch_Default $data]} append body \n "\} on error \{err errdat\} \{" append body \n { puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}} append body \n "\}" oo::objdefine [self] method dispatch data $body ### # rebuild the Headers_Process method ### set body "\n try \{" append body \n " upvar 1 \$varname query" append body \n { my Headers_Local query} foreach {slot class} $mixinmap { set script [$class clay search plugin/ headers] if {[string length $script]} { append body \n "# SLOT $slot" append body \n $script } } append body \n "\} on error \{err errdat\} \{" append body \n { puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}} append body \n "\}" oo::objdefine [self] method Headers_Process varname $body ### # rebuild the Threads_Start method ### set body "\n try \{" foreach {slot class} $mixinmap { set script [$class clay search plugin/ thread] if {[string length $script]} { append body \n "# SLOT $slot" append body \n $script } } append body \n "\} on error \{err errdat\} \{" append body \n { puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}} append body \n "\}" oo::objdefine [self] method Thread_start {} $body } # Return the actual port that httpd is listening on. method port_listening {} { my variable port_listening return $port_listening } # For the stock version, trim trailing /'s and *'s from a prefix. This # method can be replaced by the end user to perform any other transformations # needed for the application. method PrefixNormalize prefix { set prefix [string trimright $prefix /] set prefix [string trimright $prefix *] set prefix [string trimright $prefix /] return $prefix } method source {filename} { source $filename } # Open the socket listener. method start {} { # Build a namespace to contain replies namespace eval [namespace current]::reply {} my variable socklist port_listening if {[my clay get server/ configuration_file] ne {}} { source [my clay get server/ configuration_file] } set port [my clay get server/ port] if { $port in {auto {}} } { package require nettool set port [::nettool::allocate_port 8015] } set port_listening $port set myaddr [my clay get server/ myaddr] my debug [list [self] listening on $port $myaddr] if {$myaddr ni {all any * {}}} { foreach ip $myaddr { lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port] } } else { lappend socklist [socket -server [namespace code [list my connect]] $port] } ::cron::every [self] 120 [namespace code {my CheckTimeout}] my Thread_start } # Shut off the socket listener, and destroy any pending replies. method stop {} { my variable socklist if {[info exists socklist]} { foreach sock $socklist { catch {close $sock} } } set socklist {} ::cron::cancel [self] } Ensemble SubObject::db {} { return [namespace current]::Sqlite_db } Ensemble SubObject::default {} { return [namespace current]::$method } # Return a template for the string [arg page] method template page { my variable template if {[info exists template($page)]} { return $template($page) } set template($page) [my TemplateSearch $page] return $template($page) } # Perform a search for the template that best matches [arg page]. This # can include local file searches, in-memory structures, or even # database lookups. The stock implementation simply looks for files # with a .tml or .html extension in the [opt doc_root] directory. method TemplateSearch page { set doc_root [my clay get server/ doc_root] if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} { return [::fileutil::cat [file join $doc_root $page.tml]] } if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} { return [::fileutil::cat [file join $doc_root $page.html]] } switch $page { redirect { return { [my html_header "$HTTP_STATUS"] The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved. <p> If your browser does not automatically load the new location, it is <a href=\"$msg\">$msg</a> [my html_footer] } } internal_error { return { [my html_header "$HTTP_STATUS"] Error serving <b>[my request get REQUEST_URI]</b>: <p> The server encountered an internal server error: <pre>$msg</pre> <pre><code> $errorInfo </code></pre> [my html_footer] } } notfound { return { [my html_header "$HTTP_STATUS"] The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist. [my html_footer] } } } } ### # Built by the [cmd plugin] method. Called by the [cmd start] method. Intended # to allow plugins to spawn worker threads. ### method Thread_start {} {} ### # Generate a GUUID. Used to ensure every request has a unique ID. # The default implementation is: # [example { # return [::clay::uuid generate] # }] ### method Uuid_Generate {} { return [::clay::uuid::short] } ### # Given a socket and an ip address, return true if this connection should # be terminated, or false if it should be allowed to continue. The stock # implementation always returns 0. This is intended for applications to # be able to implement black lists and/or provide security based on IP # address. ### method Validate_Connection {sock ip} { return 0 } } ### # Provide a backward compadible alias ### ::clay::define ::httpd::server::dispatch { superclass ::httpd::server } |
Changes to modules/httpd/build/websocket.tcl.
1 2 3 | ### # Upgrade a connection to a websocket ### | | | 1 2 3 4 5 6 | ### # Upgrade a connection to a websocket ### ::clay::define ::httpd::content.websocket { } |
Changes to modules/httpd/httpd.man.
|
| < > | < | < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | [comment {-*- tcl -*- doctools manpage}] [vset PACKAGE_VERSION 4.3.3] [manpage_begin httpd n [vset PACKAGE_VERSION]] [keywords WWW] [copyright {2018 Sean Woods <[email protected]>}] [moddesc {Tcl Web Server}] [titledesc {A TclOO and coroutine based web server}] [category Networking] [keywords TclOO] [keywords http] [keywords httpd] [keywords httpserver] [keywords services] [require Tcl 8.6] [require uuid] [require clay] [require coroutine] [require fileutil] [require fileutil::magic::filetype] [require websocket] [require mime] [require cron] [require uri] |
︙ | ︙ | |||
38 39 40 41 42 43 44 | [section {Minimal Example}] Starting a web service requires starting a class of type [cmd httpd::server], and providing that server with one or more URIs to service, and [cmd httpd::reply] derived classes to generate them. [example { | | | > | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 | [section {Minimal Example}] Starting a web service requires starting a class of type [cmd httpd::server], and providing that server with one or more URIs to service, and [cmd httpd::reply] derived classes to generate them. [example { oo::class create ::reply.hello { method content {} { my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>" my puts "<h1>Hello World!</h1>" my puts </BODY></HTML> } } ::httpd::server create HTTPD port 8015 myaddr 127.0.0.1 doc_root ~/htdocs HTTPD plugin dispatch httpd::server::dispatch HTTPD uri add * /hello [list mixin reply.hello] }] The bare module does have facilities to hose a files from a file system. Files that end in a .tml will be substituted in the style of Tclhttpd: [example { <!-- hello.tml --> [my html_header {Hello World!}] Your Server is running. <p> The time is now [clock format [clock seconds]] [my html_footer] }] A complete example of an httpd server is in the /examples directory of Tcllib. It also show how to dispatch URIs to other processes via SCGI and HTTP proxies. [example { cd ~/tcl/sandbox/tcllib tclsh examples/httpd.tcl }] [section Classes] [subsection {Class httpd::mime}] A metaclass for MIME handling behavior across a live socket [para] [class {Methods}] [list_begin definitions] [call method [cmd "ChannelCopy"] [arg in] [arg out] [opt "[arg args]"]] [call method [cmd "html_header"] [opt "[arg title] [const ""]"] [opt "[arg args]"]] Returns a block of HTML [call method [cmd "html_footer"] [opt "[arg args]"]] [call method [cmd "http_code_string"] [arg code]] [call method [cmd "HttpHeaders"] [arg sock] [opt "[arg debug] [const ""]"]] [call method [cmd "HttpHeaders_Default"]] [call method [cmd "HttpServerHeaders"]] [call method [cmd "MimeParse"] [arg mimetext]] Converts a block of mime encoded text to a key/value list. If an exception is encountered, the method will generate its own call to the [cmd error] method, and immediately invoke the [cmd output] method to produce an error code and close the connection. [call method [cmd "Url_Decode"] [arg data]] De-httpizes a string. [call method [cmd "Url_PathCheck"] [arg urlsuffix]] [call method [cmd "wait"] [arg mode] [arg sock]] [list_end] [para] [subsection {Class httpd::reply}] [emph "ancestors"]: [class httpd::mime] [para] A class which shephards a request through the process of generating a reply. The socket associated with the reply is available at all times as the [arg chan] variable. The process of generating a reply begins with an [cmd httpd::server] generating a [cmd http::class] object, mixing in a set of behaviors and then invoking the reply object's [cmd dispatch] method. In normal operations the [cmd dispatch] method: [list_begin enumerated] [enum] Invokes the [cmd reset] method for the object to populate default headers. [enum] Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket [enum] Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a dict that can be read via the [cmd request] method. [enum] Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object. [enum] Invokes the [cmd content] method for the object, generating an call to the [cmd error] method if an exception is raised. [enum] Invokes the [cmd output] method for the object [list_end] [para] Developers have the option of streaming output to a buffer via the [cmd puts] method of the reply, or simply populating the [arg reply_body] variable of the object. The information returned by the [cmd content] method is not interpreted in any way. If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will auto-generate a 500 {Internal Error} message. A typical implementation of [cmd content] look like: [example { clay::define ::test::content.file { superclass ::httpd::content.file # Return a file # Note: this is using the content.file mixin which looks for the reply_file variable # and will auto-compute the Content-Type method content {} { my reset set doc_root [my request get DOCUMENT_ROOT] my variable reply_file set reply_file [file join $doc_root index.html] } } clay::define ::test::content.time { # return the current system time method content {} { my variable reply_body my reply set Content-Type text/plain set reply_body [clock seconds] } } clay::define ::test::content.echo { method content {} { my variable reply_body my reply set Content-Type [my request get CONTENT_TYPE] set reply_body [my PostData [my request get CONTENT_LENGTH]] } } clay::define ::test::content.form_handler { method content {} { set form [my FormData] my reply set Content-Type {text/html; charset=UTF-8} my puts [my html_header {My Dynamic Page}] my puts "<BODY>" my puts "You Sent<p>" my puts "<TABLE>" foreach {f v} $form { my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>" } my puts "</TABLE><p>" my puts "Send some info:<p>" my puts "<FORM action=/[my request get REQUEST_PATH] method POST>" my puts "<TABLE>" foreach field {name rank serial_number} { set line "<TR><TH>$field</TH><TD><input name=\"$field\" " if {[dict exists $form $field]} { append line " value=\"[dict get $form $field]\""" } append line " /></TD></TR>" my puts $line } my puts "</TABLE>" my puts [my html footer] } } }] [para] [class {Delegate}] [list_begin definitions] [call delegate [cmd <server>]]The server object which spawned this reply [list_end] [para] [class {Variable}] [list_begin definitions] [call variable [cmd reply]] A dictionary which will converted into the MIME headers of the reply [call variable [cmd request]] A dictionary containing the SCGI transformed HTTP headers for the request [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "constructor"] [arg ServerObj] [opt "[arg args]"]] [call method [cmd "destructor"] [opt "[arg dictargs]"]] clean up on exit [call method [cmd "close"]] Close channels opened by this object [call method [cmd "Log_Dispatched"]] Record a dispatch event [call method [cmd "dispatch"] [arg newsock] [arg datastate]] Accept the handoff from the server object of the socket [emph newsock] and feed it the state [emph datastate]. Fields the [emph datastate] are looking for in particular are: [para] * [const mixin] - A key/value list of slots and classes to be mixed into the object prior to invoking [cmd Dispatch]. [para] * [const http] - A key/value list of values to populate the object's [emph request] ensemble [para] All other fields are passed along to the [method clay] structure of the object. [call method [cmd "Dispatch"]] [call method [cmd "html_header"] [arg title] [opt "[arg args]"]] [call method [cmd "html_footer"] [opt "[arg args]"]] [call method [cmd "error"] [arg code] [opt "[arg msg] [const ""]"] [opt "[arg errorInfo] [const ""]"]] [call method [cmd "content"]] REPLACE ME: This method is the "meat" of your application. It writes to the result buffer via the "puts" method and can tweak the headers via "clay put header_reply" [call method [cmd "EncodeStatus"] [arg status]] Formulate a standard HTTP status header from he string provided. [call method [cmd "log"] [arg type] [opt "[arg info] [const ""]"]] [call method [cmd "CoroName"]] [call method [cmd "DoOutput"]] Generates the the HTTP reply, streams that reply back across [arg chan], and destroys the object. [call method [cmd "FormData"]] For GET requests, converts the QUERY_DATA header into a key/value list. For POST requests, reads the Post data and converts that information to a key/value list for application/x-www-form-urlencoded posts. For multipart posts, it composites all of the MIME headers of the post to a singular key/value list, and provides MIME_* information as computed by the [cmd mime] package, including the MIME_TOKEN, which can be fed back into the mime package to read out the contents. [call method [cmd "PostData"] [arg length]] Stream [arg length] bytes from the [arg chan] socket, but only of the request is a POST or PUSH. Returns an empty string otherwise. [call method [cmd "Session_Load"]] Manage session data [call method [cmd "TransferComplete"] [opt "[arg args]"]] Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel fed to it on the command line, and then destroys the object. [example { ### # Output the body ### chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 if {$length} { ### # Send any POST/PUT/etc content ### chan copy $sock $chan -size $SIZE -command [info coroutine] yield } catch {close $sock} chan flush $chan }] [call method [cmd "puts"] [arg line]] Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline character. [call method [cmd "RequestFind"] [arg field]] [call method [cmd "request"] [arg subcommand] [opt "[arg args]"]] [call method [cmd "reply"] [arg subcommand] [opt "[arg args]"]] [call method [cmd "reset"]] Clear the contents of the [arg reply_body] variable, and reset all headers in the [cmd reply] structure back to the defaults for this object. [call method [cmd "timeOutCheck"]] Called from the [cmd http::server] object which spawned this reply. Checks to see if too much time has elapsed while waiting for data or generating a reply, and issues a timeout error to the request if it has, as well as destroy the object and close the [arg chan] socket. [call method [cmd "timestamp"]] Return the current system time in the format: [example {%a, %d %b %Y %T %Z}] [list_end] [para] [subsection {Class httpd::server}] [emph "ancestors"]: [class httpd::mime] [para] [para] [class {Variable}] [list_begin definitions] [call variable [cmd template]] [call variable [cmd url_patterns]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "constructor"] [arg args] [opt "[arg port] [const "auto"]"] [opt "[arg myaddr] [const "127.0.0.1"]"] [opt "[arg string] [const "auto"]"] [opt "[arg name] [const "auto"]"] [opt "[arg doc_root] [const ""]"] [opt "[arg reverse_dns] [const "0"]"] [opt "[arg configuration_file] [const ""]"] [opt "[arg protocol] [const "HTTP/1.1"]"]] [call method [cmd "destructor"] [opt "[arg dictargs]"]] [call method [cmd "connect"] [arg sock] [arg ip] [arg port]] Reply to an open socket. This method builds a coroutine to manage the remainder of the connection. The coroutine's operations are driven by the [cmd Connect] method. [call method [cmd "ServerHeaders"] [arg ip] [arg http_request] [arg mimetxt]] [call method [cmd "Connect"] [arg uuid] [arg sock] [arg ip]] This method reads HTTP headers, and then consults the [cmd dispatch] method to determine if the request is valid, and/or what kind of reply to generate. Under normal cases, an object of class [cmd ::http::reply] is created, and that class's [cmd dispatch] method. This action passes control of the socket to the reply object. The reply object manages the rest of the transaction, including closing the socket. [call method [cmd "counter"] [arg which]] Increment an internal counter. [call method [cmd "CheckTimeout"]] Check open connections for a time out event. [call method [cmd "debug"] [opt "[arg args]"]] [call method [cmd "dispatch"] [arg data]] Given a key/value list of information, return a data structure describing how the server should reply. [call method [cmd "Dispatch_Default"] [arg reply]] Method dispatch method of last resort before returning a 404 NOT FOUND error. The default behavior is to look for a file in [emph DOCUMENT_ROOT] which matches the query. [call method [cmd "Dispatch_Local"] [arg data]] Method dispatch method invoked prior to invoking methods implemented by plugins. If this method returns a non-empty dictionary, that structure will be passed to the reply. The default is an empty implementation. [call method [cmd "Headers_Local"] [arg varname]] Introspect and possibly modify a data structure destined for a reply. This method is invoked before invoking Header methods implemented by plugins. The default implementation is empty. [call method [cmd "Headers_Process"] [arg varname]] Introspect and possibly modify a data structure destined for a reply. This method is built dynamically by the [cmd plugin] method. [call method [cmd "HostName"] [arg ipaddr]] Convert an ip address to a host name. If the server/ reverse_dns flag is false, this method simply returns the IP address back. Internally, this method uses the [emph dns] module from tcllib. [call method [cmd "log"] [opt "[arg args]"]] Log an event. The input for args is free form. This method is intended to be replaced by the user, and is a noop for a stock http::server object. [call method [cmd "plugin"] [arg slot] [opt "[arg class] [const ""]"]] Incorporate behaviors from a plugin. This method dynamically rebuilds the [cmd Dispatch] and [cmd Headers] method. For every plugin, the server looks for the following entries in [emph "clay plugin/"]: [para] [emph load] - A script to invoke in the server's namespace during the [cmd plugin] method invokation. [para] [emph dispatch] - A script to stitch into the server's [cmd Dispatch] method. [para] [emph headers] - A script to stitch into the server's [cmd Headers] method. [para] [emph thread] - A script to stitch into the server's [cmd Thread_start] method. [call method [cmd "port_listening"]] Return the actual port that httpd is listening on. [call method [cmd "PrefixNormalize"] [arg prefix]] For the stock version, trim trailing /'s and *'s from a prefix. This method can be replaced by the end user to perform any other transformations needed for the application. [call method [cmd "source"] [arg filename]] [call method [cmd "start"]] Open the socket listener. [call method [cmd "stop"]] Shut off the socket listener, and destroy any pending replies. [call method [cmd "SubObject {} db"]] [call method [cmd "SubObject {} default"]] [call method [cmd "template"] [arg page]] Return a template for the string [arg page] [call method [cmd "TemplateSearch"] [arg page]] Perform a search for the template that best matches [arg page]. This can include local file searches, in-memory structures, or even database lookups. The stock implementation simply looks for files with a .tml or .html extension in the [opt doc_root] directory. [call method [cmd "Thread_start"]] Built by the [cmd plugin] method. Called by the [cmd start] method. Intended to allow plugins to spawn worker threads. [call method [cmd "Uuid_Generate"]] Generate a GUUID. Used to ensure every request has a unique ID. The default implementation is: [example { return [::clay::uuid generate] }] [call method [cmd "Validate_Connection"] [arg sock] [arg ip]] Given a socket and an ip address, return true if this connection should be terminated, or false if it should be allowed to continue. The stock implementation always returns 0. This is intended for applications to be able to implement black lists and/or provide security based on IP address. [list_end] [para] [subsection {Class httpd::server::dispatch}] [emph "ancestors"]: [class httpd::server] [para] Provide a backward compadible alias [para] [subsection {Class httpd::content.redirect}] [para] [class {Methods}] [list_begin definitions] [call method [cmd "reset"]] [call method [cmd "content"]] [list_end] [para] [subsection {Class httpd::content.cache}] [para] [class {Methods}] [list_begin definitions] [call method [cmd "Dispatch"]] [list_end] [para] [subsection {Class httpd::content.template}] [para] [class {Methods}] [list_begin definitions] [call method [cmd "content"]] [list_end] [para] [subsection {Class httpd::content.file}] Class to deliver Static content When utilized, this class is fed a local filename by the dispatcher [para] [class {Methods}] [list_begin definitions] [call method [cmd "FileName"]] [call method [cmd "DirectoryListing"] [arg local_file]] [call method [cmd "content"]] [call method [cmd "Dispatch"]] [list_end] [para] [subsection {Class httpd::content.exec}] [para] [class {Variable}] [list_begin definitions] [call variable [cmd exename]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "CgiExec"] [arg execname] [arg script] [arg arglist]] [call method [cmd "Cgi_Executable"] [arg script]] [list_end] [para] [subsection {Class httpd::content.proxy}] [emph "ancestors"]: [class httpd::content.exec] [para] Return data from an proxy process [para] [class {Methods}] [list_begin definitions] [call method [cmd "proxy_channel"]] [call method [cmd "proxy_path"]] [call method [cmd "ProxyRequest"] [arg chana] [arg chanb]] [call method [cmd "ProxyReply"] [arg chana] [arg chanb] [opt "[arg args]"]] [call method [cmd "Dispatch"]] [list_end] [para] [subsection {Class httpd::content.cgi}] [emph "ancestors"]: [class httpd::content.proxy] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "FileName"]] [call method [cmd "proxy_channel"]] [call method [cmd "ProxyRequest"] [arg chana] [arg chanb]] [call method [cmd "ProxyReply"] [arg chana] [arg chanb] [opt "[arg args]"]] [call method [cmd "DirectoryListing"] [arg local_file]] For most CGI applications a directory list is vorboten [list_end] [para] [subsection {Class httpd::protocol.scgi}] Return data from an SCGI process [para] [class {Methods}] [list_begin definitions] [call method [cmd "EncodeStatus"] [arg status]] [list_end] [para] [subsection {Class httpd::content.scgi}] [emph "ancestors"]: [class httpd::content.proxy] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "scgi_info"]] [call method [cmd "proxy_channel"]] [call method [cmd "ProxyRequest"] [arg chana] [arg chanb]] [call method [cmd "ProxyReply"] [arg chana] [arg chanb] [opt "[arg args]"]] [list_end] [para] [subsection {Class httpd::server.scgi}] [emph "ancestors"]: [class httpd::server] [para] Act as an SCGI Server [para] [class {Methods}] [list_begin definitions] [call method [cmd "debug"] [opt "[arg args]"]] [call method [cmd "Connect"] [arg uuid] [arg sock] [arg ip]] [list_end] [para] [subsection {Class httpd::content.websocket}] Upgrade a connection to a websocket [para] [subsection {Class httpd::plugin}] httpd plugin template [para] [subsection {Class httpd::plugin.dict_dispatch}] A rudimentary plugin that dispatches URLs from a dict data structure [para] [class {Methods}] [list_begin definitions] [call method [cmd "Dispatch_Dict"] [arg data]] Implementation of the dispatcher [call method [cmd "uri {} add"] [arg vhosts] [arg patterns] [arg info]] [call method [cmd "uri {} direct"] [arg vhosts] [arg patterns] [arg info] [arg body]] [list_end] [para] [subsection {Class httpd::reply.memchan}] [emph "ancestors"]: [class httpd::reply] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "output"]] [call method [cmd "DoOutput"]] [call method [cmd "close"]] [list_end] [para] [subsection {Class httpd::plugin.local_memchan}] [para] [class {Methods}] [list_begin definitions] [call method [cmd "local_memchan"] [arg command] [opt "[arg args]"]] [call method [cmd "Connect_Local"] [arg uuid] [arg sock] [opt "[arg args]"]] A modified connection method that passes simple GET request to an object and pulls data directly from the reply_body data variable in the object Needed because memchan is bidirectional, and we can't seem to communicate that the server is one side of the link and the reply is another [list_end] [para] [section AUTHORS] Sean Woods [vset CATEGORY network] [include ../doctools2base/include/feedback.inc] [manpage_end] |
Changes to modules/httpd/httpd.tcl.
1 2 3 4 5 6 | ### # Amalgamated package for httpd # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl 8.6 | | | < < < < < < < < < < < < < < | | < | | | > | > | | | > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > < | 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 | ### # Amalgamated package for httpd # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl 8.6 package provide httpd 4.3.3 namespace eval ::httpd {} set ::httpd::version 4.3.3 ### # START: core.tcl ### package require uri package require dns package require cron package require coroutine package require mime package require fileutil package require websocket package require Markdown package require fileutil::magic::filetype package require clay 0.7 namespace eval httpd::content { } namespace eval ::url { } namespace eval ::httpd { } namespace eval ::scgi { } clay::define ::httpd::mime { method ChannelCopy {in out args} { set chunk 4096 set size -1 foreach {f v} $args { set [string trim $f -] $v } dict set info coroutine [info coroutine] if {$size>0 && $chunk>$size} { set chunk $size } set bytes 0 set sofar 0 set method [self method] while 1 { set command {} set error {} if {$size>=0} { incr sofar $bytes set remaining [expr {$size-$sofar}] if {$remaining <= 0} { break } elseif {$chunk > $remaining} { set chunk $remaining } } lassign [yieldto chan copy $in $out -size $chunk \ -command [list [info coroutine] $method]] \ command bytes error if {$command ne $method} { error "Subroutine $method interrupted" } if {[string length $error]} { error $error } if {[chan eof $in]} { break } } } method html_header {{title {}} args} { set result {} append result "<!DOCTYPE html>\n<HTML><HEAD>" if {$title ne {}} { append result "<TITLE>$title</TITLE>" } if {[dict exists $args stylesheet]} { append result "<link rel=\"stylesheet\" href=\"[dict get $args stylesheet]\">" } else { append result "<link rel=\"stylesheet\" href=\"/style.css\">" } append result "</HEAD><BODY>" return $result } method html_footer {args} { return "</BODY></HTML>" } method http_code_string code { set codes { 200 {Data follows} 204 {No Content} 301 {Moved Permanently} 302 {Found} 303 {Moved Temporarily} |
︙ | ︙ | |||
82 83 84 85 86 87 88 | 505 {HTTP Version Not Supported} } if {[dict exists $codes $code]} { return [dict get $codes $code] } return {Unknown Http Code} } | < | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | 505 {HTTP Version Not Supported} } if {[dict exists $codes $code]} { return [dict get $codes $code] } return {Unknown Http Code} } method HttpHeaders {sock {debug {}}} { set result {} set LIMIT 8192 ### # Set up a channel event to stream the data from the socket line by # line. When a blank line is read, the HttpHeaderLine method will send # a flag which will terminate the vwait. |
︙ | ︙ | |||
110 111 112 113 114 115 116 | } } ### # Return our buffer ### return $result } | < > > > > > > > | < < < > | 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 | } } ### # Return our buffer ### return $result } method HttpHeaders_Default {} { return {Status {200 OK} Content-Size 0 Content-Type {text/html; charset=UTF-8} Cache-Control {no-cache} Connection close} } method HttpServerHeaders {} { return { CONTENT_LENGTH CONTENT_TYPE QUERY_STRING REMOTE_USER AUTH_TYPE REQUEST_METHOD REMOTE_ADDR REMOTE_HOST REQUEST_URI REQUEST_PATH REQUEST_VERSION DOCUMENT_ROOT QUERY_STRING REQUEST_RAW GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT SERVER_NAME SERVER_SOFTWARE SERVER_PROTOCOL } } method MimeParse mimetext { set data(mimeorder) {} foreach line [split $mimetext \n] { # This regexp picks up # key: value # MIME headers. MIME headers may be continue with a line # that starts with spaces or a tab |
︙ | ︙ | |||
205 206 207 208 209 210 211 | set ckey Referer } } dict set result $ckey $data(mime,$key) } return $result } | < < | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | set ckey Referer } } dict set result $ckey $data(mime,$key) } return $result } method Url_Decode data { regsub -all {\+} $data " " data regsub -all {([][$\\])} $data {\\\1} data regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data return [subst $data] } method Url_PathCheck {urlsuffix} { set pathlist "" foreach part [split $urlsuffix /] { if {[string length $part] == 0} { # It is important *not* to "continue" here and skip # an empty component because it could be the last thing, # /a/b/c/ |
︙ | ︙ | |||
245 246 247 248 249 250 251 | default { lappend pathlist $part } } } return $pathlist } | < < < < < < | > > | | > > > > > > > > > > | | | | < < < < < < | | | | | | | | > > > > > > > > > > > > > > | > | | > > > | > | | | > | | < | > > > | > | < | | < < | < < < < < | < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < | < < < < < | 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 | default { lappend pathlist $part } } } return $pathlist } method wait {mode sock} { if {[info coroutine] eq {}} { chan event $sock $mode [list set ::httpd::lock_$sock $mode] vwait ::httpd::lock_$sock } else { chan event $sock $mode [info coroutine] yield } chan event $sock $mode {} } } ### # END: core.tcl ### ### # START: reply.tcl ### ::clay::define ::httpd::reply { superclass ::httpd::mime Delegate <server> { description {The server object which spawned this reply} } Dict reply {} Dict request { CONTENT_LENGTH 0 COOKIE {} HTTP_HOST {} REFERER {} REQUEST_URI {} REMOTE_ADDR {} REMOTE_HOST {} USER_AGENT {} SESSION {} } constructor {ServerObj args} { my variable chan dispatched_time uuid set uuid [namespace tail [self]] set dispatched_time [clock milliseconds] my clay delegate <server> $ServerObj foreach {field value} [::clay::args_to_options {*}$args] { my clay set config $field: $value } } destructor { my close } method close {} { my variable chan if {[info exists chan] && $chan ne {}} { catch {chan event $chan readable {}} catch {chan event $chan writable {}} catch {chan flush $chan} catch {chan close $chan} set chan {} } } method Log_Dispatched {} { my log Dispatched [dict create \ REMOTE_ADDR [my request get REMOTE_ADDR] \ REMOTE_HOST [my request get REMOTE_HOST] \ COOKIE [my request get HTTP_COOKIE] \ REFERER [my request get HTTP_REFERER] \ USER_AGENT [my request get HTTP_USER_AGENT] \ REQUEST_URI [my request get REQUEST_URI] \ HTTP_HOST [my request get HTTP_HOST] \ SESSION [my request get SESSION] \ ] } method dispatch {newsock datastate} { my variable chan request try { set chan $newsock chan event $chan readable {} chan configure $chan -translation {auto crlf} -buffering line if {[dict exists $datastate mixin]} { set mixinmap [dict get $datastate mixin] } else { set mixinmap {} } foreach item [dict keys $datastate MIXIN_*] { set slot [string range $item 6 end] dict set mixinmap [string tolower $slot] [dict get $datastate $item] } my clay mixinmap {*}$mixinmap if {[dict exists $datastate delegate]} { my clay delegate {*}[dict get $datastate delegate] } my reset set request [my clay get dict/ request] foreach {f v} $datastate { if {[string index $f end] eq "/"} { my clay merge $f $v } else { my clay set $f $v } if {$f eq "http"} { foreach {ff vf} $v { dict set request $ff $vf } } } my Session_Load my Log_Dispatched my Dispatch } on error {err errdat} { my error 500 $err [dict get $errdat -errorinfo] my DoOutput } } method Dispatch {} { # Invoke the URL implementation. my content my DoOutput } method html_header {title args} { set result {} append result "<HTML><HEAD>" if {$title ne {}} { append result "<TITLE>$title</TITLE>" } append result "</HEAD><BODY>" append result \n {<div id="top-menu">} if {[dict exists $args banner]} { append result "<img src=\"[dict get $args banner]\">" } else { append result {<img src="/images/etoyoc-banner.jpg">} } append result {</div>} if {[dict exists $args sideimg]} { append result "\n<div name=\"sideimg\"><img align=right src=\"[dict get $args sideimg]\"></div>" } append result {<div id="content">} return $result } method html_footer {args} { set result {</div><div id="footer">} append result {</div></BODY></HTML>} } method error {code {msg {}} {errorInfo {}}} { my clay set HTTP_ERROR $code my reset set qheaders [my clay dump] set HTTP_STATUS "$code [my http_code_string $code]" dict with qheaders {} my reply replace {} my reply set Status $HTTP_STATUS my reply set Content-Type {text/html; charset=UTF-8} switch $code { 301 - 302 - 303 - 307 - 308 { my reply set Location $msg set template [my <server> template redirect] } 404 { set template [my <server> template notfound] } default { set template [my <server> template internal_error] } } my puts [subst $template] } method content {} { my puts [my html_header {Hello World!}] my puts "<H1>HELLO WORLD!</H1>" my puts [my html_footer] } method EncodeStatus {status} { return "HTTP/1.0 $status" } method log {type {info {}}} { my variable dispatched_time uuid my <server> log $type $uuid $info } method CoroName {} { if {[info coroutine] eq {}} { return ::httpd::object::[my clay get UUID] } } method DoOutput {} { my variable reply_body chan if {$chan eq {}} return catch { my wait writable $chan chan configure $chan -translation {binary binary} ### |
︙ | ︙ | |||
466 467 468 469 470 471 472 | append result [my reply output] } chan puts -nonewline $chan $result my log HttpAccess {} } my destroy } | < < < < | < | | | 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 | append result [my reply output] } chan puts -nonewline $chan $result my log HttpAccess {} } my destroy } method FormData {} { my variable chan formdata # Run this only once if {[info exists formdata]} { return $formdata } set length [my request get CONTENT_LENGTH] set formdata {} if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} { set rawtype [my request get CONTENT_TYPE] if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} { set type $rawtype } else { set type multipart } switch $type { multipart { ### # Ok, Multipart MIME is troublesome, farm out the parsing to a dedicated tool ### set body [my clay get mimetxt] append body \n [my PostData $length] set token [::mime::initialize -string $body] foreach item [::mime::getheader $token -names] { dict set formdata $item [::mime::getheader $token $item] } foreach item {content encoding params parts size} { dict set formdata MIME_[string toupper $item] [::mime::getproperty $token $item] |
︙ | ︙ | |||
515 516 517 518 519 520 521 | foreach {name value} [split $pair "="] { lappend formdata [my Url_Decode $name] [my Url_Decode $value] } } } } } else { | | < | | < < < < < < < > > > > > | < | | | | | | | | | | | | | | | | | < | | | | | | | | | | | > > | > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | > > | > > | | < < < > | < < < < < < < < < < < < | > | | | | < | | | | | | | | | | < | | > > > > > > > > > > > > > > > | < | | | > | < | | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > < < < | < < < < < < < < < < < < | < < < < < < < | | < < | < | | | | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < > > | | > | | | | > < | < < | | | > > > > > > | > | > | | < < < < < | | | | < > > | > > | < | | | | | | | | | | < < | < < < < < < < < < < | | < | | | | < | < | | < < < < < < | < | < | | | < < < < < | < > > > > | | | | < | | | < | | 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 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 | foreach {name value} [split $pair "="] { lappend formdata [my Url_Decode $name] [my Url_Decode $value] } } } } } else { foreach pair [split [my clay get QUERY_STRING] "&"] { foreach {name value} [split $pair "="] { lappend formdata [my Url_Decode $name] [my Url_Decode $value] } } } return $formdata } method PostData {length} { my variable postdata # Run this only once if {[info exists postdata]} { return $postdata } set postdata {} if {[my request get REQUEST_METHOD] in {"POST" "PUSH"}} { my variable chan chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096 set postdata [::coroutine::util::read $chan $length] } return $postdata } method Session_Load {} {} method TransferComplete args { my log TransferComplete set chan {} foreach c $args { catch {chan event $c readable {}} catch {chan event $c writable {}} catch {chan flush $c} catch {chan close $c} } my destroy } method puts line { my variable reply_body append reply_body $line \n } method RequestFind {field} { my variable request if {[dict exists $request $field]} { return $field } foreach item [dict keys $request] { if {[string tolower $item] eq [string tolower $field]} { return $item } } return $field } method request {subcommand args} { my variable request switch $subcommand { dump { return $request } field { tailcall my RequestFind [lindex $args 0] } get { set field [my RequestFind [lindex $args 0]] if {![dict exists $request $field]} { return {} } tailcall dict get $request $field } getnull { set field [my RequestFind [lindex $args 0]] if {![dict exists $request $field]} { return {} } tailcall dict get $request $field } exists { set field [my RequestFind [lindex $args 0]] tailcall dict exists $request $field } parse { if {[catch {my MimeParse [lindex $args 0]} result]} { my error 400 $result tailcall my DoOutput } set request $result } replace { set request [lindex $args 0] } set { dict set request {*}$args } default { error "Unknown command $subcommand. Valid: field, get, getnull, exists, parse, replace, set" } } } method reply {subcommand args} { my variable reply switch $subcommand { dump { return $reply } exists { return [dict exists $reply {*}$args] } get - getnull { return [dict getnull $reply {*}$args] } replace { set reply [my HttpHeaders_Default] if {[llength $args]==1} { foreach {f v} [lindex $args 0] { dict set reply $f $v } } else { foreach {f v} $args { dict set reply $f $v } } } output { set result {} if {![dict exists $reply Status]} { set status {200 OK} } else { set status [dict get $reply Status] } set result "[my EncodeStatus $status]\n" foreach {f v} $reply { if {$f in {Status}} continue append result "[string trimright $f :]: $v\n" } #append result \n return $result } set { dict set reply {*}$args } default { error "Unknown command $subcommand. Valid: exists, get, getnull, output, replace, set" } } } method reset {} { my variable reply_body my reply replace [my HttpHeaders_Default] my reply set Server [my <server> clay get server/ string] my reply set Date [my timestamp] set reply_body {} } method timeOutCheck {} { my variable dispatched_time if {([clock seconds]-$dispatched_time)>120} { ### # Something has lasted over 2 minutes. Kill this ### catch { my error 408 {Request Timed out} my DoOutput } } } method timestamp {} { return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}] } } ### # END: reply.tcl ### ### # START: server.tcl ### namespace eval ::httpd::object { } namespace eval ::httpd::coro { } ::clay::define ::httpd::server { superclass ::httpd::mime clay set server/ port auto clay set server/ myaddr 127.0.0.1 clay set server/ string [list TclHttpd $::httpd::version] clay set server/ name [info hostname] clay set server/ doc_root {} clay set server/ reverse_dns 0 clay set server/ configuration_file {} clay set server/ protocol {HTTP/1.1} clay set socket/ buffersize 32768 clay set socket/ translation {auto crlf} clay set reply_class ::httpd::reply Array template Dict url_patterns {} constructor { {args { port {default auto comment {Port to listen on}} myaddr {default 127.0.0.1 comment {IP address to listen on. "all" means all}} string {default auto comment {Value for SERVER_SOFTWARE in HTTP headers}} name {default auto comment {Value for SERVER_NAME in HTTP headers. Defaults to [info hostname]}} doc_root {default {} comment {File path to serve.}} reverse_dns {default 0 comment {Perform reverse DNS to convert IPs into hostnames}} configuration_file {default {} comment {Configuration file to load into server namespace}} protocol {default {HTTP/1.1} comment {Value for SERVER_PROTOCOL in HTTP headers}} }}} { if {[llength $args]==1} { set arglist [lindex $args 0] } else { set arglist $args } foreach {var val} $arglist { my clay set server/ $var $val } my start } destructor { my stop } method connect {sock ip port} { ### # If an IP address is blocked drop the # connection ### if {[my Validate_Connection $sock $ip]} { catch {close $sock} return } set uuid [my Uuid_Generate] set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]] chan event $sock readable $coro } method ServerHeaders {ip http_request mimetxt} { set result {} dict set result HTTP_HOST {} dict set result CONTENT_LENGTH 0 foreach {f v} [my MimeParse $mimetxt] { set fld [string toupper [string map {- _} $f]] if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} { set qfld $fld } else { set qfld HTTP_$fld } dict set result $qfld $v } dict set result REMOTE_ADDR $ip dict set result REMOTE_HOST [my HostName $ip] dict set result REQUEST_METHOD [lindex $http_request 0] set uriinfo [::uri::split [lindex $http_request 1]] dict set result uriinfo $uriinfo dict set result REQUEST_URI [lindex $http_request 1] dict set result REQUEST_PATH [dict get $uriinfo path] dict set result REQUEST_VERSION [lindex [split [lindex $http_request end] /] end] dict set result DOCUMENT_ROOT [my clay get server/ doc_root] dict set result QUERY_STRING [dict get $uriinfo query] dict set result REQUEST_RAW $http_request dict set result SERVER_PORT [my port_listening] dict set result SERVER_NAME [my clay get server/ name] dict set result SERVER_PROTOCOL [my clay get server/ protocol] dict set result SERVER_SOFTWARE [my clay get server/ string] if {[string match 127.* $ip]} { dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}] } return $result } method Connect {uuid sock ip} { yield [info coroutine] chan event $sock readable {} chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ -buffering line my counter url_hit try { set readCount [::coroutine::util::gets_safety $sock 4096 http_request] set mimetxt [my HttpHeaders $sock] dict set query UUID $uuid dict set query mimetxt $mimetxt dict set query mixin style [my clay get server/ style] dict set query http [my ServerHeaders $ip $http_request $mimetxt] my Headers_Process query set reply [my dispatch $query] } on error {err errdat} { my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"} catch {chan close $sock} return } if {[dict size $reply]==0} { set reply $query my log BadLocation $uuid $query dict set reply http HTTP_STATUS {404 Not Found} dict set reply template notfound dict set reply mixin reply ::httpd::content.template } set pageobj [::httpd::reply create ::httpd::object::$uuid [self]] tailcall $pageobj dispatch $sock $reply } method counter which { my variable counters incr counters($which) } method CheckTimeout {} { foreach obj [info commands ::httpd::object::*] { try { $obj timeOutCheck } on error {} { catch {$obj destroy} } } } method debug args {} method dispatch {data} { set reply [my Dispatch_Local $data] if {[dict size $reply]} { return $reply } return [my Dispatch_Default $data] } method Dispatch_Default {reply} { ### # Fallback to docroot handling ### set doc_root [dict getnull $reply http DOCUMENT_ROOT] if {$doc_root ne {}} { ### # Fall back to doc_root handling ### dict set reply prefix {} dict set reply path $doc_root dict set reply mixin reply httpd::content.file return $reply } return {} } method Dispatch_Local data {} method Headers_Local {varname} {} method Headers_Process varname {} method HostName ipaddr { if {![my clay get server/ reverse_dns]} { return $ipaddr } set t [::dns::resolve $ipaddr] set result [::dns::name $t] ::dns::cleanup $t return $result } method log args { # Do nothing for now } method plugin {slot {class {}}} { if {$class eq {}} { set class ::httpd::plugin.$slot } if {[info command $class] eq {}} { error "Class $class for plugin $slot does not exist" } my clay mixinmap $slot $class set mixinmap [my clay mixinmap] ### # Perform action on load ### set script [$class clay search plugin/ load] eval $script ### # rebuild the dispatch method ### set body "\n try \{" append body \n { set reply [my Dispatch_Local $data] if {[dict size $reply]} {return $reply} } foreach {slot class} $mixinmap { set script [$class clay search plugin/ dispatch] if {[string length $script]} { append body \n "# SLOT $slot" append body \n $script } } append body \n { return [my Dispatch_Default $data]} append body \n "\} on error \{err errdat\} \{" append body \n { puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}} append body \n "\}" oo::objdefine [self] method dispatch data $body ### # rebuild the Headers_Process method ### set body "\n try \{" append body \n " upvar 1 \$varname query" append body \n { my Headers_Local query} foreach {slot class} $mixinmap { set script [$class clay search plugin/ headers] if {[string length $script]} { append body \n "# SLOT $slot" append body \n $script } } append body \n "\} on error \{err errdat\} \{" append body \n { puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}} append body \n "\}" oo::objdefine [self] method Headers_Process varname $body ### # rebuild the Threads_Start method ### set body "\n try \{" foreach {slot class} $mixinmap { set script [$class clay search plugin/ thread] if {[string length $script]} { append body \n "# SLOT $slot" append body \n $script } } append body \n "\} on error \{err errdat\} \{" append body \n { puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}} append body \n "\}" oo::objdefine [self] method Thread_start {} $body } method port_listening {} { my variable port_listening return $port_listening } method PrefixNormalize prefix { set prefix [string trimright $prefix /] set prefix [string trimright $prefix *] set prefix [string trimright $prefix /] return $prefix } method source {filename} { source $filename } method start {} { # Build a namespace to contain replies namespace eval [namespace current]::reply {} my variable socklist port_listening if {[my clay get server/ configuration_file] ne {}} { source [my clay get server/ configuration_file] } set port [my clay get server/ port] if { $port in {auto {}} } { package require nettool set port [::nettool::allocate_port 8015] } set port_listening $port set myaddr [my clay get server/ myaddr] my debug [list [self] listening on $port $myaddr] if {$myaddr ni {all any * {}}} { foreach ip $myaddr { lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port] } } else { lappend socklist [socket -server [namespace code [list my connect]] $port] } ::cron::every [self] 120 [namespace code {my CheckTimeout}] my Thread_start } method stop {} { my variable socklist if {[info exists socklist]} { foreach sock $socklist { catch {close $sock} } } set socklist {} ::cron::cancel [self] } Ensemble SubObject::db {} { return [namespace current]::Sqlite_db } Ensemble SubObject::default {} { return [namespace current]::$method } method template page { my variable template if {[info exists template($page)]} { return $template($page) } set template($page) [my TemplateSearch $page] return $template($page) } method TemplateSearch page { set doc_root [my clay get server/ doc_root] if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} { return [::fileutil::cat [file join $doc_root $page.tml]] } if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} { return [::fileutil::cat [file join $doc_root $page.html]] } switch $page { redirect { return { [my html_header "$HTTP_STATUS"] The page you are looking for: <b>[my request get REQUEST_URI]</b> has moved. <p> If your browser does not automatically load the new location, it is <a href=\"$msg\">$msg</a> [my html_footer] } } internal_error { return { [my html_header "$HTTP_STATUS"] Error serving <b>[my request get REQUEST_URI]</b>: <p> The server encountered an internal server error: <pre>$msg</pre> <pre><code> $errorInfo </code></pre> [my html_footer] } } notfound { return { [my html_header "$HTTP_STATUS"] The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist. [my html_footer] } } } } method Thread_start {} {} method Uuid_Generate {} { return [::clay::uuid::short] } method Validate_Connection {sock ip} { return 0 } } ::clay::define ::httpd::server::dispatch { superclass ::httpd::server } ### # END: server.tcl ### ### # START: dispatch.tcl ### ::clay::define ::httpd::content.redirect { method reset {} { ### # Inject the location into the HTTP headers ### my variable reply_body set reply_body {} my reply replace [my HttpHeaders_Default] my reply set Server [my <server> clay get server/ string] set msg [my clay get LOCATION] my reply set Location [my clay get LOCATION] set code [my clay get REDIRECT_CODE] if {$code eq {}} { set code 301 } my reply set Status [list $code [my http_code_string $code]] } method content {} { set template [my <server> template redirect] set msg [my clay get LOCATION] set HTTP_STATUS [my reply get Status] my puts [subst $msg] } } ::clay::define ::httpd::content.cache { method Dispatch {} { my variable chan try { my wait writable $chan chan configure $chan -translation {binary binary} chan puts -nonewline $chan [my clay get cache/ data] } on error {err info} { my <server> debug [dict get $info -errorinfo] } finally { my TransferComplete $chan } } } ::clay::define ::httpd::content.template { method content {} { if {[my request get HTTP_STATUS] ne {}} { my reply set Status [my request get HTTP_STATUS] } my puts [subst [my <server> template [my clay get template]]] } } ### # END: dispatch.tcl ### ### # START: file.tcl ### ::clay::define ::httpd::content.file { method FileName {} { # Some dispatchers will inject a fully qualified name during discovery if {[my clay exists FILENAME] && [file exists [my clay get FILENAME]]} { return [my clay get FILENAME] } set uri [string trimleft [my request get REQUEST_URI] /] set path [my clay get path] set prefix [my clay get prefix] set fname [string range $uri [string length $prefix] end] if {$fname in "{} index.html index.md index index.tml"} { return $path } if {[file exists [file join $path $fname]]} { return [file join $path $fname] } if {[file exists [file join $path $fname.md]]} { return [file join $path $fname.md] } if {[file exists [file join $path $fname.html]]} { return [file join $path $fname.html] } if {[file exists [file join $path $fname.tml]]} { return [file join $path $fname.tml] } return {} } method DirectoryListing {local_file} { set uri [string trimleft [my request get REQUEST_URI] /] set path [my clay get path] set prefix [my clay get prefix] set fname [string range $uri [string length $prefix] end] my puts [my html_header "Listing of /$fname/"] my puts "Listing contents of /$fname/" my puts "<TABLE>" if {$prefix ni {/ {}}} { set updir [file dirname $prefix] if {$updir ne {}} { my puts "<TR><TD><a href=\"/$updir\">..</a></TD><TD></TD></TR>" } } foreach file [glob -nocomplain [file join $local_file *]] { if {[file isdirectory $file]} { my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]/</a></TD><TD></TD></TR>" } else { my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]</a></TD><TD>[file size $file]</TD></TR>" } } my puts "</TABLE>" my puts [my html_footer] } method content {} { my variable reply_file set local_file [my FileName] if {$local_file eq {} || ![file exist $local_file]} { my log httpNotFound [my request get REQUEST_URI] my error 404 {File Not Found} tailcall my DoOutput } if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} { ### # Produce an index page ### |
︙ | ︙ | |||
1228 1229 1230 1231 1232 1233 1234 | my reply set Content-Type {text/html; charset=UTF-8} set mdtxt [::fileutil::cat $local_file] my puts [::Markdown::convert $mdtxt] } .tml { my reply set Content-Type {text/html; charset=UTF-8} set tmltxt [::fileutil::cat $local_file] | | > > > > > > | < < < < < < < < | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 | my reply set Content-Type {text/html; charset=UTF-8} set mdtxt [::fileutil::cat $local_file] my puts [::Markdown::convert $mdtxt] } .tml { my reply set Content-Type {text/html; charset=UTF-8} set tmltxt [::fileutil::cat $local_file] set headers [my request dump] dict with headers {} my puts [subst $tmltxt] } .svgz - .svg { # FU magic screws it up my reply set Content-Type {image/svg+xml} set reply_file $local_file } default { ### # Assume we are returning a binary file ### my reply set Content-Type [::fileutil::magic::filetype $local_file] set reply_file $local_file } } } method Dispatch {} { my variable reply_body reply_file reply_chan chan try { my reset # Invoke the URL implementation. my content } on error {err errdat} { my error 500 $err [dict get $errdat -errorinfo] tailcall my DoOutput } |
︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 | ### set size [file size $reply_file] my reply set Content-Length $size append result [my reply output] \n chan puts -nonewline $chan $result set reply_chan [open $reply_file r] my log SendReply [list length $size] | < | < < < < < < < < < > | | | < < | 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 | ### set size [file size $reply_file] my reply set Content-Length $size append result [my reply output] \n chan puts -nonewline $chan $result set reply_chan [open $reply_file r] my log SendReply [list length $size] ### # Output the file contents. With no -size flag, channel will copy until EOF ### chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0 my ChannelCopy $reply_chan $chan -chunk 4096 } finally { my TransferComplete $reply_chan $chan } } } ### # END: file.tcl ### ### # START: proxy.tcl ### ::clay::define ::httpd::content.exec { variable exename [list tcl [info nameofexecutable] .tcl [info nameofexecutable]] method CgiExec {execname script arglist} { if { $::tcl_platform(platform) eq "windows"} { if {[file extension $script] eq ".exe"} { return [open "|[list $script] $arglist" r+] } else { if {$execname eq {}} { set execname [my Cgi_Executable $script] } return [open "|[list $execname $script] $arglist" r+] } } else { if {$execname eq {}} { return [open "|[list $script] $arglist 2>@1" r+] } else { return [open "|[list $execname $script] $arglist 2>@1" r+] } } error "CGI Not supported" } method Cgi_Executable {script} { if {[string tolower [file extension $script]] eq ".exe"} { return $script } my variable exename set ext [file extension $script] if {$ext eq {}} { |
︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 | return $result } } if {[dict exists exename $which]} { return [dict get $exename $which] } if {$which eq "tcl"} { | | | | | < < < < | < < | | < | > | | | < > < < < < < | < < | | | | | < < | | < < < < < < | | < < < < < < < < < > | | > > > | < | | | < | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 | return $result } } if {[dict exists exename $which]} { return [dict get $exename $which] } if {$which eq "tcl"} { if {[my clay get tcl_exe] ne {}} { dict set exename $which [my clay get tcl_exe] } else { dict set exename $which [info nameofexecutable] } } else { if {[my clay get ${which}_exe] ne {}} { dict set exename $which [my clay get ${which}_exe] } elseif {"$::tcl_platform(platform)" == "windows"} { dict set exename $which $which.exe } else { dict set exename $which $which } } set result [dict get $exename $which] if {$ext ne {}} { dict set exename $ext $result } return $result } } ::clay::define ::httpd::content.proxy { superclass ::httpd::content.exec method proxy_channel {} { ### # This method returns a channel to the # proxied socket/stdout/etc ### error unimplemented } method proxy_path {} { set uri [string trimleft [my request get REQUEST_URI] /] set prefix [my clay get prefix] return /[string range $uri [string length $prefix] end] } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} chan puts $chanb "[my request get REQUEST_METHOD] [my proxy_path]" set mimetxt [my clay get mimetxt] chan puts $chanb [my clay get mimetxt] set length [my request get CONTENT_LENGTH] if {$length} { chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 ### # Send any POST/PUT/etc content ### my ChannelCopy $chana $chanb -size $length } else { chan flush $chanb } chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] chan event $chana readable {} set readCount [::coroutine::util::gets_safety $chana 4096 reply_status] set replyhead [my HttpHeaders $chana] set replydat [my MimeParse $replyhead] ### # Read the first incoming line as the HTTP reply status # Return the rest of the headers verbatim ### set replybuffer "$reply_status\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer ### # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 } method Dispatch {} { my variable sock chan if {[catch {my proxy_channel} sock errdat]} { my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo] tailcall my DoOutput } if {$sock eq {}} { my error 404 {Not Found} tailcall my DoOutput } my log HttpAccess {} chan event $sock writable [info coroutine] yield try { my ProxyRequest $chan $sock my ProxyReply $sock $chan } finally { my TransferComplete $chan $sock } } } ### # END: proxy.tcl ### ### # START: cgi.tcl ### ::clay::define ::httpd::content.cgi { superclass ::httpd::content.proxy method FileName {} { set uri [string trimleft [my request get REQUEST_URI] /] set path [my clay get path] set prefix [my clay get prefix] set fname [string range $uri [string length $prefix] end] if {[file exists [file join $path $fname]]} { return [file join $path $fname] } if {[file exists [file join $path $fname.fossil]]} { return [file join $path $fname.fossil] } if {[file exists [file join $path $fname.fos]]} { return [file join $path $fname.fos] } if {[file extension $fname] in {.exe .cgi .tcl .pl .py .php}} { return $fname } return {} } method proxy_channel {} { ### # When delivering static content, allow web caches to save ### set local_file [my FileName] if {$local_file eq {} || ![file exist $local_file]} { my log httpNotFound [my request get REQUEST_URI] my error 404 {Not Found} tailcall my DoOutput } if {[file isdirectory $local_file]} { ### # Produce an index page... or error ### |
︙ | ︙ | |||
1549 1550 1551 1552 1553 1554 1555 | } foreach item $verbatim { set ::env($item) {} } foreach item [array names ::env HTTP_*] { set ::env($item) {} } | | | < | < < < < < < < < < | | < > | < < < < < | | | | | < < | | < < < < < < > > | < > > | < < | < | | > | < > < < < < < < < < | | | | | < < < < < < | < < | < < | < < < < < | < | | | | < > | | > | > < < | < < | < | | | | | | | > > | | | < | > > > | | < < < < < < < < < < < < < < < < < < < < | < < > | < < < | < | | | | | | | < > < < < | < < < < | < < < < < < < < | < < < < | < < < < | < < < < | < < < < < | | < < < < < < | | < > | | | > | | | | | | | < | < < < < < < < < < < < | | < | < < < < < < < < < < < < < > > > > > > | > > > > > > > > | < < < < < | < | < < < < < < < < < > | | | | | | | | | | | | | | | | < < < | | | < | | | | 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 | } foreach item $verbatim { set ::env($item) {} } foreach item [array names ::env HTTP_*] { set ::env($item) {} } set ::env(SCRIPT_NAME) [my request get REQUEST_PATH] set ::env(SERVER_PROTOCOL) HTTP/1.0 set ::env(HOME) $::env(DOCUMENT_ROOT) foreach {f v} [my request dump] { set ::env($f) $v } set arglist $::env(QUERY_STRING) set pwd [pwd] cd [file dirname $local_file] set script_file $local_file if {[file extension $local_file] in {.fossil .fos}} { if {![file exists $local_file.cgi]} { set fout [open $local_file.cgi w] chan puts $fout "#!/usr/bin/fossil" chan puts $fout "repository: $local_file" close $fout } set script_file $local_file.cgi set EXE [my Cgi_Executable fossil] } else { set EXE [my Cgi_Executable $local_file] } set ::env(PATH_TRANSLATED) $script_file set pipe [my CgiExec $EXE $script_file $arglist] cd $pwd return $pipe } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} set length [my request get CONTENT_LENGTH] if {$length} { chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 ### # Send any POST/PUT/etc content ### my ChannelCopy $chana $chanb -size $length } else { chan flush $chanb } chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] chan event $chana readable {} set replyhead [my HttpHeaders $chana] set replydat [my MimeParse $replyhead] if {![dict exists $replydat Content-Length]} { set length 0 } else { set length [dict get $replydat Content-Length] } ### # Convert the Status: header from the CGI process to # a standard service reply line from a web server, but # otherwise spit out the rest of the headers verbatim ### set replybuffer "HTTP/1.0 [dict get $replydat Status]\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer ### # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 } method DirectoryListing {local_file} { my error 403 {Not Allowed} tailcall my DoOutput } } ### # END: cgi.tcl ### ### # START: scgi.tcl ### ::clay::define ::httpd::protocol.scgi { method EncodeStatus {status} { return "Status: $status" } } ::clay::define ::httpd::content.scgi { superclass ::httpd::content.proxy method scgi_info {} { ### # This method should check if a process is launched # or launch it if needed, and return a list of # HOST PORT SCRIPT_NAME ### # return {localhost 8016 /some/path} error unimplemented } method proxy_channel {} { set sockinfo [my scgi_info] if {$sockinfo eq {}} { my error 404 {Not Found} tailcall my DoOutput } lassign $sockinfo scgihost scgiport scgiscript my clay set SCRIPT_NAME $scgiscript if {![string is integer $scgiport]} { my error 404 {Not Found} tailcall my DoOutput } return [::socket $scgihost $scgiport] } method ProxyRequest {chana chanb} { chan event $chanb writable {} my log ProxyRequest {} chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my clay get SCRIPT_NAME]] foreach {f v} [my request dump] { dict set info $f $v } set length [dict get $info CONTENT_LENGTH] set block {} foreach {f v} $info { append block [string toupper $f] \x00 $v \x00 } chan puts -nonewline $chanb "[string length $block]:$block," # Light off another coroutine #set cmd [list coroutine [my CoroName] {*}[namespace code [list my ProxyReply $chanb $chana]]] if {$length} { chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 ### # Send any POST/PUT/etc content ### my ChannelCopy $chana $chanb -size $length #chan copy $chana $chanb -size $length -command [info coroutine] } else { chan flush $chanb } chan event $chanb readable [info coroutine] yield } method ProxyReply {chana chanb args} { my log ProxyReply [list args $args] chan event $chana readable {} set replyhead [my HttpHeaders $chana] set replydat [my MimeParse $replyhead] ### # Convert the Status: header from the CGI process to # a standard service reply line from a web server, but # otherwise spit out the rest of the headers verbatim ### set replybuffer "HTTP/1.0 [dict get $replydat Status]\n" append replybuffer $replyhead chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096 chan puts $chanb $replybuffer ### # Output the body. With no -size flag, channel will copy until EOF ### chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096 chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096 my ChannelCopy $chana $chanb -chunk 4096 } } ::clay::define ::httpd::server.scgi { superclass ::httpd::server clay set socket/ buffersize 32768 clay set socket/ blocking 0 clay set socket/ translation {binary binary} method debug args { puts $args } method Connect {uuid sock ip} { yield [info coroutine] chan event $sock readable {} chan configure $sock \ -blocking 1 \ -translation {binary binary} \ -buffersize 4096 \ -buffering none my counter url_hit try { # Read the SCGI request on byte at a time until we reach a ":" dict set query http HTTP_HOST {} dict set query http CONTENT_LENGTH 0 dict set query http REQUEST_URI / dict set query http REMOTE_ADDR $ip set size {} while 1 { set char [::coroutine::util::read $sock 1] if {[chan eof $sock]} { catch {close $sock} return } if {$char eq ":"} break append size $char } # With length in hand, read the netstring encoded headers set inbuffer [::coroutine::util::read $sock [expr {$size+1}]] chan configure $sock -blocking 0 -buffersize 4096 -buffering full foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] { dict set query http $f $v } if {![dict exists $query http REQUEST_PATH]} { set uri [dict get $query http REQUEST_URI] set uriinfo [::uri::split $uri] dict set query http REQUEST_PATH [dict get $uriinfo path] } set reply [my dispatch $query] } on error {err errdat} { my debug [list uri: [dict getnull $query http REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"} catch {chan event readable $sock {}} catch {chan event writeable $sock {}} catch {chan close $sock} return } if {[dict size $reply]==0} { my log BadLocation $uuid $query dict set query http HTTP_STATUS 404 dict set query template notfound dict set query mixin reply ::httpd::content.template } try { set pageobj [::httpd::reply create ::httpd::object::$uuid [self]] dict set reply mixin protocol ::httpd::protocol.scgi $pageobj dispatch $sock $reply } on error {err errdat} { my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]] catch {$pageobj destroy} catch {chan event readable $sock {}} catch {chan event writeable $sock {}} catch {chan close $sock} return } } } ### # END: scgi.tcl ### ### # START: websocket.tcl ### ::clay::define ::httpd::content.websocket { } ### # END: websocket.tcl ### ### # START: plugin.tcl ### ::clay::define ::httpd::plugin { clay set plugin/ load {} clay set plugin/ headers {} clay set plugin/ dispatch {} clay set plugin/ local_config {} clay set plugin/ thread {} } ::clay::define ::httpd::plugin.dict_dispatch { clay set plugin/ dispatch { set reply [my Dispatch_Dict $data] if {[dict size $reply]} { return $reply } } method Dispatch_Dict {data} { my variable url_patterns set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0] set uri [dict get $data http REQUEST_PATH] foreach {host hostpat} $url_patterns { if {![string match $host $vhost]} continue foreach {pattern info} $hostpat { if {![string match $pattern $uri]} continue set buffer $data foreach {f v} $info { dict set buffer $f $v } return $buffer } } return {} } Ensemble uri::add {vhosts patterns info} { my variable url_patterns foreach vhost $vhosts { foreach pattern $patterns { set data $info if {![dict exists $data prefix]} { dict set data prefix [my PrefixNormalize $pattern] } dict set url_patterns $vhost [string trimleft $pattern /] $data } } } Ensemble uri::direct {vhosts patterns info body} { my variable url_patterns url_stream set cbody {} if {[dict exists $info superclass]} { append cbody \n "superclass {*}[dict get $info superclass]" dict unset info superclass } append cbody \n [list method content {} $body] set class [namespace current]::${vhosts}/${patterns} set class [string map {* %} $class] ::clay::define $class $cbody dict set info mixin content $class my uri add $vhosts $patterns $info } } ::clay::define ::httpd::reply.memchan { superclass ::httpd::reply method output {} { my variable reply_body return $reply_body } method DoOutput {} {} method close {} { # Neuter the channel closing mechanism we need the channel to stay alive # until the reader sucks out the info } } ::clay::define ::httpd::plugin.local_memchan { clay set plugin/ load { package require tcl::chan::events package require tcl::chan::memchan } method local_memchan {command args} { my variable sock_to_coro switch $command { geturl { ### # Hook to allow a local process to ask for data without a socket ### set uuid [my Uuid_Generate] set ip 127.0.0.1 set sock [::tcl::chan::memchan] set output [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect_Local $uuid $sock GET {*}$args]]] return $output } default { error "Valid: connect geturl" } } } method Connect_Local {uuid sock args} { chan event $sock readable {} chan configure $sock \ -blocking 0 \ -translation {auto crlf} \ -buffering line set ip 127.0.0.1 dict set query UUID $uuid dict set query http UUID $uuid dict set query http HTTP_HOST localhost dict set query http REMOTE_ADDR 127.0.0.1 dict set query http REMOTE_HOST localhost dict set query http LOCALHOST 1 my counter url_hit dict set query http REQUEST_METHOD [lindex $args 0] set uriinfo [::uri::split [lindex $args 1]] dict set query http REQUEST_URI [lindex $args 1] dict set query http REQUEST_PATH [dict get $uriinfo path] dict set query http REQUEST_VERSION [lindex [split [lindex $args end] /] end] dict set query http DOCUMENT_ROOT [my clay get server/ doc_root] dict set query http QUERY_STRING [dict get $uriinfo query] dict set query http REQUEST_RAW $args dict set query http SERVER_PORT [my port_listening] my Headers_Process query set reply [my dispatch $query] if {[llength $reply]==0} { my log BadLocation $uuid $query my log BadLocation $uuid $query dict set query http HTTP_STATUS 404 dict set query template notfound dict set query mixin reply ::httpd::content.template } set class ::httpd::reply.memchan set pageobj [$class create ::httpd::object::$uuid [self]] if {[dict exists $reply mixin]} { set mixinmap [dict get $reply mixin] } else { set mixinmap {} } foreach item [dict keys $reply MIXIN_*] { set slot [string range $reply 6 end] dict set mixinmap [string tolower $slot] [dict get $reply $item] } $pageobj clay mixinmap {*}$mixinmap if {[dict exists $reply delegate]} { $pageobj clay delegate {*}[dict get $reply delegate] } $pageobj dispatch $sock $reply set output [$pageobj output] catch {$pageobj destroy} return $output } } ### # END: plugin.tcl ### namespace eval ::httpd { namespace export * } |
Changes to modules/httpd/httpd.test.
1 2 3 | # httpd.test - Copyright (c) 2015 Sean Woods # ------------------------------------------------------------------------- | > > > > > > > | | < < < | | | < | | | | > > | | | | | | | | < | < < < | < | | | < < < | | | > > > | 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 | # httpd.test - Copyright (c) 2015 Sean Woods # ------------------------------------------------------------------------- set TESTDIR [file dirname [file normalize [info script]]] set MODDIR [file dirname $TESTDIR] if {[file exists [file join $MODDIR devtools testutilities.tcl]]} { # Running inside tcllib set TCLLIBMOD $MODDIR } else { set TCLLIBMOD [file join $MODDIR .. .. tcllib modules] } source [file join $TCLLIBMOD devtools testutilities.tcl] testsNeedTcl 8.6 ;# tool requires 8.6 testsNeedTcltest 2 testsNeed TclOO 1 support { use [file join ${TCLLIBMOD} fumagic rtcore.tcl] fileutil::magic::rt use [file join ${TCLLIBMOD} fumagic filetypes.tcl] fileutil::magic::filetype use [file join ${TCLLIBMOD} textutil string.tcl] textutil::string use [file join ${TCLLIBMOD} textutil repeat.tcl] textutil::repeat use [file join ${TCLLIBMOD} textutil tabify.tcl] textutil::tabify use [file join ${TCLLIBMOD} markdown markdown.tcl] Markdown use [file join ${TCLLIBMOD} ncgi ncgi.tcl] ncgi use [file join ${TCLLIBMOD} log logger.tcl] logger use [file join ${TCLLIBMOD} base64 base64.tcl] base64 use [file join ${TCLLIBMOD} md5 md5x.tcl] md5 use [file join ${TCLLIBMOD} mime mime.tcl] mime use [file join ${TCLLIBMOD} uuid uuid.tcl] uuid use [file join ${TCLLIBMOD} cmdline cmdline.tcl] cmdline use [file join ${TCLLIBMOD} fileutil fileutil.tcl] fileutil use [file join ${TCLLIBMOD} sha1 sha1.tcl] sha1 use [file join ${TCLLIBMOD} uri uri.tcl] uri use [file join ${TCLLIBMOD} ncgi ncgi.tcl] ncgi use [file join ${TCLLIBMOD} dns ip.tcl] ip use [file join ${TCLLIBMOD} nettool nettool.tcl] nettool use [file join ${TCLLIBMOD} coroutine coroutine.tcl] coroutine use [file join ${TCLLIBMOD} dicttool dicttool.tcl] dicttool use [file join ${TCLLIBMOD} cron cron.tcl] cron use [file join ${TCLLIBMOD} virtchannel_core core.tcl] tcl::chan::core use [file join ${TCLLIBMOD} virtchannel_core events.tcl] tcl::chan::events use [file join ${TCLLIBMOD} virtchannel_base memchan.tcl] tcl::chan::memchan use [file join ${TCLLIBMOD} websocket websocket.tcl] websocket use [file join ${MODDIR} clay clay.tcl] clay } testing { useLocal httpd.tcl httpd } # Set to true for debugging and traces set ::DEBUG 0 set ::clay::debug $::DEBUG proc DEBUG args { if {$::DEBUG} { uplevel 1 $args } } |
︙ | ︙ | |||
130 131 132 133 134 135 136 | chan event $sock readable {} set [namespace current]::reply($sock) $buffer($sock) unset buffer($sock) } } | | < | > > > > | | | | | | | | | | < < < | | | | | | | | 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 | chan event $sock readable {} set [namespace current]::reply($sock) $buffer($sock) unset buffer($sock) } } clay::define ::httpd::server { method log args {} method TemplateSearch page { set doc_root [my clay get server/ doc_root] if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} { return [::fileutil::cat [file join $doc_root $page.tml]] } if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} { return [::fileutil::cat [file join $doc_root $page.html]] } switch $page { redirect { return {300 Redirect} } notfound { return {404 Not Found} } internal_error { return {500 Server Internal Error} } } } ::DEBUG method debug args { puts stderr $args } ::DEBUG method log args { puts stdout $args } } ### # Modify the reply class to return plain text ### clay::define ::httpd::reply { method HttpHeaders_Default {} { return {Status {200 OK} Content-Type {text/plain} Connection close} } method reset {} { my variable reply_body my reply replace [my HttpHeaders_Default] set reply_body {} } method error {code {msg {}} {errorInfo {}}} { my clay set HTTP_ERROR $code my reset set errorstring [my http_code_string $code] set qheaders [my clay dump] dict with qheaders {} my reply replace {} my reply set Status "$code $errorstring" my reply set Content-Type text/plain my puts "$code $errorstring" } } clay::define ::test::content.echo { method content {} { my variable reply_body set reply_body [my PostData [my request get CONTENT_LENGTH]] #puts [list REPLY BODY WAS $reply_body] } } clay::define ::test::content.file { superclass ::httpd::content.file method content {} { my reset set doc_root [my request get DOCUMENT_ROOT] my variable reply_file set reply_file [file join $doc_root pkgIndex.tcl] } } clay::define ::test::content.time { method content {} { my variable reply_body set reply_body [clock seconds] } } clay::define ::test::content.error { method content {} { error {The programmer asked me to die this way} } } clay::define ::test::content.cgi { superclass ::httpd::content.cgi } clay::define ::httpd::test::reply { superclass ::httpd::reply ::test::content.echo } ### # Build the server ### ::httpd::server create TESTAPP port 10001 doc_root $::TESTDIR TESTAPP plugin dict_dispatch TESTAPP uri add * / [list mixin {reply ::test::content.echo}] TESTAPP uri add * /echo [list mixin {reply ::test::content.echo}] TESTAPP uri add * /file [list mixin {reply ::test::content.file}] TESTAPP uri add * /time [list mixin {reply ::test::content.time}] TESTAPP uri add * /error [list mixin {replyy ::test::content.error}] # Catch all #TESTAPP uri add * * [list mixin {reply httpd::content.echo}] ::DEBUG puts httpd-client-0001 test httpd-client-0001 {Do an echo request} { set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS IS MY CODE}] ::httpd::test::compare $reply {HTTP/1.0 200 OK Content-Type: text/plain |
︙ | ︙ | |||
305 306 307 308 309 310 311 | ::DEBUG puts httpd-client-0005 test httpd-client-0005 {URL Different output with a different request} { set reply [::httpd::test::send 10001 {POST /time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply $checkreply } {} | | > > > > > > > > > > > > | < | | | | | | | | | 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 | ::DEBUG puts httpd-client-0005 test httpd-client-0005 {URL Different output with a different request} { set reply [::httpd::test::send 10001 {POST /time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply $checkreply } {} set fin [open [file join $TESTDIR pkgIndex.tcl] r] set replyfile [read $fin] close $fin set checkreply "HTTP/1.0 200 OK Content-Type: text/plain Connection: close Content-Length: [string length $replyfile] $replyfile" ::DEBUG puts httpd-client-0006 test httpd-client-0006 {Return a file} { set reply [::httpd::test::send 10001 {GET /file HTTP/1.0} {} {}] ::httpd::test::compare $reply $checkreply } {} ::DEBUG puts httpd-client-0007 test httpd-client-0007 {URL Generates Not Found} { set reply [::httpd::test::send 10001 {POST /doesnotexist HTTP/1.0} {} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply {HTTP/1.0 404 Not Found Content-Type: text/plain Connection: close Content-Length: * 404 Not Found} } {} # ------------------------------------------------------------------------- # Test proxies clay::define ::test::content.proxy { superclass ::httpd::content.proxy method proxy_channel {} { return [::socket localhost [my clay get proxy_port]] } } ::httpd::server create TESTPROXY port 10002 doc_root $::TESTDIR TESTAPP uri add * /proxy* [list mixin {reply ::test::content.proxy} proxy_port [TESTPROXY port_listening]] TESTPROXY plugin dict_dispatch TESTPROXY uri add * / [list mixin {reply ::test::content.echo}] TESTPROXY uri add * /echo [list mixin {reply ::test::content.echo}] TESTPROXY uri add * /file [list mixin {reply ::test::content.file}] TESTPROXY uri add * /time [list mixin {reply ::test::content.time}] TESTPROXY uri add * /error [list mixin {reply ::test::content.error}] ::DEBUG puts httpd-proxy-0001 test httpd-proxy-0001 {Do an echo request} { set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS IS MY CODE}] ::httpd::test::compare $reply {HTTP/1.0 200 OK Content-Type: text/plain |
︙ | ︙ | |||
404 405 406 407 408 409 410 | ::DEBUG puts httpd-proxy-0005 test httpd-proxy-0005 {URL Different output with a different request} { set reply [::httpd::test::send 10001 {POST /proxy/time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply $checkreply } {} | | < < | | | 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 | ::DEBUG puts httpd-proxy-0005 test httpd-proxy-0005 {URL Different output with a different request} { set reply [::httpd::test::send 10001 {POST /proxy/time HTTP/1.0} {} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply $checkreply } {} set fin [open [file join $TESTDIR pkgIndex.tcl] r] set replyfile [read $fin] close $fin set checkreply "HTTP/1.0 200 OK Content-Type: text/plain Connection: close Content-Length: [string length $replyfile] $replyfile" ::DEBUG puts httpd-proxy-0006 test httpd-proxy-0006 {Return a file} { set reply [::httpd::test::send 10001 {GET /proxy/file HTTP/1.0} {} {}] ::httpd::test::compare $reply $checkreply } {} # ------------------------------------------------------------------------- # cgi TESTAPP plugin local_memchan TESTAPP uri add * /cgi-bin* [list mixin {reply ::test::content.cgi} path $::TESTDIR] set fout [open [file join $TESTDIR test.tcl] w] puts $fout {#!/usr/bin/tclsh puts stdout "Status: 200 OK" if {$::env(CONTENT_LENGTH) > 0} { puts stdout "Content-Type: $::env(CONTENT_TYPE)" set dat [read stdin $::env(CONTENT_LENGTH)] } else { |
︙ | ︙ | |||
558 559 560 561 562 563 564 | namespace eval ::scgi { variable server_block {SCGI 1.0 SERVER_SOFTWARE {TclScgiServer/0.1}} } ### # Build the reply class ### | | | | | > | | | | | | > | 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 | namespace eval ::scgi { variable server_block {SCGI 1.0 SERVER_SOFTWARE {TclScgiServer/0.1}} } ### # Build the reply class ### ::clay::define ::scgi::test::reply { superclass ::httpd::reply method reset {} { my variable reply_body my reply replace [my HttpHeaders_Default] set reply_body {} } } ### # Build the server ### ::clay::define scgi::test::app { superclass ::httpd::server.scgi clay set reply_class ::scgi::test::reply } puts [list ::test::content.file [info commands ::test::content.file]] scgi::test::app create TESTSCGI port 10003 doc_root $::TESTDIR TESTSCGI plugin dict_dispatch TESTSCGI uri add * / [list mixin {reply ::test::content.echo}] TESTSCGI uri add * /echo [list mixin {reply ::test::content.echo}] TESTSCGI uri add * /file [list mixin {reply ::test::content.file}] TESTSCGI uri add * /time [list mixin {reply ::test::content.time}] TESTSCGI uri add * /error [list mixin {reply ::test::content.error}] ::DEBUG puts scgi-client-0001 test scgi-client-0001 {Do an echo request} { set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS IS MY CODE}] set checkreply {Status: 200 OK Content-Type: text/plain Connection: close Content-Length: * THIS IS MY CODE} ::httpd::test::compare $reply $checkreply } {} ::DEBUG puts scgi-client-0002 test scgi-client-0002 {Do another echo request} { set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT}] set checkreply {Status: 200 OK Content-Type: text/plain Connection: close |
︙ | ︙ | |||
651 652 653 654 655 656 657 | ::DEBUG puts scgi-client-0005 test scgi-client-0005 {URL Different output with a different request} { set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /time} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply $checkreply } {} | | > > > > > > | | | | | | | | | | | | 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 | ::DEBUG puts scgi-client-0005 test scgi-client-0005 {URL Different output with a different request} { set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /time} {THIS ONE ALONE IS MINE}] ::httpd::test::compare $reply $checkreply } {} set fin [open [file join $TESTDIR pkgIndex.tcl] r] set checkfile [read $fin] close $fin ### # Nerfed: There is something screwy that is preventing this test from working # properly in Sak. But only this test, and not the other two (normal client and proxy) # who are doing essentially the same operation # Investigate at some point - Sean ### #::DEBUG puts scgi-client-0006 #test scgi-client-0006 {Return a file} { #set reply [::scgi::test::send 10003 {REQUEST_METHOD GET REQUEST_URI /file} {}] #set checkreply "Status: 200 OK #Content-Type: text/plain #Connection: close #Content-Length: [string length $checkfile] #$checkfile" #::httpd::test::compare $reply $checkreply #} {} ::DEBUG puts all-tests-finished file delete [file join $TESTDIR test.tcl] # ------------------------------------------------------------------------- testsuiteCleanup # Local variables: # mode: tcl # indent-tabs-mode: nil # End: |
Changes to modules/httpd/pkgIndex.tcl.
1 2 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} | | | 1 2 3 4 | if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded httpd 4.3.3 [list source [file join $dir httpd.tcl]] |
Added modules/nettool/available_ports.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 | namespace eval ::nettool { set blocks {} } lappend ::nettool::blocks 1028 1028 lappend ::nettool::blocks 1067 1068 lappend ::nettool::blocks 1109 1109 lappend ::nettool::blocks 1138 1138 lappend ::nettool::blocks 1313 1313 lappend ::nettool::blocks 1382 1382 lappend ::nettool::blocks 1385 1385 lappend ::nettool::blocks 1416 1416 lappend ::nettool::blocks 1454 1454 lappend ::nettool::blocks 1461 1461 lappend ::nettool::blocks 1464 1464 lappend ::nettool::blocks 1486 1486 lappend ::nettool::blocks 1491 1491 lappend ::nettool::blocks 1493 1493 lappend ::nettool::blocks 1528 1528 lappend ::nettool::blocks 1556 1556 lappend ::nettool::blocks 1587 1587 lappend ::nettool::blocks 1651 1651 lappend ::nettool::blocks 1783 1783 lappend ::nettool::blocks 1895 1895 lappend ::nettool::blocks 2083 2083 lappend ::nettool::blocks 2194 2196 lappend ::nettool::blocks 2222 2222 lappend ::nettool::blocks 2259 2259 lappend ::nettool::blocks 2340 2340 lappend ::nettool::blocks 2346 2349 lappend ::nettool::blocks 2369 2369 lappend ::nettool::blocks 2377 2378 lappend ::nettool::blocks 2395 2395 lappend ::nettool::blocks 2426 2426 lappend ::nettool::blocks 2446 2446 lappend ::nettool::blocks 2528 2528 lappend ::nettool::blocks 2640 2640 lappend ::nettool::blocks 2654 2654 lappend ::nettool::blocks 2682 2682 lappend ::nettool::blocks 2693 2693 lappend ::nettool::blocks 2794 2794 lappend ::nettool::blocks 2825 2825 lappend ::nettool::blocks 2873 2873 lappend ::nettool::blocks 2916 2917 lappend ::nettool::blocks 2925 2925 lappend ::nettool::blocks 3014 3014 lappend ::nettool::blocks 3016 3019 lappend ::nettool::blocks 3024 3024 lappend ::nettool::blocks 3027 3029 lappend ::nettool::blocks 3050 3050 lappend ::nettool::blocks 3080 3080 lappend ::nettool::blocks 3092 3092 lappend ::nettool::blocks 3126 3126 lappend ::nettool::blocks 3300 3301 lappend ::nettool::blocks 3396 3396 lappend ::nettool::blocks 3403 3404 lappend ::nettool::blocks 3546 3546 lappend ::nettool::blocks 3693 3694 lappend ::nettool::blocks 3876 3876 lappend ::nettool::blocks 3900 3900 lappend ::nettool::blocks 3938 3938 lappend ::nettool::blocks 3970 3970 lappend ::nettool::blocks 3986 3986 lappend ::nettool::blocks 3994 3994 lappend ::nettool::blocks 4000 4000 lappend ::nettool::blocks 4048 4048 lappend ::nettool::blocks 4060 4060 lappend ::nettool::blocks 4065 4065 lappend ::nettool::blocks 4120 4120 lappend ::nettool::blocks 4132 4133 lappend ::nettool::blocks 4140 4140 lappend ::nettool::blocks 4144 4144 lappend ::nettool::blocks 4151 4152 lappend ::nettool::blocks 4184 4184 lappend ::nettool::blocks 4194 4198 lappend ::nettool::blocks 4315 4315 lappend ::nettool::blocks 4317 4319 lappend ::nettool::blocks 4332 4332 lappend ::nettool::blocks 4334 4339 lappend ::nettool::blocks 4363 4367 lappend ::nettool::blocks 4370 4370 lappend ::nettool::blocks 4380 4388 lappend ::nettool::blocks 4397 4399 lappend ::nettool::blocks 4412 4424 lappend ::nettool::blocks 4434 4440 lappend ::nettool::blocks 4459 4483 lappend ::nettool::blocks 4489 4499 lappend ::nettool::blocks 4501 4501 lappend ::nettool::blocks 4503 4533 lappend ::nettool::blocks 4539 4544 lappend ::nettool::blocks 4560 4562 lappend ::nettool::blocks 4564 4565 lappend ::nettool::blocks 4569 4569 lappend ::nettool::blocks 4571 4589 lappend ::nettool::blocks 4606 4657 lappend ::nettool::blocks 4693 4699 lappend ::nettool::blocks 4705 4724 lappend ::nettool::blocks 4734 4736 lappend ::nettool::blocks 4746 4746 lappend ::nettool::blocks 4748 4748 lappend ::nettool::blocks 4754 4783 lappend ::nettool::blocks 4792 4799 lappend ::nettool::blocks 4805 4826 lappend ::nettool::blocks 4828 4836 lappend ::nettool::blocks 4846 4846 lappend ::nettool::blocks 4852 4866 lappend ::nettool::blocks 4872 4875 lappend ::nettool::blocks 4886 4893 lappend ::nettool::blocks 4895 4898 lappend ::nettool::blocks 4903 4911 lappend ::nettool::blocks 4916 4935 lappend ::nettool::blocks 4938 4939 lappend ::nettool::blocks 4943 4948 lappend ::nettool::blocks 4954 4968 lappend ::nettool::blocks 4971 4983 lappend ::nettool::blocks 4992 4998 lappend ::nettool::blocks 5016 5019 lappend ::nettool::blocks 5033 5041 lappend ::nettool::blocks 5076 5077 lappend ::nettool::blocks 5088 5089 lappend ::nettool::blocks 5095 5098 lappend ::nettool::blocks 5107 5110 lappend ::nettool::blocks 5113 5113 lappend ::nettool::blocks 5118 5119 lappend ::nettool::blocks 5121 5132 lappend ::nettool::blocks 5138 5145 lappend ::nettool::blocks 5147 5149 lappend ::nettool::blocks 5151 5151 lappend ::nettool::blocks 5158 5160 lappend ::nettool::blocks 5165 5165 lappend ::nettool::blocks 5169 5171 lappend ::nettool::blocks 5173 5189 lappend ::nettool::blocks 5197 5199 lappend ::nettool::blocks 5204 5208 lappend ::nettool::blocks 5210 5214 lappend ::nettool::blocks 5216 5220 lappend ::nettool::blocks 5238 5244 lappend ::nettool::blocks 5254 5263 lappend ::nettool::blocks 5266 5268 lappend ::nettool::blocks 5273 5279 lappend ::nettool::blocks 5283 5297 lappend ::nettool::blocks 5311 5311 lappend ::nettool::blocks 5316 5316 lappend ::nettool::blocks 5319 5319 lappend ::nettool::blocks 5322 5342 lappend ::nettool::blocks 5345 5348 lappend ::nettool::blocks 5365 5396 lappend ::nettool::blocks 5438 5442 lappend ::nettool::blocks 5444 5444 lappend ::nettool::blocks 5446 5452 lappend ::nettool::blocks 5457 5460 lappend ::nettool::blocks 5466 5499 lappend ::nettool::blocks 5507 5552 lappend ::nettool::blocks 5558 5565 lappend ::nettool::blocks 5570 5572 lappend ::nettool::blocks 5576 5578 lappend ::nettool::blocks 5587 5596 lappend ::nettool::blocks 5606 5617 lappend ::nettool::blocks 5619 5626 lappend ::nettool::blocks 5640 5645 lappend ::nettool::blocks 5647 5669 lappend ::nettool::blocks 5685 5686 lappend ::nettool::blocks 5690 5692 lappend ::nettool::blocks 5694 5695 lappend ::nettool::blocks 5697 5712 lappend ::nettool::blocks 5731 5740 lappend ::nettool::blocks 5749 5749 lappend ::nettool::blocks 5751 5754 lappend ::nettool::blocks 5756 5756 lappend ::nettool::blocks 5758 5765 lappend ::nettool::blocks 5772 5776 lappend ::nettool::blocks 5778 5779 lappend ::nettool::blocks 5788 5792 lappend ::nettool::blocks 5795 5812 lappend ::nettool::blocks 5815 5840 lappend ::nettool::blocks 5843 5858 lappend ::nettool::blocks 5860 5862 lappend ::nettool::blocks 5864 5867 lappend ::nettool::blocks 5869 5882 lappend ::nettool::blocks 5884 5899 lappend ::nettool::blocks 5901 5909 lappend ::nettool::blocks 5914 5962 lappend ::nettool::blocks 5964 5967 lappend ::nettool::blocks 5970 5983 lappend ::nettool::blocks 5993 5998 lappend ::nettool::blocks 6067 6067 lappend ::nettool::blocks 6078 6080 lappend ::nettool::blocks 6089 6098 lappend ::nettool::blocks 6119 6120 lappend ::nettool::blocks 6125 6129 lappend ::nettool::blocks 6131 6132 lappend ::nettool::blocks 6134 6139 lappend ::nettool::blocks 6150 6158 lappend ::nettool::blocks 6164 6199 lappend ::nettool::blocks 6202 6221 lappend ::nettool::blocks 6223 6240 lappend ::nettool::blocks 6245 6250 lappend ::nettool::blocks 6254 6266 lappend ::nettool::blocks 6270 6299 lappend ::nettool::blocks 6301 6305 lappend ::nettool::blocks 6307 6314 lappend ::nettool::blocks 6318 6319 lappend ::nettool::blocks 6323 6323 lappend ::nettool::blocks 6327 6342 lappend ::nettool::blocks 6345 6345 lappend ::nettool::blocks 6348 6349 lappend ::nettool::blocks 6351 6354 lappend ::nettool::blocks 6356 6359 lappend ::nettool::blocks 6361 6362 lappend ::nettool::blocks 6364 6369 lappend ::nettool::blocks 6371 6381 lappend ::nettool::blocks 6383 6388 lappend ::nettool::blocks 6391 6399 lappend ::nettool::blocks 6411 6416 lappend ::nettool::blocks 6422 6431 lappend ::nettool::blocks 6433 6441 lappend ::nettool::blocks 6444 6445 lappend ::nettool::blocks 6447 6454 lappend ::nettool::blocks 6457 6470 lappend ::nettool::blocks 6472 6479 lappend ::nettool::blocks 6490 6499 lappend ::nettool::blocks 6501 6508 lappend ::nettool::blocks 6512 6512 lappend ::nettool::blocks 6516 6542 lappend ::nettool::blocks 6545 6546 lappend ::nettool::blocks 6552 6557 lappend ::nettool::blocks 6559 6565 lappend ::nettool::blocks 6569 6578 lappend ::nettool::blocks 6584 6599 lappend ::nettool::blocks 6603 6618 lappend ::nettool::blocks 6629 6631 lappend ::nettool::blocks 6635 6639 lappend ::nettool::blocks 6641 6652 lappend ::nettool::blocks 6654 6654 lappend ::nettool::blocks 6658 6664 lappend ::nettool::blocks 6672 6677 lappend ::nettool::blocks 6680 6686 lappend ::nettool::blocks 6690 6695 lappend ::nettool::blocks 6698 6700 lappend ::nettool::blocks 6707 6713 lappend ::nettool::blocks 6717 6766 lappend ::nettool::blocks 6772 6776 lappend ::nettool::blocks 6779 6783 lappend ::nettool::blocks 6792 6800 lappend ::nettool::blocks 6802 6816 lappend ::nettool::blocks 6818 6830 lappend ::nettool::blocks 6832 6840 lappend ::nettool::blocks 6843 6849 lappend ::nettool::blocks 6851 6867 lappend ::nettool::blocks 6869 6887 lappend ::nettool::blocks 6889 6900 lappend ::nettool::blocks 6902 6934 lappend ::nettool::blocks 6937 6945 lappend ::nettool::blocks 6947 6950 lappend ::nettool::blocks 6952 6960 lappend ::nettool::blocks 6967 6968 lappend ::nettool::blocks 6971 6996 lappend ::nettool::blocks 7016 7017 lappend ::nettool::blocks 7026 7029 lappend ::nettool::blocks 7032 7039 lappend ::nettool::blocks 7041 7069 lappend ::nettool::blocks 7072 7072 lappend ::nettool::blocks 7074 7079 lappend ::nettool::blocks 7081 7094 lappend ::nettool::blocks 7096 7098 lappend ::nettool::blocks 7102 7106 lappend ::nettool::blocks 7108 7120 lappend ::nettool::blocks 7122 7127 lappend ::nettool::blocks 7130 7160 lappend ::nettool::blocks 7175 7180 lappend ::nettool::blocks 7182 7199 lappend ::nettool::blocks 7202 7226 lappend ::nettool::blocks 7230 7234 lappend ::nettool::blocks 7238 7261 lappend ::nettool::blocks 7263 7271 lappend ::nettool::blocks 7284 7299 lappend ::nettool::blocks 7360 7364 lappend ::nettool::blocks 7366 7390 lappend ::nettool::blocks 7396 7396 lappend ::nettool::blocks 7398 7399 lappend ::nettool::blocks 7403 7409 lappend ::nettool::blocks 7412 7420 lappend ::nettool::blocks 7422 7425 lappend ::nettool::blocks 7432 7436 lappend ::nettool::blocks 7438 7442 lappend ::nettool::blocks 7444 7470 lappend ::nettool::blocks 7472 7472 lappend ::nettool::blocks 7475 7490 lappend ::nettool::blocks 7492 7499 lappend ::nettool::blocks 7502 7507 lappend ::nettool::blocks 7512 7541 lappend ::nettool::blocks 7551 7559 lappend ::nettool::blocks 7561 7562 lappend ::nettool::blocks 7564 7565 lappend ::nettool::blocks 7567 7568 lappend ::nettool::blocks 7571 7573 lappend ::nettool::blocks 7575 7587 lappend ::nettool::blocks 7589 7623 lappend ::nettool::blocks 7625 7625 lappend ::nettool::blocks 7632 7632 lappend ::nettool::blocks 7634 7647 lappend ::nettool::blocks 7649 7671 lappend ::nettool::blocks 7678 7679 lappend ::nettool::blocks 7681 7688 lappend ::nettool::blocks 7690 7696 lappend ::nettool::blocks 7698 7699 lappend ::nettool::blocks 7701 7706 lappend ::nettool::blocks 7709 7719 lappend ::nettool::blocks 7721 7723 lappend ::nettool::blocks 7728 7733 lappend ::nettool::blocks 7735 7737 lappend ::nettool::blocks 7739 7740 lappend ::nettool::blocks 7745 7746 lappend ::nettool::blocks 7748 7776 lappend ::nettool::blocks 7780 7780 lappend ::nettool::blocks 7782 7785 lappend ::nettool::blocks 7788 7788 lappend ::nettool::blocks 7790 7793 lappend ::nettool::blocks 7795 7796 lappend ::nettool::blocks 7803 7809 lappend ::nettool::blocks 7811 7844 lappend ::nettool::blocks 7848 7868 lappend ::nettool::blocks 7873 7877 lappend ::nettool::blocks 7879 7879 lappend ::nettool::blocks 7881 7886 lappend ::nettool::blocks 7888 7899 lappend ::nettool::blocks 7904 7912 lappend ::nettool::blocks 7914 7931 lappend ::nettool::blocks 7934 7961 lappend ::nettool::blocks 7963 7966 lappend ::nettool::blocks 7968 7978 lappend ::nettool::blocks 7983 7996 lappend ::nettool::blocks 8004 8004 lappend ::nettool::blocks 8006 8007 lappend ::nettool::blocks 8009 8018 lappend ::nettool::blocks 8023 8024 lappend ::nettool::blocks 8027 8031 lappend ::nettool::blocks 8035 8039 lappend ::nettool::blocks 8041 8041 lappend ::nettool::blocks 8045 8050 lappend ::nettool::blocks 8061 8065 lappend ::nettool::blocks 8067 8073 lappend ::nettool::blocks 8075 8079 lappend ::nettool::blocks 8084 8085 lappend ::nettool::blocks 8089 8090 lappend ::nettool::blocks 8092 8096 lappend ::nettool::blocks 8098 8099 lappend ::nettool::blocks 8103 8114 lappend ::nettool::blocks 8119 8120 lappend ::nettool::blocks 8123 8127 lappend ::nettool::blocks 8133 8139 lappend ::nettool::blocks 8141 8147 lappend ::nettool::blocks 8150 8152 lappend ::nettool::blocks 8154 8159 lappend ::nettool::blocks 8163 8180 lappend ::nettool::blocks 8185 8190 lappend ::nettool::blocks 8193 8193 lappend ::nettool::blocks 8196 8198 lappend ::nettool::blocks 8203 8203 lappend ::nettool::blocks 8209 8229 lappend ::nettool::blocks 8231 8242 lappend ::nettool::blocks 8244 8275 lappend ::nettool::blocks 8277 8279 lappend ::nettool::blocks 8281 8291 lappend ::nettool::blocks 8295 8299 lappend ::nettool::blocks 8302 8312 lappend ::nettool::blocks 8314 8319 lappend ::nettool::blocks 8322 8350 lappend ::nettool::blocks 8352 8375 lappend ::nettool::blocks 8381 8382 lappend ::nettool::blocks 8384 8399 lappend ::nettool::blocks 8406 8414 lappend ::nettool::blocks 8418 8441 lappend ::nettool::blocks 8446 8449 lappend ::nettool::blocks 8451 8456 lappend ::nettool::blocks 8458 8469 lappend ::nettool::blocks 8475 8499 lappend ::nettool::blocks 8503 8553 lappend ::nettool::blocks 8556 8566 lappend ::nettool::blocks 8568 8599 lappend ::nettool::blocks 8601 8608 lappend ::nettool::blocks 8616 8664 lappend ::nettool::blocks 8667 8674 lappend ::nettool::blocks 8676 8685 lappend ::nettool::blocks 8687 8687 lappend ::nettool::blocks 8689 8698 lappend ::nettool::blocks 8700 8710 lappend ::nettool::blocks 8712 8731 lappend ::nettool::blocks 8734 8749 lappend ::nettool::blocks 8751 8762 lappend ::nettool::blocks 8767 8769 lappend ::nettool::blocks 8771 8777 lappend ::nettool::blocks 8779 8785 lappend ::nettool::blocks 8788 8792 lappend ::nettool::blocks 8794 8799 lappend ::nettool::blocks 8801 8803 lappend ::nettool::blocks 8805 8872 lappend ::nettool::blocks 8874 8879 lappend ::nettool::blocks 8882 8882 lappend ::nettool::blocks 8884 8887 lappend ::nettool::blocks 8895 8898 lappend ::nettool::blocks 8902 8909 lappend ::nettool::blocks 8914 8936 lappend ::nettool::blocks 8938 8952 lappend ::nettool::blocks 8955 8988 lappend ::nettool::blocks 8992 8997 lappend ::nettool::blocks 9003 9006 lappend ::nettool::blocks 9011 9019 lappend ::nettool::blocks 9027 9049 lappend ::nettool::blocks 9052 9079 lappend ::nettool::blocks 9081 9081 lappend ::nettool::blocks 9094 9099 lappend ::nettool::blocks 9108 9118 lappend ::nettool::blocks 9120 9121 lappend ::nettool::blocks 9124 9130 lappend ::nettool::blocks 9132 9159 lappend ::nettool::blocks 9165 9190 lappend ::nettool::blocks 9192 9199 lappend ::nettool::blocks 9218 9221 lappend ::nettool::blocks 9223 9254 lappend ::nettool::blocks 9256 9276 lappend ::nettool::blocks 9288 9291 lappend ::nettool::blocks 9296 9299 lappend ::nettool::blocks 9301 9305 lappend ::nettool::blocks 9307 9311 lappend ::nettool::blocks 9313 9317 lappend ::nettool::blocks 9319 9320 lappend ::nettool::blocks 9322 9342 lappend ::nettool::blocks 9345 9345 lappend ::nettool::blocks 9347 9373 lappend ::nettool::blocks 9375 9379 lappend ::nettool::blocks 9381 9386 lappend ::nettool::blocks 9391 9395 lappend ::nettool::blocks 9398 9399 lappend ::nettool::blocks 9403 9417 lappend ::nettool::blocks 9419 9442 lappend ::nettool::blocks 9446 9449 lappend ::nettool::blocks 9451 9499 lappend ::nettool::blocks 9501 9521 lappend ::nettool::blocks 9523 9534 lappend ::nettool::blocks 9537 9554 lappend ::nettool::blocks 9556 9591 lappend ::nettool::blocks 9601 9611 lappend ::nettool::blocks 9613 9613 lappend ::nettool::blocks 9615 9615 lappend ::nettool::blocks 9619 9627 lappend ::nettool::blocks 9633 9639 lappend ::nettool::blocks 9641 9665 lappend ::nettool::blocks 9669 9693 lappend ::nettool::blocks 9696 9699 lappend ::nettool::blocks 9701 9746 lappend ::nettool::blocks 9748 9749 lappend ::nettool::blocks 9751 9752 lappend ::nettool::blocks 9754 9761 lappend ::nettool::blocks 9763 9799 lappend ::nettool::blocks 9803 9874 lappend ::nettool::blocks 9877 9877 lappend ::nettool::blocks 9879 9887 lappend ::nettool::blocks 9890 9897 lappend ::nettool::blocks 9904 9908 lappend ::nettool::blocks 9910 9910 lappend ::nettool::blocks 9912 9924 lappend ::nettool::blocks 9926 9949 lappend ::nettool::blocks 9957 9965 lappend ::nettool::blocks 9967 9977 lappend ::nettool::blocks 9979 9986 lappend ::nettool::blocks 9989 9989 lappend ::nettool::blocks 10003 10003 lappend ::nettool::blocks 10011 10022 lappend ::nettool::blocks 10024 10049 lappend ::nettool::blocks 10052 10054 lappend ::nettool::blocks 10056 10079 lappend ::nettool::blocks 10082 10099 lappend ::nettool::blocks 10105 10106 lappend ::nettool::blocks 10108 10109 lappend ::nettool::blocks 10112 10112 lappend ::nettool::blocks 10118 10127 lappend ::nettool::blocks 10130 10159 lappend ::nettool::blocks 10163 10199 lappend ::nettool::blocks 10202 10251 lappend ::nettool::blocks 10253 10259 lappend ::nettool::blocks 10261 10287 lappend ::nettool::blocks 10289 10320 lappend ::nettool::blocks 10322 10438 lappend ::nettool::blocks 10440 10499 lappend ::nettool::blocks 10501 10539 lappend ::nettool::blocks 10545 10630 lappend ::nettool::blocks 10632 10799 lappend ::nettool::blocks 10801 10804 lappend ::nettool::blocks 10806 10808 lappend ::nettool::blocks 10811 10859 lappend ::nettool::blocks 10861 10879 lappend ::nettool::blocks 10881 10989 lappend ::nettool::blocks 10991 10999 lappend ::nettool::blocks 11002 11094 lappend ::nettool::blocks 11096 11102 lappend ::nettool::blocks 11107 11107 lappend ::nettool::blocks 11113 11160 lappend ::nettool::blocks 11166 11170 lappend ::nettool::blocks 11176 11200 lappend ::nettool::blocks 11203 11207 lappend ::nettool::blocks 11209 11210 lappend ::nettool::blocks 11212 11318 lappend ::nettool::blocks 11322 11366 lappend ::nettool::blocks 11368 11370 lappend ::nettool::blocks 11372 11429 lappend ::nettool::blocks 11431 11488 lappend ::nettool::blocks 11490 11599 lappend ::nettool::blocks 11601 11622 lappend ::nettool::blocks 11624 11719 lappend ::nettool::blocks 11721 11722 lappend ::nettool::blocks 11724 11750 lappend ::nettool::blocks 11752 11795 lappend ::nettool::blocks 11797 11875 lappend ::nettool::blocks 11878 11966 lappend ::nettool::blocks 11968 11996 lappend ::nettool::blocks 12011 12011 lappend ::nettool::blocks 12014 12108 lappend ::nettool::blocks 12110 12120 lappend ::nettool::blocks 12122 12167 lappend ::nettool::blocks 12169 12171 lappend ::nettool::blocks 12173 12299 lappend ::nettool::blocks 12301 12301 lappend ::nettool::blocks 12303 12320 lappend ::nettool::blocks 12323 12344 lappend ::nettool::blocks 12346 12752 lappend ::nettool::blocks 12754 12864 lappend ::nettool::blocks 12866 13159 lappend ::nettool::blocks 13161 13215 lappend ::nettool::blocks 13219 13222 lappend ::nettool::blocks 13225 13399 lappend ::nettool::blocks 13401 13719 lappend ::nettool::blocks 13723 13723 lappend ::nettool::blocks 13725 13781 lappend ::nettool::blocks 13784 13784 lappend ::nettool::blocks 13787 13817 lappend ::nettool::blocks 13824 13893 lappend ::nettool::blocks 13895 13928 lappend ::nettool::blocks 13931 13999 lappend ::nettool::blocks 14003 14032 lappend ::nettool::blocks 14035 14140 lappend ::nettool::blocks 14143 14144 lappend ::nettool::blocks 14146 14148 lappend ::nettool::blocks 14151 14153 lappend ::nettool::blocks 14155 14249 lappend ::nettool::blocks 14251 14413 lappend ::nettool::blocks 14415 14935 lappend ::nettool::blocks 14938 14999 lappend ::nettool::blocks 15001 15001 lappend ::nettool::blocks 15003 15117 lappend ::nettool::blocks 15119 15344 lappend ::nettool::blocks 15346 15362 lappend ::nettool::blocks 15364 15554 lappend ::nettool::blocks 15556 15659 lappend ::nettool::blocks 15661 15739 lappend ::nettool::blocks 15741 15997 lappend ::nettool::blocks 16004 16019 lappend ::nettool::blocks 16022 16160 lappend ::nettool::blocks 16163 16308 lappend ::nettool::blocks 16312 16359 lappend ::nettool::blocks 16362 16366 lappend ::nettool::blocks 16369 16383 lappend ::nettool::blocks 16385 16618 lappend ::nettool::blocks 16620 16664 lappend ::nettool::blocks 16667 16899 lappend ::nettool::blocks 16901 16949 lappend ::nettool::blocks 16951 16990 lappend ::nettool::blocks 16996 17006 lappend ::nettool::blocks 17008 17183 lappend ::nettool::blocks 17186 17218 lappend ::nettool::blocks 17223 17233 lappend ::nettool::blocks 17236 17499 lappend ::nettool::blocks 17501 17554 lappend ::nettool::blocks 17556 17728 lappend ::nettool::blocks 17730 17753 lappend ::nettool::blocks 17757 17776 lappend ::nettool::blocks 17778 17999 lappend ::nettool::blocks 18001 18103 lappend ::nettool::blocks 18105 18135 lappend ::nettool::blocks 18137 18180 lappend ::nettool::blocks 18188 18240 lappend ::nettool::blocks 18244 18261 lappend ::nettool::blocks 18263 18462 lappend ::nettool::blocks 18464 18633 lappend ::nettool::blocks 18636 18768 lappend ::nettool::blocks 18770 18880 lappend ::nettool::blocks 18882 18887 lappend ::nettool::blocks 18889 18999 lappend ::nettool::blocks 19001 19006 lappend ::nettool::blocks 19008 19019 lappend ::nettool::blocks 19021 19190 lappend ::nettool::blocks 19192 19193 lappend ::nettool::blocks 19195 19282 lappend ::nettool::blocks 19284 19314 lappend ::nettool::blocks 19316 19397 lappend ::nettool::blocks 19399 19409 lappend ::nettool::blocks 19413 19538 lappend ::nettool::blocks 19542 19787 lappend ::nettool::blocks 19789 19997 lappend ::nettool::blocks 20004 20004 lappend ::nettool::blocks 20006 20011 lappend ::nettool::blocks 20015 20045 lappend ::nettool::blocks 20047 20047 lappend ::nettool::blocks 20050 20166 lappend ::nettool::blocks 20168 20201 lappend ::nettool::blocks 20203 20221 lappend ::nettool::blocks 20223 20479 lappend ::nettool::blocks 20481 20669 lappend ::nettool::blocks 20671 20998 lappend ::nettool::blocks 21001 21009 lappend ::nettool::blocks 21011 21552 lappend ::nettool::blocks 21555 21589 lappend ::nettool::blocks 21591 21799 lappend ::nettool::blocks 21801 21844 lappend ::nettool::blocks 21850 21999 lappend ::nettool::blocks 22006 22124 lappend ::nettool::blocks 22126 22127 lappend ::nettool::blocks 22129 22221 lappend ::nettool::blocks 22223 22272 lappend ::nettool::blocks 22274 22304 lappend ::nettool::blocks 22306 22342 lappend ::nettool::blocks 22344 22346 lappend ::nettool::blocks 22348 22349 lappend ::nettool::blocks 22352 22536 lappend ::nettool::blocks 22538 22554 lappend ::nettool::blocks 22556 22762 lappend ::nettool::blocks 22764 22799 lappend ::nettool::blocks 22801 22950 lappend ::nettool::blocks 22952 22999 lappend ::nettool::blocks 23006 23052 lappend ::nettool::blocks 23054 23271 lappend ::nettool::blocks 23273 23332 lappend ::nettool::blocks 23334 23399 lappend ::nettool::blocks 23403 23455 lappend ::nettool::blocks 23458 23545 lappend ::nettool::blocks 23547 23999 lappend ::nettool::blocks 24007 24241 lappend ::nettool::blocks 24243 24248 lappend ::nettool::blocks 24250 24320 lappend ::nettool::blocks 24323 24464 lappend ::nettool::blocks 24466 24553 lappend ::nettool::blocks 24555 24576 lappend ::nettool::blocks 24578 24675 lappend ::nettool::blocks 24679 24679 lappend ::nettool::blocks 24681 24753 lappend ::nettool::blocks 24755 24849 lappend ::nettool::blocks 24851 24921 lappend ::nettool::blocks 24923 24999 lappend ::nettool::blocks 25010 25470 lappend ::nettool::blocks 25472 25575 lappend ::nettool::blocks 25577 25603 lappend ::nettool::blocks 25605 25792 lappend ::nettool::blocks 25794 25899 lappend ::nettool::blocks 25904 25953 lappend ::nettool::blocks 25956 25999 lappend ::nettool::blocks 26001 26132 lappend ::nettool::blocks 26134 26207 lappend ::nettool::blocks 26209 26259 lappend ::nettool::blocks 26264 26485 lappend ::nettool::blocks 26488 26488 lappend ::nettool::blocks 26490 26999 lappend ::nettool::blocks 27010 27344 lappend ::nettool::blocks 27346 27441 lappend ::nettool::blocks 27443 27503 lappend ::nettool::blocks 27505 27781 lappend ::nettool::blocks 27783 27875 lappend ::nettool::blocks 27877 27998 lappend ::nettool::blocks 28002 28118 lappend ::nettool::blocks 28120 28199 lappend ::nettool::blocks 28201 28239 lappend ::nettool::blocks 28241 29117 lappend ::nettool::blocks 29119 29166 lappend ::nettool::blocks 29170 29998 lappend ::nettool::blocks 30005 30259 lappend ::nettool::blocks 30261 30831 lappend ::nettool::blocks 30833 30998 lappend ::nettool::blocks 31000 31019 lappend ::nettool::blocks 31021 31028 lappend ::nettool::blocks 31030 31399 lappend ::nettool::blocks 31401 31415 lappend ::nettool::blocks 31417 31456 lappend ::nettool::blocks 31458 31619 lappend ::nettool::blocks 31621 31684 lappend ::nettool::blocks 31686 31764 lappend ::nettool::blocks 31766 32033 lappend ::nettool::blocks 32035 32248 lappend ::nettool::blocks 32250 32482 lappend ::nettool::blocks 32484 32634 lappend ::nettool::blocks 32637 32766 lappend ::nettool::blocks 32778 32800 lappend ::nettool::blocks 32802 32810 lappend ::nettool::blocks 32812 32895 lappend ::nettool::blocks 32897 33122 lappend ::nettool::blocks 33124 33330 lappend ::nettool::blocks 33332 33332 lappend ::nettool::blocks 33335 33433 lappend ::nettool::blocks 33435 33655 lappend ::nettool::blocks 33657 34248 lappend ::nettool::blocks 34250 34377 lappend ::nettool::blocks 34380 34566 lappend ::nettool::blocks 34568 34961 lappend ::nettool::blocks 34965 34979 lappend ::nettool::blocks 34981 34999 lappend ::nettool::blocks 35007 35353 lappend ::nettool::blocks 35358 36000 lappend ::nettool::blocks 36002 36411 lappend ::nettool::blocks 36413 36421 lappend ::nettool::blocks 36423 36442 lappend ::nettool::blocks 36445 36523 lappend ::nettool::blocks 36525 36601 lappend ::nettool::blocks 36603 36699 lappend ::nettool::blocks 36701 36864 lappend ::nettool::blocks 36866 37474 lappend ::nettool::blocks 37476 37482 lappend ::nettool::blocks 37484 37653 lappend ::nettool::blocks 37655 37999 lappend ::nettool::blocks 38002 38200 lappend ::nettool::blocks 38204 38799 lappend ::nettool::blocks 38801 38864 lappend ::nettool::blocks 38866 39680 lappend ::nettool::blocks 39682 39999 lappend ::nettool::blocks 40001 40403 lappend ::nettool::blocks 40405 40840 lappend ::nettool::blocks 40844 40852 lappend ::nettool::blocks 40854 41110 lappend ::nettool::blocks 41112 41120 lappend ::nettool::blocks 41122 41793 lappend ::nettool::blocks 41798 42507 lappend ::nettool::blocks 42511 42999 lappend ::nettool::blocks 43001 44320 lappend ::nettool::blocks 44323 44443 lappend ::nettool::blocks 44445 44543 lappend ::nettool::blocks 44545 44552 lappend ::nettool::blocks 44554 44599 lappend ::nettool::blocks 44601 44899 lappend ::nettool::blocks 44901 44999 lappend ::nettool::blocks 45002 45044 lappend ::nettool::blocks 45046 45053 lappend ::nettool::blocks 45055 45677 lappend ::nettool::blocks 45679 45823 lappend ::nettool::blocks 45826 45965 lappend ::nettool::blocks 45967 46997 lappend ::nettool::blocks 47002 47099 lappend ::nettool::blocks 47101 47556 lappend ::nettool::blocks 47558 47623 lappend ::nettool::blocks 47625 47805 lappend ::nettool::blocks 47807 47807 lappend ::nettool::blocks 47810 47999 lappend ::nettool::blocks 48006 48048 lappend ::nettool::blocks 48051 48127 lappend ::nettool::blocks 48130 48555 lappend ::nettool::blocks 48557 48618 lappend ::nettool::blocks 48620 48652 lappend ::nettool::blocks 48654 48999 lappend ::nettool::blocks 49001 65535 |
Changes to modules/practcl/build/build.tcl.
1 2 3 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] | > > > | | > | | | | | | | | | | | | | | > < > > | < | > | 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 | set srcdir [file dirname [file normalize [file join [pwd] [info script]]]] set moddir [file dirname $srcdir] source [file join $srcdir doctool.tcl] ::practcl::doctool create AutoDoc set version 0.16.3 set tclversion 8.6 set module [file tail $moddir] set filename $module set fout [open [file join $moddir $filename.tcl] w] fconfigure $fout -translation lf dict set modmap %module% $module dict set modmap %version% $version dict set modmap %tclversion% $tclversion #dict set modmap { } {} #dict set modmap "\t" { } puts $fout [string map $modmap {### # Amalgamated package for %module% # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl %tclversion% package provide %module% %version% namespace eval ::%module% {} }] # Track what files we have included so far set loaded {} # These files must be loaded in a particular order ### # Load other module code that this module will need ### foreach {omod files} { httpwget wget.tcl clay {clay.tcl} } { foreach fname $files { set file [file join $moddir .. $omod $fname] puts $fout "###\n# START: [file join $omod $fname]\n###" set content [::practcl::cat [file join $moddir .. $omod $fname]] #AutoDoc scan_text $content puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file join $omod $fname]\n###" } } foreach {file} { setup.tcl doctool.tcl buildutil.tcl fileutil.tcl installutil.tcl makeutil.tcl {class metaclass.tcl} {class toolset baseclass.tcl} |
︙ | ︙ | |||
74 75 76 77 78 79 80 | {class subproject binary.tcl} {class subproject core.tcl} {class tool.tcl} } { lappend loaded $file | < > > | < < | | | | > > > > > > > > | 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 | {class subproject binary.tcl} {class subproject core.tcl} {class tool.tcl} } { lappend loaded $file puts $fout "###\n# START: [file join $file]\n###" set content [::practcl::cat [file join $srcdir {*}$file]] AutoDoc scan_text $content puts $fout [::practcl::docstrip $content] puts $fout "###\n# END: [file join $file]\n###" } # Provide some cleanup and our final package provide puts $fout [string map $modmap { namespace eval ::%module% { namespace export * } }] close $fout ### # Build our pkgIndex.tcl file ### set fout [open [file join $moddir pkgIndex.tcl] w] fconfigure $fout -translation lf puts $fout [string map $modmap {### if {![package vsatisfies [package provide Tcl] %tclversion%]} {return} package ifneeded %module% %version% [list source [file join $dir %module%.tcl]] }] close $fout set manout [open [file join $moddir $filename.man] w] puts $manout [AutoDoc manpage map $modmap \ header [::practcl::cat [file join $srcdir manual.txt]] \ footer [::practcl::cat [file join $srcdir footer.txt]] \ ] close $manout |
Changes to modules/practcl/build/buildutil.tcl.
1 2 3 4 5 6 7 8 9 10 11 | ### # Build utility functions ### ### # A command to do nothing. A handy way of # negating an instruction without # having to comment it completely out. # It's also a handy attachment point for # an object to be named later ### | > > > > > > > > < | < | 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 | ### # Build utility functions ### ### # Generate a proc if no command already exists by that name ### proc Proc {name arglist body} { if {[info command $name] ne {}} return proc $name $arglist $body } ### # A command to do nothing. A handy way of # negating an instruction without # having to comment it completely out. # It's also a handy attachment point for # an object to be named later ### Proc ::noop args {} proc ::practcl::debug args { #puts $args ::practcl::cputs ::DEBUG_INFO $args } ### |
︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 | return $result } proc ::practcl::os {} { return [${::practcl::MAIN} define get TEACUP_OS] } if {[::package vcompare $::tcl_version 8.6] < 0} { # Approximate ::zipfile::mkzip with exec calls proc ::practcl::mkzip {exename barekit vfspath} { set path [file dirname [file normalize $exename]] set zipfile [file join $path [file rootname $exename].zip] file copy -force $barekit $exename set pwd [pwd] | > > > > > > > > > > > > > > > | 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 | return $result } proc ::practcl::os {} { return [${::practcl::MAIN} define get TEACUP_OS] } ### # Build a zipfile. On tcl8.6 this invokes the native Zip implementation # on older interpreters this invokes zip via exec ### proc ::practcl::mkzip {exename barekit vfspath} { ::practcl::tcllib_require zipfile::mkzip ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath } ### # Dictionary sort a key/value list. Needed because pre tcl8.6 # does not have [emph {lsort -stride 2}] ### proc ::practcl::sort_dict list { return [::lsort -stride 2 -dictionary $list] } if {[::package vcompare $::tcl_version 8.6] < 0} { # Approximate ::zipfile::mkzip with exec calls proc ::practcl::mkzip {exename barekit vfspath} { set path [file dirname [file normalize $exename]] set zipfile [file join $path [file rootname $exename].zip] file copy -force $barekit $exename set pwd [pwd] |
︙ | ︙ | |||
123 124 125 126 127 128 129 | proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } | < < < < | < < | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } } proc ::practcl::local_os {} { # If we have already run this command, return # a cached copy of the data if {[info exists ::practcl::LOCAL_INFO]} { return $::practcl::LOCAL_INFO } |
︙ | ︙ |
Changes to modules/practcl/build/class/distro/baseclass.tcl.
1 2 3 4 5 6 | ### # Standalone class to manage code distribution # This class is intended to be mixed into another class # (Thus the lack of ancestors) ### | | | | | 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 | ### # Standalone class to manage code distribution # This class is intended to be mixed into another class # (Thus the lack of ancestors) ### ::clay::define ::practcl::distribution { method scm_info {} { return { scm None hash {} maxdate {} tags {} isodate {} } } method DistroMixIn {} { my define set scm none } method Sandbox {} { if {[my define exists sandbox]} { return [my define get sandbox] } if {[my clay delegate project] ni {::noop {}}} { set sandbox [my <project> define get sandbox] if {$sandbox ne {}} { my define set sandbox $sandbox return $sandbox } } set sandbox [file normalize [file join $::CWD ..]] |
︙ | ︙ | |||
66 67 68 69 70 71 72 | ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir return } } my ScmUnpack } } | < < | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir return } } my ScmUnpack } } oo::objdefine ::practcl::distribution { method Sandbox {object} { if {[$object define exists sandbox]} { return [$object define get sandbox] } if {[$object clay delegate project] ni {::noop {}}} { set sandbox [$object <project> define get sandbox] if {$sandbox ne {}} { $object define set sandbox $sandbox return $sandbox } } set pkg [$object define get name] |
︙ | ︙ | |||
103 104 105 106 107 108 109 | $object define set srcdir $srcdir } set classprefix ::practcl::distribution. if {[file exists $srcdir]} { foreach class [::info commands ${classprefix}*] { if {[$class claim_path $srcdir]} { | | > | | | > | | > | | | | | > > > > > | 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 | $object define set srcdir $srcdir } set classprefix ::practcl::distribution. if {[file exists $srcdir]} { foreach class [::info commands ${classprefix}*] { if {[$class claim_path $srcdir]} { $object clay mixinmap distribution $class set name [$class claim_option] $object define set scm $name return $name } } } foreach class [::info commands ${classprefix}*] { if {[$class claim_object $object]} { $object clay mixinmap distribution $class set name [$class claim_option] $object define set scm $name return $name } } if {[$object define get scm] eq {} && [$object define exists file_url]} { set class ::practcl::distribution.snapshot set name [$class claim_option] $object define set scm $name $object clay mixinmap distribution $class return $name } error "Cannot determine source distribution method" } method claim_option {} { return Unknown } method claim_object object { return false } method claim_path path { return false } } |
Changes to modules/practcl/build/class/distro/fossil.tcl.
|
| | > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ### # A file distribution based on fossil ### ::clay::define ::practcl::distribution.fossil { superclass ::practcl::distribution method scm_info {} { set info [next] dict set info scm fossil foreach {field value} [::practcl::fossil_status [my define get srcdir]] { dict set info $field $value } return $info } # Clone the source method ScmClone {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .fslckout]]} { return } if {[file exists [file join $srcdir _FOSSIL_]]} { |
︙ | ︙ | |||
108 109 110 111 112 113 114 | set tag [my ScmTag] ::practcl::fossil $srcdir update $tag } } oo::objdefine ::practcl::distribution.fossil { | < < < < < < < < < < < | > > > > > > > > > > > > > > > | 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 | set tag [my ScmTag] ::practcl::fossil $srcdir update $tag } } oo::objdefine ::practcl::distribution.fossil { # Check for markers in the metadata method claim_object obj { set path [$obj define get srcdir] if {[my claim_path $path]} { return true } if {[$obj define get fossil_url] ne {}} { return true } return false } method claim_option {} { return fossil } # Check for markers in the source root method claim_path path { if {[file exists [file join $path .fslckout]]} { return true } if {[file exists [file join $path _FOSSIL_]]} { return true } return false } } |
Changes to modules/practcl/build/class/distro/git.tcl.
|
| | | > | | 1 2 3 4 5 6 7 8 9 10 11 | ### # A file distribution based on git ### ::clay::define ::practcl::distribution.git { superclass ::practcl::distribution method ScmTag {} { if {[my define exists scm_tag]} { return [my define get scm_tag] } if {[my define exists tag]} { |
︙ | ︙ | |||
38 39 40 41 42 43 44 | } set CWD [pwd] set srcdir [my SrcDir] set tag [my ScmTag] ::practcl::doexec_in $srcdir git pull cd $CWD } | | | < < < | < < | > > > > > > > > > > > | 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 | } set CWD [pwd] set srcdir [my SrcDir] set tag [my ScmTag] ::practcl::doexec_in $srcdir git pull cd $CWD } } oo::objdefine ::practcl::distribution.git { method claim_object obj { set path [$obj define get srcdir] if {[my claim_path $path]} { return true } if {[$obj define get git_url] ne {}} { return true } return false } method claim_option {} { return git } method claim_path path { if {[file exists [file join $path .git]]} { return true } return false } } |
Changes to modules/practcl/build/class/distro/snapshot.tcl.
|
| | > > | | 1 2 3 4 5 6 7 8 9 10 11 | ### # A file distribution from zip, tarball, or other non-scm archive format ### ::clay::define ::practcl::distribution.snapshot { superclass ::practcl::distribution method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .download]]} { return 0 } |
︙ | ︙ | |||
36 37 38 39 40 41 42 43 | set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } } | > > > > | > > > > < < | < | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } } oo::objdefine ::practcl::distribution.snapshot { method claim_object object { return false } method claim_option {} { return snapshot } method claim_path path { if {[file exists [file join $path .download]]} { return true } return false } } |
Changes to modules/practcl/build/class/dynamic.tcl.
1 2 3 4 5 6 | ### # Dynamic blocks do not generate their own .c files, # instead the contribute to the amalgamation # of the main library file ### | | | | 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 | ### # Dynamic blocks do not generate their own .c files, # instead the contribute to the amalgamation # of the main library file ### ::clay::define ::practcl::dynamic { ### # Parser functions ### method cstructure {name definition {argdat {}}} { my variable cstruct dict set cstruct $name body $definition foreach {f v} $argdat { dict set cstruct $name $f $v } if {![dict exists $cstruct $name public]} { dict set cstruct $name public 1 } } method include header { my define add include $header } method include_dir args { my define add include_dir {*}$args } |
︙ | ︙ | |||
169 170 171 172 173 174 175 | dict set tcltype $name $func $fname } } ### # Module interactions ### | < < | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | dict set tcltype $name $func $fname } } ### # Module interactions ### method project-compile-products {} { set filename [my define get output_c] set result {} if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { |
︙ | ︙ | |||
203 204 205 206 207 208 209 | } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } | < | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } method implement path { my go my Collate_Source $path if {[my define get output_c] eq {}} return set filename [file join $path [my define get output_c]] ::practcl::debug [self] [my define get filename] WANTS TO GENERATE $filename my define set cfile $filename |
︙ | ︙ | |||
225 226 227 228 229 230 231 | } puts $fout " return TCL_OK\;" puts $fout "\x7D" } close $fout } | < < < | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 | } puts $fout " return TCL_OK\;" puts $fout "\x7D" } close $fout } ### # Practcl internals ### method initialize {} { set filename [my define get filename] if {$filename eq {}} { return } if {[my define get name] eq {}} { my define set name [file tail [file rootname $filename]] |
︙ | ︙ |
Changes to modules/practcl/build/class/metaclass.tcl.
|
| > > > | < | 1 2 3 4 5 6 7 8 9 10 11 | ### # The metaclass for all practcl objects ### ::clay::define ::practcl::metaclass { method _MorphPatterns {} { return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}} } method define {submethod args} { my variable define |
︙ | ︙ | |||
64 65 66 67 68 69 70 | } default { array $submethod define {*}$args } } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | } default { array $submethod define {*}$args } } } method graft args { return [my clay delegate {*}$args] } method initialize {} {} method link {command args} { my variable links |
︙ | ︙ | |||
230 231 232 233 234 235 236 | } { if {[string match $pattern $class]} { set mixinslot $slot break } } if {$mixinslot ne {}} { | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | } { if {[string match $pattern $class]} { set mixinslot $slot break } } if {$mixinslot ne {}} { my clay mixinmap $mixinslot $class } elseif {[info command $class] ne {}} { if {[info object class [self]] ne $class} { ::oo::objdefine [self] class $class ::practcl::debug [self] morph $class my define set class $class } } else { error "[self] Could not detect class for $classname" } } if {[::info exists define(oodefine)]} { ::oo::objdefine [self] $define(oodefine) #unset define(oodefine) } } method script script { eval $script } method select {} { my variable define if {[info exists define(class)]} { |
︙ | ︙ |
Changes to modules/practcl/build/class/module.tcl.
1 2 3 4 5 6 | ### # In the end, all C code must be loaded into a module # This will either be a dynamically loaded library implementing # a tcl extension, or a compiled in segment of a custom shell/app ### | | > > | | < | < < < | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > | | | | | | > > | | | | | > > | | | | | | | > > | | | | | | | | > | > | | | | | | < < | < < | | | | | | | | | | | | | | | | | | > > > > | | | | | | > | | > > > | | | | | | | | < < > | 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 | ### # In the end, all C code must be loaded into a module # This will either be a dynamically loaded library implementing # a tcl extension, or a compiled in segment of a custom shell/app ### ::clay::define ::practcl::module { superclass ::practcl::object ::practcl::product.dynamic Dict make_object {} method _MorphPatterns {} { return {{@name@} {::practcl::module.@name@} ::practcl::module} } method add args { my variable links set object [::practcl::object new [self] {*}$args] foreach linktype [$object linktype] { lappend links($linktype) $object } return $object } method install-headers args {} Ensemble make::_preamble {} { my variable make_object if {![info exists make_object]} { set make_object {} } } Ensemble make::pkginfo {} { ### # Build local variables needed for install ### package require platform set result {} set dat [my define dump] set PKG_DIR [dict get $dat name][dict get $dat version] dict set result PKG_DIR $PKG_DIR dict with dat {} if {![info exists DESTDIR]} { set DESTDIR {} } dict set result profile [::platform::identify] dict set result os $::tcl_platform(os) dict set result platform $::tcl_platform(platform) foreach {field value} $dat { switch $field { includedir - mandir - datadir - libdir - libfile - name - output_tcl - version - authors - license - requires { dict set result $field $value } TEA_PLATFORM { dict set result platform $value } TEACUP_OS { dict set result os $value } TEACUP_PROFILE { dict set result profile $value } TEACUP_ZIPFILE { dict set result zipfile $value } } } if {![dict exists $result zipfile]} { dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip" } return $result } # Return a dictionary of all handles and associated objects Ensemble make::objects {} { return $make_object } # Return the object associated with handle [emph name] Ensemble make::object name { if {[dict exists $make_object $name]} { return [dict get $make_object $name] } return {} } # Reset all deputy objects Ensemble make::reset {} { foreach {name obj} $make_object { $obj reset } } # Exercise the triggers method for all handles listed Ensemble make::trigger args { foreach {name obj} $make_object { if {$name in $args} { $obj triggers } } } # Exercise the check method for all handles listed Ensemble make::depends args { foreach {name obj} $make_object { if {$name in $args} { $obj check } } } # Return the file name of the build product for the listed # handle Ensemble make::filename name { if {[dict exists $make_object $name]} { return [[dict get $make_object $name] define get filename] } } Ensemble make::target {name Info body} { set info [uplevel #0 [list subst $Info]] set nspace [namespace current] if {[dict exist $make_object $name]} { set obj [dict get $$make_object $name] } else { set obj [::practcl::make_obj new [self] $name $info $body] dict set make_object $name $obj dict set target_make $name 0 dict set target_trigger $name 0 } if {[dict exists $info aliases]} { foreach item [dict get $info aliases] { if {![dict exists $make_object $item]} { dict set make_object $item $obj } } } return $obj } clay set method_ensemble make target aliases {task add} # Return a list of handles for object which return true for the # do method Ensemble make::todo {} { foreach {name obj} $make_object { if {[$obj do]} { lappend result $name } } return $result } # For each target exercise the action specified in the [emph action] # definition if the [emph do] method returns true Ensemble make::do {} { global CWD SRCDIR project SANDBOX foreach {name obj} $make_object { if {[$obj do]} { eval [$obj define get action] } } } method child which { switch $which { delegate - organs { return [list project [my define get project] module [self]] } } } ### |
︙ | ︙ | |||
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | ### # This methods generates the contents of an amalgamated .h file # which describes the public API of this module ### method generate-h {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} set includes [my generate-hfile-public-includes] foreach inc $includes { if {[string index $inc 0] ni {< \"}} { ::practcl::cputs result "#include \"$inc\"" } else { ::practcl::cputs result "#include $inc" } } | > > > > > > > > < < < | 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 | ### # This methods generates the contents of an amalgamated .h file # which describes the public API of this module ### method generate-h {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} foreach method { generate-hfile-public-define generate-hfile-public-macro } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } set includes [my generate-hfile-public-includes] foreach inc $includes { if {[string index $inc 0] ni {< \"}} { ::practcl::cputs result "#include \"$inc\"" } else { ::practcl::cputs result "#include $inc" } } foreach method { generate-hfile-public-typedef generate-hfile-public-structure } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } |
︙ | ︙ | |||
335 336 337 338 339 340 341 | lappend errs [dict get $errdat -errorinfo] } else { lappend errs $errdat } } } if {[llength $errs]} { | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | lappend errs [dict get $errdat -errorinfo] } else { lappend errs $errdat } } } if {[llength $errs]} { set logfile [file join $::CWD practcl.log] ::practcl::log $logfile "*** ERRORS ***" foreach {item trace} $errs { ::practcl::log $logfile "###\n# ERROR\n###\n$item" ::practcl::log $logfile "###\n# TRACE\n###\n$trace" } ::practcl::log $logfile "*** DEBUG INFO ***" ::practcl::log $logfile $::DEBUG_INFO |
︙ | ︙ |
Changes to modules/practcl/build/class/object.tcl.
|
| > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ### # A generic Practcl object ### ::clay::define ::practcl::object { superclass ::practcl::metaclass constructor {parent args} { my variable links define set organs [$parent child organs] my clay delegate {*}$organs array set define $organs array set define [$parent child define] array set links {} if {[llength $args]==1 && [file exists [lindex $args 0]]} { my define set filename [lindex $args 0] ::practcl::product select [self] } elseif {[llength $args] == 1} { |
︙ | ︙ |
Changes to modules/practcl/build/class/product.tcl.
|
| | > > | < | 1 2 3 4 5 6 7 8 9 10 11 | ### # A deliverable for the build system ### ::clay::define ::practcl::product { method code {section body} { my variable code ::practcl::cputs code($section) $body } method Collate_Source CWD {} |
︙ | ︙ | |||
544 545 546 547 548 549 550 | } method target {method args} { switch $method { is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } } } | | < < > | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 | } method target {method args} { switch $method { is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } } } } oo::objdefine ::practcl::product { method select {object} { set class [$object define get class] set mixin [$object define get product] if {$class eq {} && $mixin eq {}} { set filename [$object define get filename] if {$filename ne {} && [file exists $filename]} { switch [file extension $filename] { |
︙ | ︙ | |||
584 585 586 587 588 589 590 | .a { set mixin ::practcl::product.clibrary } } } } if {$class ne {}} { | | | | | > > > | | 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 | .a { set mixin ::practcl::product.clibrary } } } } if {$class ne {}} { $object clay mixinmap core $class } if {$mixin ne {}} { $object clay mixinmap product $mixin } } } ### # A product which generated from a C header file. Which is to say, nothing. ### ::clay::define ::practcl::product.cheader { superclass ::practcl::product method project-compile-products {} {} method generate-loader-module {} {} } ### # A product which generated from a C source file. Normally an object (.o) file. ### ::clay::define ::practcl::product.csource { superclass ::practcl::product method project-compile-products {} { set result {} set filename [my define get filename] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename |
︙ | ︙ | |||
625 626 627 628 629 630 631 | foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } } | > > > > > > | > > > > > > | | 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 | foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } } ### # A product which is generated from a compiled C library. # Usually a .a or a .dylib file, but in complex cases may # actually just be a conduit for one project to integrate the # source code of another ### ::clay::define ::practcl::product.clibrary { superclass ::practcl::product method linker-products {configdict} { return [my define get filename] } } ### # A product which is generated from C code that itself is generated # by practcl or some other means. This C file may or may not produce # its own .o file, depending on whether it is eligible to become part # of an amalgamation ### ::clay::define ::practcl::product.dynamic { superclass ::practcl::dynamic ::practcl::product method initialize {} { set filename [my define get filename] if {$filename eq {}} { return } |
︙ | ︙ | |||
662 663 664 665 666 667 668 | if {[my define get output_c] ne {}} { # Turn into a module if we have an output_c file my morph ::practcl::module } } } | > > > | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 | if {[my define get output_c] ne {}} { # Turn into a module if we have an output_c file my morph ::practcl::module } } } ### # A binary product produced by critcl. Note: The implementation is not # written yet, this class does nothing. ::clay::define ::practcl::product.critcl { superclass ::practcl::dynamic ::practcl::product } |
Changes to modules/practcl/build/class/project/baseclass.tcl.
|
| | > > | | 1 2 3 4 5 6 7 8 9 10 11 | ### # A toplevel project that is a collection of other projects ### ::clay::define ::practcl::project { superclass ::practcl::module method _MorphPatterns {} { return {{@name@} {::practcl::@name@} {::practcl::project.@name@} {::practcl::project}} } constructor args { |
︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | my link add tool $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } method build-tclcore {} { set os [my define get TEACUP_OS] set tcl_config_opts [::practcl::platform::tcl_core_options $os] set tk_config_opts [::practcl::platform::tk_core_options $os] lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix] set tclobj [my tclcore] if {[my define get debug 0]} { $tclobj define set debug 1 lappend tcl_config_opts --enable-symbols=true } $tclobj define set config_opts $tcl_config_opts $tclobj go $tclobj compile set _TclSrcDir [$tclobj define get localsrcdir] my define set tclsrcdir $_TclSrcDir | > > > > | | | | | | | | | > > | 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 | my link add tool $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } ### # Compile the Tcl core. If the define [emph tk] is true, compile the # Tk core as well ### method build-tclcore {} { set os [my define get TEACUP_OS] set tcl_config_opts [::practcl::platform::tcl_core_options $os] set tk_config_opts [::practcl::platform::tk_core_options $os] lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix] set tclobj [my tclcore] if {[my define get debug 0]} { $tclobj define set debug 1 lappend tcl_config_opts --enable-symbols=true } $tclobj define set config_opts $tcl_config_opts $tclobj go $tclobj compile set _TclSrcDir [$tclobj define get localsrcdir] my define set tclsrcdir $_TclSrcDir if {[my define get tk 0]} { set tkobj [my tkcore] lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir] [$tclobj define get builddir]] if {[my define get debug 0]} { $tkobj define set debug 1 lappend tk_config_opts --enable-symbols=true } $tkobj define set config_opts $tk_config_opts $tkobj compile } } method child which { switch $which { delegate - organs { # A library can be a project, it can be a module. Any # subordinate modules will indicate their existance return [list project [self] module [self]] } } } |
︙ | ︙ | |||
144 145 146 147 148 149 150 | return $obj } ${obj} {*}$args } method tclcore {} { | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | return $obj } ${obj} {*}$args } method tclcore {} { if {[info commands [set obj [my clay delegate tclcore]]] ne {}} { return $obj } if {[info commands [set obj [my project TCLCORE]]] ne {}} { my graft tclcore $obj return $obj } if {[info commands [set obj [my project tcl]]] ne {}} { |
︙ | ︙ | |||
169 170 171 172 173 174 175 | fossil_url http://core.tcl.tk/tcl }] my graft tclcore $obj return $obj } method tkcore {} { | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | fossil_url http://core.tcl.tk/tcl }] my graft tclcore $obj return $obj } method tkcore {} { if {[set obj [my clay delegate tkcore]] ne {}} { return $obj } if {[set obj [my project tk]] ne {}} { my graft tkcore $obj return $obj } if {[set obj [my tool tk]] ne {}} { |
︙ | ︙ |
Changes to modules/practcl/build/class/project/library.tcl.
|
| | > > | | 1 2 3 4 5 6 7 8 9 10 11 | ### # A toplevel project that produces a library ### ::clay::define ::practcl::library { superclass ::practcl::project method clean {PATH} { set objext [my define get OBJEXT o] foreach {ofile info} [my project-compile-products] { if {[file exists [file join $PATH objs $ofile].${objext}]} { |
︙ | ︙ | |||
270 271 272 273 274 275 276 | set version [my define get pkg_vers [my define get version]] if {$version eq {}} { set version 0.1a } set output_tcl [my define get output_tcl] if {$output_tcl ne {}} { set script "\[list source \[file join \$dir $output_tcl\]\]" | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | set version [my define get pkg_vers [my define get version]] if {$version eq {}} { set version 0.1a } set output_tcl [my define get output_tcl] if {$output_tcl ne {}} { set script "\[list source \[file join \$dir $output_tcl\]\]" } elseif {[my define get SHARED_BUILD 0]} { set script "\[list load \[file join \$dir [my define get libfile]\] $name\]" } else { # Provide a null passthrough set script "\[list package provide $name $version\]" } set result "package ifneeded [list $name] [list $version] $script" foreach alias $args { |
︙ | ︙ |
Changes to modules/practcl/build/class/project/tclkit.tcl.
|
| | | > | | 1 2 3 4 5 6 7 8 9 10 11 | ### # A toplevel project that produces a self-contained executable ### ::clay::define ::practcl::tclkit { superclass ::practcl::library method build-tclkit_main {PROJECT PKG_OBJS} { ### # Build static package list ### set statpkglist {} |
︙ | ︙ | |||
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 | set map {} foreach var { vfsroot mainhook mainfunc vfs_main } { dict set map %${var}% [set $var] } set preinitscript { set ::odie(boot_vfs) %vfsroot% set ::SRCDIR $::odie(boot_vfs) if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { set ::tcl_library [file join %vfsroot% tcl_library] set ::auto_path {} } if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { set ::tk_library [file join %vfsroot% tk_library] } } ; # Preinitscript set zvfsboot { /* * %mainhook% -- * Performs the argument munging for the shell */ } ::practcl::cputs zvfsboot { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | set map {} foreach var { vfsroot mainhook mainfunc vfs_main } { dict set map %${var}% [set $var] } set preinitscript { set ::odie(boot_vfs) %vfsroot% set ::SRCDIR $::odie(boot_vfs) namespace eval ::starkit {} set ::starkit::topdir %vfsroot% if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { set ::tcl_library [file join %vfsroot% tcl_library] set ::auto_path {} } if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { set ::tk_library [file join %vfsroot% tk_library] } } ; # Preinitscript set main_init_script {} set thread_init_script {} append preinitscript \n {namespace eval ::starkit {}} append preinitscript \n [list set ::starkit::topdir $vfsroot] foreach {statpkg info} $statpkglist { set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] append preinitscript \n $script if {[dict get $info autoload]} { append main_init_script \n [list ::load {} $statpkg] } } append preinitscript \n { if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} { #In a wrapped exe, we don't go out to the environment set dir $::starkit::topdir source [file join $::starkit::topdir pkgIndex.tcl] }} append main_init_script \n { # Specify a user-specific startup file to invoke if the application # is run interactively. Typically the startup file is "~/.apprc" # where "app" is the name of the application. If this line is deleted # then no user-specific startup file will be run under any conditions. } append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] append preinitscript \n [list set ::starkit::thread_init $thread_init_script] append preinitscript \n {eval $::starkit::thread_init} set zvfsboot { /* * %mainhook% -- * Performs the argument munging for the shell */ } ::practcl::cputs zvfsboot { |
︙ | ︙ | |||
164 165 166 167 168 169 170 | return TCL_ERROR; } } if {![$PROJECT define get tip_430 0]} { ::practcl::cputs appinit { TclZipfs_Init(interp);} } | < < < < < < < < < < | < < < < < < | | 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 | return TCL_ERROR; } } if {![$PROJECT define get tip_430 0]} { ::practcl::cputs appinit { TclZipfs_Init(interp);} } foreach {statpkg info} $statpkglist { set initfunc {} if {[dict exists $info initfunc]} { set initfunc [dict get $info initfunc] } if {$initfunc eq {}} { set initfunc [string totitle ${statpkg}]_Init } if {![dict exists $info version]} { error "$statpkg HAS NO VERSION" } # We employ a NULL to prevent the package system from thinking the # package is actually loaded into the interpreter $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" if {[dict get $info autoload]} { ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" } else { ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" } } practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" practcl::cputs appinit { return TCL_OK;} $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] } method Collate_Source CWD { next $CWD set name [my define get name] # Assume a static shell if {[my define exists SHARED_BUILD]} { my define set SHARED_BUILD 0 } if {![my define exists TCL_LOCAL_APPINIT]} { my define set TCL_LOCAL_APPINIT Tclkit_AppInit } if {![my define exists TCL_LOCAL_MAIN_HOOK]} { my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook } set PROJECT [self] set os [$PROJECT define get TEACUP_OS] if {[my define get SHARED_BUILD 0]} { puts [list BUILDING TCLSH FOR OS $os] } else { puts [list BUILDING KIT FOR OS $os] } set TCLOBJ [$PROJECT tclcore] ::practcl::toolset select $TCLOBJ |
︙ | ︙ | |||
245 246 247 248 249 250 251 | if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK if {$os eq "windows"} { set PLATFORM_SRC_DIR win | | | | 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 | if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK if {$os eq "windows"} { set PLATFORM_SRC_DIR win if {![my define get SHARED_BUILD 0]} { my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1 my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1 } my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] } else { set PLATFORM_SRC_DIR unix my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] } if {![my define get SHARED_BUILD 0]} { ### # Add local static Zlib implementation ### set cdir [file join $TCLSRCDIR compat zlib] foreach file { adler32.c compress.c crc32.c deflate.c infback.c inffast.c |
︙ | ︙ | |||
285 286 287 288 289 290 291 | if {[file exists $zipfs]} { $TCLOBJ define set tip_430 1 my define set tip_430 1 } else { # The Tclconfig project maintains a mirror of the version # released with the Tcl core my define set tip_430 0 | > > | | > > > | | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | if {[file exists $zipfs]} { $TCLOBJ define set tip_430 1 my define set tip_430 1 } else { # The Tclconfig project maintains a mirror of the version # released with the Tcl core my define set tip_430 0 set tclzipfs_c [my define get tclzipfs_c] if {![file exists $tclzipfs_c]} { ::practcl::LOCAL tool tclconfig unpack set COMPATSRCROOT [::practcl::LOCAL tool tclconfig define get srcdir] set tclzipfs_c [file join $COMPATSRCROOT compat tclZipfs.c] } my add class csource ofile tclZipfs.o filename $tclzipfs_c \ extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]] } my define add include_dir [file join $TCLSRCDIR generic] my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK my build-tclkit_main $PROJECT $PKG_OBJS } |
︙ | ︙ | |||
318 319 320 321 322 323 324 | #if {[my define get installdir] ne {}} { # ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] #} foreach arg $args { ::practcl::copyDir $arg $vfspath } | | > | | | | | 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 | #if {[my define get installdir] ne {}} { # ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] #} foreach arg $args { ::practcl::copyDir $arg $vfspath } set fout [open [file join $vfspath pkgIndex.tcl] w] puts $fout [string map [list %platform% [my define get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}] puts $fout { namespace eval ::starkit {} set ::PKGIDXFILE [info script] set dir [file dirname $::PKGIDXFILE] if {$::tcl_platform(platform) eq "windows"} { set ::starkit::localHome [file join [file normalize $::env(LOCALAPPDATA)] tcl] } else { set ::starkit::localHome [file normalize ~/tcl] } set ::tcl_teapot [file join $::starkit::localHome teapot $::tcl_teapot_profile] lappend ::auto_path $::tcl_teapot } puts $fout [list proc installDir [info args ::practcl::installDir] [info body ::practcl::installDir]] set buffer [::practcl::pkgindex_path $vfspath] puts $fout $buffer puts $fout { # Advertise statically linked packages foreach {pkg script} [array get ::starkit::static_packages] { eval $script } } puts $fout { ### # Cache binary packages distributed as dynamic libraries in a known location ### |
︙ | ︙ |
Changes to modules/practcl/build/class/subproject/baseclass.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 | ### # A subordinate project ### ::clay::define ::practcl::subproject { superclass ::practcl::module method _MorphPatterns {} { return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}} } method BuildDir {PWD} { return [my define get srcdir] } method child which { switch $which { delegate - organs { # A library can be a project, it can be a module. Any # subordinate modules will indicate their existance return [list project [self] module [self]] } } } |
︙ | ︙ | |||
129 130 131 132 133 134 135 | ### ### # A project which the kit compiles and integrates # the source for itself ### | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | ### ### # A project which the kit compiles and integrates # the source for itself ### ::clay::define ::practcl::subproject.source { superclass ::practcl::subproject ::practcl::library method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } |
︙ | ︙ | |||
151 152 153 154 155 156 157 | method linktype {} { return {subordinate package source} } } # a copy from the teapot | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | method linktype {} { return {subordinate package source} } } # a copy from the teapot ::clay::define ::practcl::subproject.teapot { superclass ::practcl::subproject method env-bootstrap {} { set pkg [my define get pkg_name [my define get name]] package require $pkg } |
︙ | ︙ | |||
186 187 188 189 190 191 192 | my unpack set prefix [string trimleft [my <project> define get prefix] /] ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] } } | | | < | | 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 | my unpack set prefix [string trimleft [my <project> define get prefix] /] ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] } } ::clay::define ::practcl::subproject.kettle { superclass ::practcl::subproject method kettle {path args} { my variable kettle if {![info exists kettle]} { ::practcl::LOCAL tool kettle env-load set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle] } set srcdir [my SourceRoot] ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args } method install DEST { my kettle reinstall --prefix $DEST } } ::clay::define ::practcl::subproject.critcl { superclass ::practcl::subproject method install DEST { my critcl -pkg [my define get name] set srcdir [my SourceRoot] ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]] } } ::clay::define ::practcl::subproject.sak { superclass ::practcl::subproject method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } |
︙ | ︙ | |||
260 261 262 263 264 265 266 | ::practcl::dotclexec [file join $srcdir installer.tcl] \ -pkg-path [file join $DEST $prefix lib $pkg] \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps } method install-module {DEST args} { | > > | | | > > > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ::practcl::dotclexec [file join $srcdir installer.tcl] \ -pkg-path [file join $DEST $prefix lib $pkg] \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps } method install-module {DEST args} { set srcdir [my define get srcdir] if {[llength $args]==1 && [lindex $args 0] in {* all}} { set pkg [my define get pkg_name [my define get name]] ::practcl::dotclexec [file join $srcdir installer.tcl] \ -pkg-path [file join $DEST $pkg] \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps } else { foreach module $args { ::practcl::installModule [file join $srcdir modules $module] [file join $DEST $module] } } } } ::clay::define ::practcl::subproject.practcl { superclass ::practcl::subproject method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } } method env-install {} { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $prefix lib $pkg] } method install DEST { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [string trimleft [my <project> define get prefix] /] set srcdir [my define get srcdir] puts [list INSTALLING [my define get name] to [file join $DEST $prefix lib $pkg]] ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $DEST $prefix lib $pkg] } method install-module {DEST args} { set pkg [my define get pkg_name [my define get name]] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir make.tcl] install-module $DEST {*}$args } } |
Changes to modules/practcl/build/class/subproject/binary.tcl.
|
| < | | | 1 2 3 4 5 6 7 8 9 10 11 | ### # A subordinate binary package ### ::clay::define ::practcl::subproject.binary { superclass ::practcl::subproject method clean {} { set builddir [file normalize [my define get builddir]] if {![file exists $builddir]} return if {[file exists [file join $builddir make.tcl]]} { ::practcl::domake.tcl $builddir clean |
︙ | ︙ | |||
26 27 28 29 30 31 32 | set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options my go my clean my compile | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options my go my clean my compile my make install {} } method project-compile-products {} {} method ComputeInstall {} { if {[my define exists install]} { switch [my define get install] { |
︙ | ︙ | |||
142 143 144 145 146 147 148 | ### set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } | | | | 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 | ### set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } my make compile cd $PWD } method Configure {} { cd $::CWD my unpack ::practcl::toolset select [self] set srcdir [file normalize [my define get srcdir]] set builddir [file normalize [my define get builddir]] file mkdir $builddir my make autodetect } method install DEST { set PWD [pwd] set PREFIX [my <project> define get prefix] ### # Handle teapot installs |
︙ | ︙ | |||
176 177 178 179 180 181 182 | set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] ::practcl::copyDir $teapath $dest return } } } my compile | | > > > | > > > | > | > | | 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 | set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] ::practcl::copyDir $teapath $dest return } } } my compile my make install $DEST cd $PWD } } ### # A subordinate TEA based binary package ### ::clay::define ::practcl::subproject.tea { superclass ::practcl::subproject.binary } ### # A subordinate C library built by this project ### ::clay::define ::practcl::subproject.library { superclass ::practcl::subproject.binary ::practcl::library method install DEST { my compile } } ### # A subordinate external C library ### ::clay::define ::practcl::subproject.external { superclass ::practcl::subproject.binary method install DEST { my compile } } |
Changes to modules/practcl/build/class/subproject/core.tcl.
1 |
| | | 1 2 3 4 5 6 7 8 9 | ::clay::define ::practcl::subproject.core { superclass ::practcl::subproject.binary method env-bootstrap {} {} method env-present {} { set PREFIX [my <project> define get prefix] set name [my define get name] |
︙ | ︙ | |||
17 18 19 20 21 22 23 | set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options puts [list [self] OS [dict get $os TEACUP_OS] options $options] my go my compile | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options puts [list [self] OS [dict get $os TEACUP_OS] options $options] my go my compile my make install {} } method go {} { my define set core_binary 1 next } method linktype {} { return {subordinate core.library} } } |
Changes to modules/practcl/build/class/target.tcl.
|
| | > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 | ### # A build deliverable object. Normally an object file, header, or tcl script # which must be compiled or generated in some way ### ::clay::define ::practcl::make_obj { superclass ::practcl::metaclass constructor {module_object name info {action_body {}}} { my variable define triggered domake set triggered 0 set domake 0 set define(name) $name |
︙ | ︙ | |||
50 51 52 53 54 55 56 | if {$filename ne {} && ![file exists $filename]} { set needs_make 1 } } } return $needs_make } | | | | 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 | if {$filename ne {} && ![file exists $filename]} { set needs_make 1 } } } return $needs_make } method output {} { set result {} set filename [my define get filename] if {$filename ne {}} { lappend result $filename } foreach filename [my define get files] { if {$filename ne {}} { lappend result $filename } } return $result } method reset {} { my variable triggered domake needs_make set triggerd 0 set domake 0 set needs_make 0 } method triggers {} { my variable triggered domake define if {$triggered} { return $domake } set triggered 1 set make_objects [my <module> make objects] |
︙ | ︙ |
Changes to modules/practcl/build/class/toolset/baseclass.tcl.
1 2 3 4 5 | ### # Ancestor-less class intended to be a mixin # which defines a family of build related behaviors # that are modified when targetting either gcc or msvc ### | | | > | > > | > > > > > > > | 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 | ### # Ancestor-less class intended to be a mixin # which defines a family of build related behaviors # that are modified when targetting either gcc or msvc ### ::clay::define ::practcl::toolset { ### # find or fake a key/value list describing this project ### method config.sh {} { return [my read_configuration] } # Compute the location where the product will be built method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } # Return where the Makefile is located relative to [emph srcdir]. # For this implementation the MakeDir is always srcdir. method MakeDir {srcdir} { return $srcdir } # Read information about the build process for this package. # For this implementation, data is sought in the following locations # in the following order: # config.tcl (generated by practcl.) PKGConfig.sh. The Makefile # [para] # If the Makefile needs to be consulted, but does not exist, the # Configure method is invoked method read_configuration {} { my variable conf_result if {[info exists conf_result]} { return $conf_result } set result {} set name [my define get name] |
︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 | } set conf_result $result return $result } ### # Oh man... we have to guess ### set filename [file join $builddir Makefile] if {![file exists $filename]} { error "Could not locate any configuration data in $srcdir" } foreach {field dat} [::practcl::read_Makefile $filename] { dict set result $field $dat } | > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | } set conf_result $result return $result } ### # Oh man... we have to guess ### if {![file exists [file join $builddir Makefile]]} { my Configure } set filename [file join $builddir Makefile] if {![file exists $filename]} { error "Could not locate any configuration data in $srcdir" } foreach {field dat} [::practcl::read_Makefile $filename] { dict set result $field $dat } |
︙ | ︙ | |||
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | } } append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" return $defs } method critcl args { if {![info exists critcl]} { ::practcl::LOCAL tool critcl env-load set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl } set srcdir [my SourceRoot] set PWD [pwd] cd $srcdir ::practcl::dotclexec $critcl {*}$args cd $PWD } | > | < | < < | < | | | | 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 | } } append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" return $defs } # Invoke critcl in an external process method critcl args { if {![info exists critcl]} { ::practcl::LOCAL tool critcl env-load set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl } set srcdir [my SourceRoot] set PWD [pwd] cd $srcdir ::practcl::dotclexec $critcl {*}$args cd $PWD } } oo::objdefine ::practcl::toolset { # Perform the selection for the toolset mixin method select object { ### # Select the toolset to use for this project ### if {[$object define exists toolset]} { return [$object define get toolset] } set class [$object define get toolset] if {$class ne {}} { $object clay mixinmap toolset $class } else { if {[info exists ::env(VisualStudioVersion)]} { $object clay mixinmap toolset ::practcl::toolset.msvc } else { $object clay mixinmap toolset ::practcl::toolset.gcc } } } } |
Changes to modules/practcl/build/class/toolset/gcc.tcl.
1 |
| | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ::clay::define ::practcl::toolset.gcc { superclass ::practcl::toolset method Autoconf {} { ### # Re-run autoconf for this project # Not a good idea in practice... but in the right hands it can be useful ### set pwd [pwd] set srcdir [file normalize [my define get srcdir]] set localsrcdir [my MakeDir $srcdir] cd $localsrcdir foreach template {configure.ac configure.in} { set input [file join $srcdir $template] if {[file exists $input]} { puts "autoconf -f $input > [file join $srcdir configure]" exec autoconf -f $input > [file join $srcdir configure] } } |
︙ | ︙ | |||
51 52 53 54 55 56 57 | } } if {[my <project> define get CONFIG_SITE] != {}} { lappend opts --host=[my <project> define get HOST] } set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]] lappend opts --with-tclsh=[info nameofexecutable] | > > | | | | | | | | | < > > > > > > > > > | > > | | | 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 | } } if {[my <project> define get CONFIG_SITE] != {}} { lappend opts --host=[my <project> define get HOST] } set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]] lappend opts --with-tclsh=[info nameofexecutable] if {[my define get tk 0]} { if {![my <project> define get LOCAL 0]} { set obj [my <project> tclcore] if {$obj ne {}} { if {$inside_msys} { lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] } else { lappend opts --with-tcl=[file normalize [$obj define get builddir]] } } set obj [my <project> tkcore] if {$obj ne {}} { if {$inside_msys} { lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] } else { lappend opts --with-tk=[file normalize [$obj define get builddir]] } } } else { lappend opts --with-tcl=[file join $PREFIX lib] lappend opts --with-tk=[file join $PREFIX lib] } } else { if {![my <project> define get LOCAL 0]} { set obj [my <project> tclcore] if {$obj ne {}} { if {$inside_msys} { lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] } else { lappend opts --with-tcl=[file normalize [$obj define get builddir]] } } } else { lappend opts --with-tcl=[file join $PREFIX lib] } } lappend opts {*}[my define get config_opts] if {![regexp -- "--prefix" $opts]} { lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX } if {[my define get debug 0]} { |
︙ | ︙ | |||
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 | windows { if {[file exists [file join $srcdir win]]} { my define add include_dir [file join $srcdir win] } if {[file exists [file join $srcdir win Makefile.in]]} { set localsrcdir [file join $srcdir win] } } default { if {[file exists [file join $srcdir $os]]} { my define add include_dir [file join $srcdir $os] } if {[file exists [file join $srcdir unix]]} { my define add include_dir [file join $srcdir unix] } if {[file exists [file join $srcdir $os Makefile.in]]} { set localsrcdir [file join $srcdir $os] } elseif {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } } return $localsrcdir } | > > > > > | | > > > | 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 | windows { if {[file exists [file join $srcdir win]]} { my define add include_dir [file join $srcdir win] } if {[file exists [file join $srcdir win Makefile.in]]} { set localsrcdir [file join $srcdir win] } } macosx { if {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } default { if {[file exists [file join $srcdir $os]]} { my define add include_dir [file join $srcdir $os] } if {[file exists [file join $srcdir unix]]} { my define add include_dir [file join $srcdir unix] } if {[file exists [file join $srcdir $os Makefile.in]]} { set localsrcdir [file join $srcdir $os] } elseif {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } } return $localsrcdir } Ensemble make::autodetect {} { set srcdir [my define get srcdir] set localsrcdir [my MakeDir $srcdir] if {$localsrcdir eq {}} { set localsrcdir $srcdir } if {$srcdir eq $localsrcdir} { if {![file exists [file join $srcdir tclconfig install-sh]]} { # ensure we have tclconfig with all of the trimmings set teapath {} if {[file exists [file join $srcdir .. tclconfig install-sh]]} { set teapath [file join $srcdir .. tclconfig] } else { |
︙ | ︙ | |||
175 176 177 178 179 180 181 | if {[my <project> define get CONFIG_SITE] ne {}} { set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] } catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} cd $::CWD } | | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 | if {[my <project> define get CONFIG_SITE] ne {}} { set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] } catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} cd $::CWD } Ensemble make::clean {} { set builddir [file normalize [my define get builddir]] catch {::practcl::domake $builddir clean} } Ensemble make::compile {} { set name [my define get name] set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } |
︙ | ︙ | |||
205 206 207 208 209 210 211 | ::practcl::domake.tcl $builddir all } } else { ::practcl::domake $builddir all } } | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | ::practcl::domake.tcl $builddir all } } else { ::practcl::domake $builddir all } } Ensemble make::install DEST { set PWD [pwd] set builddir [my define get builddir] if {[my <project> define get LOCAL 0] || $DEST eq {}} { if {[file exists [file join $builddir make.tcl]]} { puts "[self] Local INSTALL (Practcl)" ::practcl::domake.tcl $builddir install } elseif {[my define get broken_destroot 0] == 0} { |
︙ | ︙ | |||
440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | method build-library {outfile PROJECT} { array set proj [$PROJECT define dump] set path $proj(builddir) cd $path set includedir . #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] if {[$PROJECT define get tk 0]} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] } foreach include [$PROJECT toolset-include-directory] { set cpath [::practcl::file_relative $path [file normalize $include]] if {$cpath ni $includedir} { lappend includedir $cpath } | > > > > > > > > > > > > > > > > | 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 | method build-library {outfile PROJECT} { array set proj [$PROJECT define dump] set path $proj(builddir) cd $path set includedir . #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] if {[$PROJECT define get TEA_PRIVATE_TCL_HEADERS 0]} { if {[$PROJECT define get TEA_PLATFORM] eq "windows"} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]] } else { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]] } } lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] if {[$PROJECT define get tk 0]} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] if {[$PROJECT define get TEA_PRIVATE_TK_HEADERS 0]} { if {[$PROJECT define get TEA_PLATFORM] eq "windows"} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]] } else { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]] } } lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] } foreach include [$PROJECT toolset-include-directory] { set cpath [::practcl::file_relative $path [file normalize $include]] if {$cpath ni $includedir} { lappend includedir $cpath } |
︙ | ︙ | |||
514 515 516 517 518 519 520 | catch {exec $ranlib $outfile} } } ### # Produce a static executable ### | | > | > > > > > > > > > > > > > > > > > > > | < | | < < < < < < < < < | 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 | catch {exec $ranlib $outfile} } } ### # Produce a static executable ### method build-tclsh {outfile PROJECT {path {auto}}} { if {[my define get tk 0] && [my define get static_tk 0]} { puts " BUILDING STATIC TCL/TK EXE $PROJECT" set TKOBJ [$PROJECT tkcore] if {[info command $TKOBJ] eq {}} { set TKOBJ ::noop $PROJECT define set static_tk 0 } else { ::practcl::toolset select $TKOBJ array set TK [$TKOBJ read_configuration] set do_tk [$TKOBJ define get static] $PROJECT define set static_tk $do_tk $PROJECT define set tk $do_tk set TKSRCDIR [$TKOBJ define get srcdir] } } else { puts " BUILDING STATIC TCL EXE $PROJECT" set TKOBJ ::noop my define set static_tk 0 } set TCLOBJ [$PROJECT tclcore] ::practcl::toolset select $TCLOBJ set PKG_OBJS {} foreach item [$PROJECT link list core.library] { if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } foreach item [$PROJECT link list package] { if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } array set TCL [$TCLOBJ read_configuration] if {$path in {{} auto}} { set path [file dirname [file normalize $outfile]] } if {$path eq "."} { set path [pwd] } cd $path ### # For a static Tcl shell, we need to build all local sources # with the same DEFS flags as the tcl core was compiled with. # The DEFS produced by a TEA extension aren't intended to operate # with the internals of a staticly linked Tcl ### |
︙ | ︙ | |||
603 604 605 606 607 608 609 | append COMPILE " " $defs lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES] set TCLSRC [file normalize $TCLSRCDIR] if {[${PROJECT} define get TEACUP_OS] eq "windows"} { set windres [$PROJECT define get RC windres] | | > > > > | > > > > > > | 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 | append COMPILE " " $defs lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES] set TCLSRC [file normalize $TCLSRCDIR] if {[${PROJECT} define get TEACUP_OS] eq "windows"} { set windres [$PROJECT define get RC windres] set RSOBJ [file join $path objs tclkit.res.o] set RCSRC [${PROJECT} define get kit_resource_file] set RCMAN [${PROJECT} define get kit_manifest_file] set RCICO [${PROJECT} define get kit_icon_file] set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]] if {[$PROJECT define get static_tk]} { if {$RCSRC eq {} || ![file exists $RCSRC]} { set RCSRC [file join $TKSRCDIR win rc wish.rc] } if {$RCMAN eq {} || ![file exists $RCMAN]} { set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest] } if {$RCICO eq {} || ![file exists $RCICO]} { set RCICO [file join $TKSRCDIR win rc wish.ico] } set TKSRC [file normalize $TKSRCDIR] lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \ --include [::practcl::file_relative $path [file join $TKSRC win]] \ --include [::practcl::file_relative $path [file join $TKSRC win rc]] } else { if {$RCSRC eq {} || ![file exists $RCSRC]} { set RCSRC [file join $TCLSRCDIR win tclsh.rc] } if {$RCMAN eq {} || ![file exists $RCMAN]} { set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest] } if {$RCICO eq {} || ![file exists $RCICO]} { set RCICO [file join $TCLSRCDIR win tclsh.ico] } } foreach item [${PROJECT} define get resource_include] { lappend cmd --include [::practcl::file_relative $path [file normalize $item]] } lappend cmd [file tail $RCSRC] if {![file exists [file join $path [file tail $RCSRC]]]} { file copy -force $RCSRC [file join $path [file tail $RCSRC]] } if {![file exists [file join $path [file tail $RCMAN]]]} { file copy -force $RCMAN [file join $path [file tail $RCMAN]] } if {![file exists [file join $path [file tail $RCICO]]]} { file copy -force $RCICO [file join $path [file tail $RCICO]] } ::practcl::doexec {*}$cmd lappend OBJECTS $RSOBJ } puts "***" set cmd "$TCL(cc)" if {$debug} { append cmd " $TCL(cflags_debug)" |
︙ | ︙ |
Changes to modules/practcl/build/class/toolset/msvc.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 | ::clay::define ::practcl::toolset.msvc { superclass ::practcl::toolset # MSVC always builds in the source directory method BuildDir {PWD} { set srcdir [my define get srcdir] return $srcdir } # Do nothing Ensemble make::autodetect {} { } Ensemble make::clean {} { set PWD [pwd] set srcdir [my define get srcdir] cd $srcdir catch {::practcl::doexec nmake -f makefile.vc clean} cd $PWD } Ensemble make::compile {} { set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } cd $srcdir |
︙ | ︙ | |||
41 42 43 44 45 46 47 | cd [file join $srcdir win] ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release } else { error "No make.tcl or makefile.vc found for project $name" } } } | | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | cd [file join $srcdir win] ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release } else { error "No make.tcl or makefile.vc found for project $name" } } } Ensemble make::install DEST { set PWD [pwd] set srcdir [my define get srcdir] cd $srcdir if {$DEST eq {}} { error "No destination given" } if {[my <project> define get LOCAL 0] || $DEST eq {}} { |
︙ | ︙ | |||
70 71 72 73 74 75 76 | } else { puts "[self] VFS INSTALL $DEST" ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install } } cd $PWD } | | | | 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 | } else { puts "[self] VFS INSTALL $DEST" ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install } } cd $PWD } # Detect what directory contains the Makefile template method MakeDir {srcdir} { set localsrcdir $srcdir if {[file exists [file join $srcdir generic]]} { my define add include_dir [file join $srcdir generic] } if {[file exists [file join $srcdir win]]} { my define add include_dir [file join $srcdir win] } if {[file exists [file join $srcdir makefile.vc]]} { set localsrcdir [file join $srcdir win] } return $localsrcdir } method NmakeOpts {} { set opts {} set builddir [file normalize [my define get builddir]] if {[my <project> define exists tclsrcdir]} { ### # On Windows we are probably running under MSYS, which doesn't deal with |
︙ | ︙ |
Added modules/practcl/build/doctool.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 | namespace eval ::practcl {} ### # Concatenate a file ### proc ::practcl::cat fname { if {![file exists $fname]} { return } set fin [open $fname r] set data [read $fin] close $fin return $data } ### # Strip the global comments from tcl code. Used to # prevent the documentation markup comments from clogging # up files intended for distribution in machine readable format. ### proc ::practcl::docstrip text { set result {} foreach line [split $text \n] { append thisline $line \n if {![info complete $thisline]} continue set outline $thisline set thisline {} if {[string trim $outline] eq {}} { continue } if {[string index [string trim $outline] 0] eq "#"} continue set cmd [string trim [lindex $outline 0] :] if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } if {[string match "*::define" $cmd] && [llength $outline]==3} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } append result $outline } return $result } ### # Append a line of text to a variable. Optionally apply a string mapping. # argspec: # map {mandatory 0 positional 1} # text {mandatory 1 positional 1} ### proc ::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { append buffer [lindex $args 0] \n } 2 { append buffer [string map {*}$args] \n } default { error "usage: putb buffername ?map? string" } } } ### # Tool for build scripts to dynamically generate manual files from comments # in source code files # example: # set authors { # {John Doe} {[email protected]} # {Tom RichardHarry} {[email protected]} # } # # Create the object # ::practcl::doctool create AutoDoc # set fout [open [file join $moddir module.tcl] w] # foreach file [glob [file join $srcdir *.tcl]] { # set content [::practcl::cat [file join $srcdir $file]] # # Scan the file # AutoDoc scan_text $content # # Strip the comments from the distribution # puts $fout [::practcl::docstrip $content] # } # # Write out the manual page # set manout [open [file join $moddir module.man] w] # dict set args header [string map $modmap [::practcl::cat [file join $srcdir manual.txt]]] # dict set args footer [string map $modmap [::practcl::cat [file join $srcdir footer.txt]]] # dict set args authors $authors # puts $manout [AutoDoc manpage {*}$args] # close $manout ### ::oo::class create ::practcl::doctool { constructor {} { my reset } ### # Process an argument list into an informational dict. # This method also understands non-positional # arguments expressed in the notation of Tip 471 # [uri https://core.tcl-lang.org/tips/doc/trunk/tip/479.md]. # [para] # The output will be a dictionary of all of the fields and whether the fields # are [const positional], [const mandatory], and whether they have a # [const default] value. # [para] # example: # my argspec {a b {c 10}} # # > a {positional 1 mandatory 1} b {positional 1 mandatory 1} c {positional 1 mandatory 0 default 10} ### method argspec {argspec} { set result [dict create] foreach arg $argspec { set name [lindex $arg 0] dict set result $name positional 1 dict set result $name mandatory 1 if {$name in {args dictargs}} { switch [llength $arg] { 1 { dict set result $name mandatory 0 } 2 { dict for {optname optinfo} [lindex $arg 1] { set optname [string trim $optname -:] dict set result $optname {positional 1 mandatory 0} dict for {f v} $optinfo { dict set result $optname [string trim $f -:] $v } } } default { error "Bad argument" } } } else { switch [llength $arg] { 1 { dict set result $name mandatory 1 } 2 { dict set result $name mandatory 0 dict set result $name default [lindex $arg 1] } default { error "Bad argument" } } } } return $result } ### # Convert a block of comments into an informational dictionary. # If lines in the comment start with a single word ending in a colon, # all subsequent lines are appended to a dictionary field of that name. # If no fields are given, all of the text is appended to the [const description] # field. # example: # my comment {Does something cool} # > description {Does something cool} # # my comment { # title : Something really cool # author : Sean Woods # author : John Doe # description : # This does something really cool! # } # > description {This does something really cool!} # title {Something really cool} # author {Sean Woods # John Doe} ### method comment block { set count 0 set field description set result [dict create description {}] foreach line [split $block \n] { set sline [string trim $line] set fwidx [string first " " $sline] if {$fwidx < 0} { set firstword [string range $sline 0 end] set restline {} } else { set firstword [string range $sline 0 [expr {$fwidx-1}]] set restline [string range $sline [expr {$fwidx+1}] end] } if {[string index $firstword end] eq ":"} { set field [string tolower [string trim $firstword -:]] switch $field { dictargs - arglist { set field argspec } desc { set field description } } if {[string length $restline]} { dict append result $field "$restline\n" } } else { dict append result $field "$line\n" } } return $result } method keyword.Annotation {resultvar commentblock type name body} { upvar 1 $resultvar result set name [string trim $name :] if {[dict exists $result $type $name]} { set info [dict get $result $type $name] } else { set info [my comment $commentblock] } foreach {f v} $body { dict set info $f $v } dict set result $type $name $info } ### # Process an oo::objdefine call that modifies the class object # itself #### method keyword.Class {resultvar commentblock name body} { upvar 1 $resultvar result set name [string trim $name :] if {[dict exists $result class $name]} { set info [dict get $result class $name] } else { set info [my comment $commentblock] } set commentblock {} foreach line [split $body \n] { append thisline $line \n if {![info complete $thisline]} continue set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} { append commentblock [string trimleft $thisline #] \n set thisline {} continue } set cmd [string trim [lindex $thisline 0] ":"] switch $cmd { Option - option { my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } variable - Variable { my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list type scaler default [lindex $thisline 2]] set commentblock {} } Dict - Array { set iinfo [lindex $thisline 2] dict set iinfo type [string tolower $cmd] my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo set commentblock {} } Componant - Delegate { my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } method - Ensemble { my keyword.Class_Method info $commentblock {*}[lrange $thisline 1 end-1] set commentblock {} } } set thisline {} } dict set result class $name $info } ### # Process an oo::define, clay::define, etc statement. ### method keyword.class {resultvar commentblock name body} { upvar 1 $resultvar result set name [string trim $name :] if {[dict exists $result class $name]} { set info [dict get $result class $name] } else { set info [my comment $commentblock] } set commentblock {} foreach line [split $body \n] { append thisline $line \n if {![info complete $thisline]} continue set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} { append commentblock [string trimleft $thisline #] \n set thisline {} continue } set cmd [string trim [lindex $thisline 0] ":"] switch $cmd { Option - option { puts [list keyword.Annotation $cmd $thisline] my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } variable - Variable { my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list default [lindex $thisline 2]] set commentblock {} } Dict - Array { set iinfo [lindex $thisline 2] dict set iinfo type [string tolower $cmd] my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo set commentblock {} } Componant - Delegate { my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } superclass { dict set info ancestors [lrange $thisline 1 end] set commentblock {} } classmethod - class_method - Class_Method { my keyword.Class_Method info $commentblock {*}[lrange $thisline 1 end-1] set commentblock {} } destructor - constructor { my keyword.method info $commentblock {*}[lrange $thisline 0 end-1] set commentblock {} } method - Ensemble { my keyword.method info $commentblock {*}[lrange $thisline 1 end-1] set commentblock {} } } set thisline {} } dict set result class $name $info } ### # Process a statement for a clay style class method ### method keyword.Class_Method {resultvar commentblock name args} { upvar 1 $resultvar result set info [my comment $commentblock] if {[dict exists $info show_body] && [dict get $info show_body]} { dict set info internals [lindex $args end] } if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result Class_Method "${name} $method" $minfo } } else { switch [llength $args] { 1 { set argspec [lindex $args 0] } 0 { set argspec dictargs #set body [lindex $args 0] } default {error "could not interpret method $name {*}$args"} } if {![dict exists $info argspec]} { dict set info argspec [my argspec $argspec] } dict set result Class_Method [string trim $name :] $info } } ### # Process a statement for a tcloo style object method ### method keyword.method {resultvar commentblock name args} { upvar 1 $resultvar result set info [my comment $commentblock] if {[dict exists $info show_body] && [dict get $info show_body]} { dict set info internals [lindex $args end] } if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result method "\"${name} $method\"" $minfo } } else { switch [llength $args] { 1 { set argspec [lindex $args 0] } 0 { set argspec dictargs #set body [lindex $args 0] } default {error "could not interpret method $name {*}$args"} } if {![dict exists $info argspec]} { dict set info argspec [my argspec $argspec] } dict set result method "\"[split [string trim $name :] ::]\"" $info } } ### # Process a proc statement ### method keyword.proc {commentblock name argspec} { set info [my comment $commentblock] if {![dict exists $info argspec]} { dict set info argspec [my argspec $argspec] } return $info } ### # Reset the state of the object and its embedded coroutine ### method reset {} { my variable coro set coro [info object namespace [self]]::coro oo::objdefine [self] forward coro $coro if {[info command $coro] ne {}} { rename $coro {} } coroutine $coro {*}[namespace code {my Main}] } ### # Main body of the embedded coroutine for the object ### method Main {} { my variable info set info [dict create] yield [info coroutine] set thisline {} set commentblock {} set linec 0 while 1 { set line [yield] append thisline $line \n if {![info complete $thisline]} continue set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} { append commentblock [string trimleft $thisline #] \n set thisline {} continue } set cmd [string trim [lindex $thisline 0] ":"] switch $cmd { dictargs::proc { set procinfo [my keyword.proc $commentblock [lindex $thisline 1] [list args [list dictargs [lindex $thisline 2]]]] if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} { dict set procinfo internals [lindex $thisline end] } dict set info proc [string trim [lindex $thisline 1] :] $procinfo set commentblock {} } tcllib::PROC - PROC - Proc - proc { set procinfo [my keyword.proc $commentblock {*}[lrange $thisline 1 2]] if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} { dict set procinfo internals [lindex $thisline end] } dict set info proc [string trim [lindex $thisline 1] :] $procinfo set commentblock {} } oo::objdefine { if {[llength $thisline]==3} { lassign $thisline tcmd name body my keyword.Class info $commentblock $name $body } else { puts "Warning: bare oo::define in library" } } oo::define { if {[llength $thisline]==3} { lassign $thisline tcmd name body my keyword.class info $commentblock $name $body } else { puts "Warning: bare oo::define in library" } } tao::define - clay::define - tool::define { lassign $thisline tcmd name body my keyword.class info $commentblock $name $body set commentblock {} } oo::class { lassign $thisline tcmd mthd name body my keyword.class info $commentblock $name $body set commentblock {} } default { if {[lindex [split $cmd ::] end] eq "define"} { lassign $thisline tcmd name body my keyword.class info $commentblock $name $body set commentblock {} } set commentblock {} } } set thisline {} } } ### # Generate the manual page text for a method or proc ### method section.method {keyword method minfo} { set result {} set line "\[call $keyword \[cmd $method\]" if {[dict exists $minfo argspec]} { dict for {argname arginfo} [dict get $minfo argspec] { set positional 1 set mandatory 1 set repeating 0 dict with arginfo {} if {$mandatory==0} { append line " \[opt \"" } else { append line " " } if {$positional} { append line "\[arg $argname" } else { append line "\[option \"$argname" if {[dict exists $arginfo type]} { append line " \[emph [dict get $arginfo type]\]" } else { append line " \[emph value\]" } append line "\"" } append line "\]" if {$mandatory==0} { if {[dict exists $arginfo default]} { append line " \[const \"[dict get $arginfo default]\"\]" } append line "\"\]" } if {$repeating} { append line " \[opt \[option \"$argname...\"\]\]" } } } append line \] putb result $line if {[dict exists $minfo description]} { putb result [dict get $minfo description] } if {[dict exists $minfo example]} { putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]" } if {[dict exists $minfo internals]} { putb result "\[para\]Internals: \[example [list [dict get $minfo internals]]\]" } return $result } method section.annotation {type name iinfo} { set result "\[call $type \[cmd $name\]\]" if {[dict exists $iinfo description]} { putb result [dict get $iinfo description] } if {[dict exists $iinfo example]} { putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]" } return $result } ### # Generate the manual page text for a class ### method section.class {class_name class_info} { set result {} putb result "\[subsection \{Class $class_name\}\]" if {[dict exists $class_info ancestors]} { set line "\[emph \"ancestors\"\]:" foreach {c} [dict get $class_info ancestors] { append line " \[class [string trim $c :]\]" } putb result $line putb result {[para]} } dict for {f v} $class_info { if {$f in {Class_Method method description ancestors example option variable delegate}} continue putb result "\[emph \"$f\"\]: $v" putb result {[para]} } if {[dict exists $class_info example]} { putb result "\[example \{[list [dict get $class_info example]]\}\]" putb result {[para]} } if {[dict exists $class_info description]} { putb result [dict get $class_info description] putb result {[para]} } dict for {f v} $class_info { if {$f ni {option variable delegate}} continue putb result "\[class \{[string totitle $f]\}\]" #putb result "Methods on the class object itself." putb result {[list_begin definitions]} dict for {item iinfo} [dict get $class_info $f] { putb result [my section.annotation $f $item $iinfo] } putb result {[list_end]} putb result {[para]} } if {[dict exists $class_info Class_Method]} { putb result "\[class \{Class Methods\}\]" #putb result "Methods on the class object itself." putb result {[list_begin definitions]} dict for {method minfo} [dict get $class_info Class_Method] { putb result [my section.method classmethod $method $minfo] } putb result {[list_end]} putb result {[para]} } if {[dict exists $class_info method]} { putb result "\[class {Methods}\]" putb result {[list_begin definitions]} dict for {method minfo} [dict get $class_info method] { putb result [my section.method method $method $minfo] } putb result {[list_end]} putb result {[para]} } return $result } ### # Generate the manual page text for the commands section ### method section.command {procinfo} { set result {} putb result "\[section \{Commands\}\]" putb result {[list_begin definitions]} dict for {method minfo} $procinfo { putb result [my section.method proc $method $minfo] } putb result {[list_end]} return $result } ### # Generate the manual page. Returns the completed text suitable for saving in .man file. # The header argument is a block of doctools text to go in before the machine generated # section. footer is a block of doctools text to go in after the machine generated # section. authors is a list of individual authors and emails in the form of AUTHOR EMAIL ?AUTHOR EMAIL?... # # argspec: # header {mandatory 0 positional 0} # footer {mandatory 0 positional 0} # authors {mandatory 0 positional 0 type list} ### method manpage args { my variable info set map {%version% 0.0 %module% {Your_Module_Here}} set result {} set header {} set footer {} set authors {} dict with args {} dict set map %keyword% comment putb result $map {[%keyword% {-*- tcl -*- doctools manpage}] [vset PACKAGE_VERSION %version%] [manpage_begin %module% n [vset PACKAGE_VERSION]]} putb result $map $header dict for {sec_type sec_info} $info { switch $sec_type { proc { putb result [my section.command $sec_info] } class { putb result "\[section Classes\]" dict for {class_name class_info} $sec_info { putb result [my section.class $class_name $class_info] } } default { putb result "\[section [list $sec_type $sec_name]\]" if {[dict exists $sec_info description]} { putb result [dict get $sec_info description] } } } } if {[llength $authors]} { putb result {[section AUTHORS]} foreach {name email} $authors { putb result "$name \[uri mailto:$email\]\[para\]" } } putb result $footer putb result {[manpage_end]} return $result } # Scan a block of text method scan_text {text} { my variable linecount coro set linecount 0 foreach line [split $text \n] { incr linecount $coro $line } } # Scan a file of text method scan_file {filename} { my variable linecount coro set fin [open $filename r] set linecount 0 while {[gets $fin line]>=0} { incr linecount $coro $line } close $fin } } |
Changes to modules/practcl/build/fileutil.tcl.
1 2 3 | ### # Bits stolen from fileutil ### | < < < | < < < < | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ### # Bits stolen from fileutil ### ### # Search for the pattern [emph pattern] amongst $files ### proc ::practcl::grep {pattern {files {}}} { set result [list] if {[llength $files] == 0} { # read from stdin set lnum 0 while {[gets stdin line] >= 0} { incr lnum if {[regexp -- $pattern $line]} { lappend result "${lnum}:${line}" } } } else { foreach filename $files { set file [open $filename r] set lnum 0 while {[gets $file line] >= 0} { incr lnum if {[regexp -- $pattern $line]} { lappend result "${filename}:${lnum}:${line}" } } close $file } } return $result } proc ::practcl::file_lexnormalize {sp} { set spx [file split $sp] # Resolution of embedded relative modifiers (., and ..). if { ([lsearch -exact $spx . ] < 0) && ([lsearch -exact $spx ..] < 0) } { # Quick path out if there are no relative modifiers return $sp } set absolute [expr {![string equal [file pathtype $sp] relative]}] # A volumerelative path counts as absolute for our purposes. set sp $spx set np {} set noskip 1 while {[llength $sp]} { set ele [lindex $sp 0] set sp [lrange $sp 1 end] set islast [expr {[llength $sp] == 0}] if {[string equal $ele ".."]} { if { ($absolute && ([llength $np] > 1)) || (!$absolute && ([llength $np] >= 1)) } { # .. : Remove the previous element added to the # new path, if there actually is enough to remove. set np [lrange $np 0 end-1] } } elseif {[string equal $ele "."]} { # Ignore .'s, they stay at the current location continue } else { # A regular element. lappend np $ele } } if {[llength $np] > 0} { return [eval [linsert $np 0 file join]] # 8.5: return [file join {*}$np] } return {} } ### # Calculate a relative path between base and dst # # example: # ::practcl::file_relative ~/build/tcl/unix ~/build/tcl/library # > ../library ### proc ::practcl::file_relative {base dst} { # Ensure that the link to directory 'dst' is properly done relative to # the directory 'base'. if {![string equal [file pathtype $base] [file pathtype $dst]]} { return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" } set base [file_lexnormalize [file join [pwd] $base]] set dst [file_lexnormalize [file join [pwd] $dst]] set save $dst set base [file split $base] set dst [file split $dst] while {[string equal [lindex $dst 0] [lindex $base 0]]} { set dst [lrange $dst 1 end] set base [lrange $base 1 end] if {![llength $dst]} {break} } set dstlen [llength $dst] set baselen [llength $base] if {($dstlen == 0) && ($baselen == 0)} { # Cases: # (a) base == dst set dst . } else { # Cases: # (b) base is: base/sub = sub # dst is: base = {} # (c) base is: base = {} # dst is: base/sub = sub while {$baselen > 0} { set dst [linsert $dst 0 ..] incr baselen -1 } # 8.5: set dst [file join {*}$dst] set dst [eval [linsert $dst 0 file join]] } return $dst } # ::fileutil::findByPattern -- # # Specialization of find. Finds files based on their names, # which have to match the specified patterns. Options are used # to specify which type of patterns (regexp-, glob-style) is # used. # # Arguments: # basedir Directory to start searching from. # args Options (-glob, -regexp, --) followed by a # list of patterns to search for. # # Results: # files a list of interesting files. proc ::practcl::findByPattern {basedir patterns} { set queue $basedir set result {} while {[llength $queue]} { set item [lindex $queue 0] set queue [lrange $queue 1 end] if {[file isdirectory $item]} { foreach path [glob -nocomplain [file join $item *]] { lappend queue $path } continue } foreach pattern $patterns { set fname [file tail $item] if {[string match $pattern $fname]} { lappend result $item break } } } return $result } ### # Record an event in the practcl log ### proc ::practcl::log {fname comment} { set fname [file normalize $fname] if {[info exists ::practcl::logchan($fname)]} { set fout $::practcl::logchan($fname) after cancel $::practcl::logevent($fname) } else { set fout [open $fname a] |
︙ | ︙ |
Added modules/practcl/build/footer.txt.
> > | 1 2 | [vset CATEGORY practcl] [include ../doctools2base/include/feedback.inc] |
Changes to modules/practcl/build/installutil.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 | proc ::practcl::_pkgindex_simpleIndex {path} { set buffer {} set pkgidxfile [file join $path pkgIndex.tcl] set modfile [file join $path [file tail $path].tcl] set use_pkgindex [file exists $pkgidxfile] set tclfiles {} set found 0 set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl] foreach file [glob -nocomplain [file join $path *.tcl]] { if {[file tail $file] ni $mlist} { puts [list NONMODFILE $file] return {} } } foreach file [glob -nocomplain [file join $path *.tcl]] { if { [file tail $file] == "version_info.tcl" } continue set fin [open $file r] set dat [read $fin] close $fin if {![regexp "package provide" $dat]} continue set fname [file rootname [file tail $file]] # Look for a package provide statement foreach line [split $dat \n] { set line [string trim $line] if { [string range $line 0 14] != "package provide" } continue set package [lindex $line 2] set version [lindex $line 3] if {[string index $package 0] in "\$ \[ @"} continue if {[string index $version 0] in "\$ \[ @"} continue puts "PKGLINE $line" append buffer "package ifneeded $package $version \[list source \[file join %DIR% [file tail $file]\]\]" \n break } } return $buffer } ### # Return true if the pkgindex file contains # any statement other than "package ifneeded" # and/or if any package ifneeded loads a DLL ### proc ::practcl::_pkgindex_directory {path} { set buffer {} set pkgidxfile [file join $path pkgIndex.tcl] set modfile [file join $path [file tail $path].tcl] set use_pkgindex [file exists $pkgidxfile] set tclfiles {} if {$use_pkgindex && [file exists $modfile]} { set use_pkgindex 0 set mlist [list pkgIndex.tcl [file tail $modfile]] foreach file [glob -nocomplain [file join $path *.tcl]] { lappend tclfiles [file tail $file] if {[file tail $file] in $mlist} continue incr use_pkgindex } } if {!$use_pkgindex} { # No pkgIndex file, read the source foreach file [glob -nocomplain $path/*.tm] { set file [file normalize $file] set fname [file rootname [file tail $file]] ### # We used to be able to ... Assume the package is correct in the filename # No hunt for a "package provides" |
︙ | ︙ | |||
106 107 108 109 110 111 112 | append buffer $thisline \n set thisline {} } if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} return $buffer } | | > > | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | append buffer $thisline \n set thisline {} } if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} return $buffer } ### # Helper function for ::practcl::pkgindex_path ### proc ::practcl::_pkgindex_path_subdir {path} { set result {} if {[file exists [file join $path src build.tcl]]} { # Tool style module, don't dive into subdirectories return $path } foreach subpath [glob -nocomplain [file join $path *]] { |
︙ | ︙ | |||
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 | set path_indexed($path) 0 } } else { puts [list WARNING: NO PATHS FOUND IN $base] } set path_indexed($base) 1 set path_indexed([file join $base boot tcl]) 1 foreach path $paths { if {$path_indexed($path)} continue set thisdir [file_relative $base $path] set idxbuf [::practcl::_pkgindex_directory $path] if {[string length $idxbuf]} { incr path_indexed($path) append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n } } } append buffer { set dir [lindex $::PATHSTACK end] set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] } return $buffer } proc ::practcl::installDir {d1 d2} { puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] file delete -force -- $d2 file mkdir $d2 foreach ftail [glob -directory $d1 -nocomplain -tails *] { set f [file join $d1 $ftail] | > > > > > > > > > > > > > > > | 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 | set path_indexed($path) 0 } } else { puts [list WARNING: NO PATHS FOUND IN $base] } set path_indexed($base) 1 set path_indexed([file join $base boot tcl]) 1 append buffer \n {# SINGLE FILE MODULES BEGIN} \n {set dir [lindex $::PATHSTACK end]} \n foreach path $paths { if {$path_indexed($path)} continue set thisdir [file_relative $base $path] set simpleIdx [_pkgindex_simpleIndex $path] if {[string length $simpleIdx]==0} continue incr path_indexed($path) if {[string length $simpleIdx]} { incr path_indexed($path) append buffer [string map [list %DIR% "\$dir \{$thisdir\}"] [string trimright $simpleIdx]] \n } } append buffer {# SINGLE FILE MODULES END} \n foreach path $paths { if {$path_indexed($path)} continue set thisdir [file_relative $base $path] set idxbuf [::practcl::_pkgindex_directory $path] if {[string length $idxbuf]} { incr path_indexed($path) append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n } } } append buffer { set dir [lindex $::PATHSTACK end] set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] } return $buffer } # Delete the contents of [emph d2], and then # recusively Ccopy the contents of [emph d1] to [emph d2]. proc ::practcl::installDir {d1 d2} { puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] file delete -force -- $d2 file mkdir $d2 foreach ftail [glob -directory $d1 -nocomplain -tails *] { set f [file join $d1 $ftail] |
︙ | ︙ | |||
213 214 215 216 217 218 219 220 221 222 223 224 225 226 | if {$::tcl_platform(platform) eq {unix}} { file attributes $d2 -permissions 0755 } else { file attributes $d2 -readonly 1 } } proc ::practcl::copyDir {d1 d2 {toplevel 1}} { #if {$toplevel} { # puts [list ::practcl::copyDir $d1 -> $d2] #} #file delete -force -- $d2 file mkdir $d2 if {[file isfile $d1]} { | > | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | if {$::tcl_platform(platform) eq {unix}} { file attributes $d2 -permissions 0755 } else { file attributes $d2 -readonly 1 } } # Recursively copy the contents of [emph d1] to [emph d2] proc ::practcl::copyDir {d1 d2 {toplevel 1}} { #if {$toplevel} { # puts [list ::practcl::copyDir $d1 -> $d2] #} #file delete -force -- $d2 file mkdir $d2 if {[file isfile $d1]} { |
︙ | ︙ | |||
243 244 245 246 247 248 249 | } else { file attributes [file join $d2 $ftail] -readonly 1 } } } } } | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } else { file attributes [file join $d2 $ftail] -readonly 1 } } } } } proc ::practcl::buildModule {modpath} { set buildscript [file join $modpath build build.tcl] if {![file exists $buildscript]} return set pkgIndexFile [file join $modpath pkgIndex.tcl] if {[file exists $pkgIndexFile]} { set latest 0 foreach file [::practcl::findByPattern [file dirname $buildscript] *.tcl] { set mtime [file mtime $file] if {$mtime>$latest} { set latest $mtime } } set IdxTime [file mtime $pkgIndexFile] if {$latest<$IdxTime} return } ::practcl::dotclexec $buildscript } proc ::practcl::installModule {modpath DEST} { set dpath [file join $DEST modules [file tail $modpath]] puts [list ::practcl::installModule $modpath -> $dpath] if {[file exists [file join $modpath index.tcl]]} { # IRM/Tao style modules non-amalgamated ::practcl::installDir $modpath $dpath return } if {[file exists [file join $modpath build build.tcl]]} { buildModule $modpath } set files [glob -nocomplain [file join $modpath *.tcl]] if {[llength $files]} { if {[llength $files]>1} { if {![file exists [file join $modpath pkgIndex.tcl]]} { pkg_mkIndex $modpath } } file delete -force $dpath file mkdir $dpath foreach file $files { file copy $file $dpath } } if {[file exists [file join $modpath htdocs]]} { ::practcl::copyDir [file join $modpath htdocs] [file join $dpath htdocs] } } |
Changes to modules/practcl/build/makeutil.tcl.
1 | ### | | | > < > > > > > > > > > > > > > > > | 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 | ### # show_body: 1 # description: # Trigger build targets, and recompute dependencies ### proc ::practcl::trigger {args} { ::practcl::LOCAL make trigger {*}$args foreach {name obj} [::practcl::LOCAL make objects] { set ::make($name) [$obj do] } } ### # show_body: 1 # description: # Calculate if a dependency for any of the arguments needs to # be fulfilled or rebuilt. proc ::practcl::depends {args} { ::practcl::LOCAL make depends {*}$args } ### # show_body: 1 # description: # Declare a build product. This proc is just a shorthand for # [emph {::practcl::LOCAL make task $name $info $action}] # [para] # Registering a build product with this command will create # an entry in the global [variable make] array, and populate # a value in the global [variable target] array. ### proc ::practcl::target {name info {action {}}} { set obj [::practcl::LOCAL make task $name $info $action] set ::make($name) 0 set filename [$obj define get filename] if {$filename ne {}} { set ::target($name) $filename } |
︙ | ︙ |
Added modules/practcl/build/manual.txt.
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | [keywords practcl] [copyright {2016-2018 Sean Woods <[email protected]>}] [moddesc {The The Proper Rational API for C to Tool Command Language Module}] [titledesc {The Practcl Module}] [category {TclOO}] [require TclOO 1.0] [description] The Practcl module is a tool for integrating large modules for C API Tcl code that requires custom Tcl types and TclOO objects. [para] The concept with Practcl is that is a single file package that can assist any tcl based project with distribution, compilation, linking, VFS preparation, executable assembly, and installation. Practcl also allows one project to invoke the build system from another project, allowing complex projects such as a statically linked basekit to be assembled with relative ease. [para] Practcl ships as a single file, and aside from a Tcl 8.6 interpreter, has no external dependencies. [para] Making a practcl project |
Changes to modules/practcl/pkgIndex.tcl.
1 | ### | | | | 1 2 3 4 | ### if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded practcl 0.16.3 [list source [file join $dir practcl.tcl]] |
Changes to modules/practcl/practcl.man.
|
| | | | < > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 | [comment {-*- tcl -*- doctools manpage}] [vset PACKAGE_VERSION 0.16.3] [manpage_begin practcl n [vset PACKAGE_VERSION]] [keywords practcl] [copyright {2016-2018 Sean Woods <[email protected]>}] [moddesc {The The Proper Rational API for C to Tool Command Language Module}] [titledesc {The Practcl Module}] [category {TclOO}] [require TclOO 1.0] [description] The Practcl module is a tool for integrating large modules for C API Tcl code that requires custom Tcl types and TclOO objects. [para] The concept with Practcl is that is a single file package that can assist any tcl based project with distribution, compilation, linking, VFS preparation, executable assembly, and installation. Practcl also allows one project to invoke the build system from another project, allowing complex projects such as a statically linked basekit to be assembled with relative ease. [para] Practcl ships as a single file, and aside from a Tcl 8.6 interpreter, has no external dependencies. [para] Making a practcl project [section {Commands}] [list_begin definitions] [call proc [cmd practcl::cat] [arg fname]] Concatenate a file [call proc [cmd practcl::docstrip] [arg text]] Strip the global comments from tcl code. Used to prevent the documentation markup comments from clogging up files intended for distribution in machine readable format. [call proc [cmd putb] [opt "[arg map]"] [arg text]] Append a line of text to a variable. Optionally apply a string mapping. [call proc [cmd Proc] [arg name] [arg arglist] [arg body]] Generate a proc if no command already exists by that name [call proc [cmd noop] [opt "[arg args]"]] A command to do nothing. A handy way of negating an instruction without having to comment it completely out. It's also a handy attachment point for an object to be named later [call proc [cmd practcl::debug] [opt "[arg args]"]] [call proc [cmd practcl::doexec] [opt "[arg args]"]] Drop in a static copy of Tcl [call proc [cmd practcl::doexec_in] [arg path] [opt "[arg args]"]] [call proc [cmd practcl::dotclexec] [opt "[arg args]"]] [call proc [cmd practcl::domake] [arg path] [opt "[arg args]"]] [call proc [cmd practcl::domake.tcl] [arg path] [opt "[arg args]"]] [call proc [cmd practcl::fossil] [arg path] [opt "[arg args]"]] [call proc [cmd practcl::fossil_status] [arg dir]] [call proc [cmd practcl::os]] [call proc [cmd practcl::mkzip] [arg exename] [arg barekit] [arg vfspath]] Build a zipfile. On tcl8.6 this invokes the native Zip implementation on older interpreters this invokes zip via exec [call proc [cmd practcl::sort_dict] [arg list]] Dictionary sort a key/value list. Needed because pre tcl8.6 does not have [emph {lsort -stride 2}] [call proc [cmd practcl::local_os]] [call proc [cmd practcl::config.tcl] [arg path]] Detect local platform [call proc [cmd practcl::read_configuration] [arg path]] [call proc [cmd practcl::tcllib_require] [arg pkg] [opt "[arg args]"]] Try to load a package, and failing that retrieve tcllib [call proc [cmd practcl::platform::tcl_core_options] [arg os]] [call proc [cmd practcl::platform::tk_core_options] [arg os]] [call proc [cmd practcl::read_rc_file] [arg filename] [opt "[arg localdat] [const ""]"]] Read a stylized key/value list stored in a file [call proc [cmd practcl::read_sh_subst] [arg line] [arg info]] Converts a XXX.sh file into a series of Tcl variables [call proc [cmd practcl::read_sh_file] [arg filename] [opt "[arg localdat] [const ""]"]] [call proc [cmd practcl::read_Config.sh] [arg filename]] A simpler form of read_sh_file tailored to pulling data from (tcl|tk)Config.sh [call proc [cmd practcl::read_Makefile] [arg filename]] A simpler form of read_sh_file tailored to pulling data from a Makefile [call proc [cmd practcl::cputs] [arg varname] [opt "[arg args]"]] Append arguments to a buffer The command works like puts in that each call will also insert a line feed. Unlike puts, blank links in the interstitial are suppressed [call proc [cmd practcl::tcl_to_c] [arg body]] [call proc [cmd practcl::_tagblock] [arg text] [opt "[arg style] [const "tcl"]"] [opt "[arg note] [const ""]"]] [call proc [cmd practcl::de_shell] [arg data]] [call proc [cmd practcl::grep] [arg pattern] [opt "[arg files] [const ""]"]] Search for the pattern [emph pattern] amongst $files [call proc [cmd practcl::file_lexnormalize] [arg sp]] [call proc [cmd practcl::file_relative] [arg base] [arg dst]] Calculate a relative path between base and dst [para]Example: [example { ::practcl::file_relative ~/build/tcl/unix ~/build/tcl/library > ../library }] [call proc [cmd practcl::findByPattern] [arg basedir] [arg patterns]] [call proc [cmd practcl::log] [arg fname] [arg comment]] Record an event in the practcl log [call proc [cmd practcl::_pkgindex_simpleIndex] [arg path]] [call proc [cmd practcl::_pkgindex_directory] [arg path]] Return true if the pkgindex file contains any statement other than "package ifneeded" and/or if any package ifneeded loads a DLL [call proc [cmd practcl::_pkgindex_path_subdir] [arg path]] Helper function for ::practcl::pkgindex_path [call proc [cmd practcl::pkgindex_path] [opt "[arg args]"]] Index all paths given as though they will end up in the same virtual file system [call proc [cmd practcl::installDir] [arg d1] [arg d2]] Delete the contents of [emph d2], and then recusively Ccopy the contents of [emph d1] to [emph d2]. [call proc [cmd practcl::copyDir] [arg d1] [arg d2] [opt "[arg toplevel] [const "1"]"]] Recursively copy the contents of [emph d1] to [emph d2] [call proc [cmd practcl::buildModule] [arg modpath]] [call proc [cmd practcl::installModule] [arg modpath] [arg DEST]] [call proc [cmd practcl::trigger] [opt "[arg args]"]] Trigger build targets, and recompute dependencies [para]Internals: [example { ::practcl::LOCAL make trigger {*}$args foreach {name obj} [::practcl::LOCAL make objects] { set ::make($name) [$obj do] } }] [call proc [cmd practcl::depends] [opt "[arg args]"]] Calculate if a dependency for any of the arguments needs to be fulfilled or rebuilt. [para]Internals: [example { ::practcl::LOCAL make depends {*}$args }] [call proc [cmd practcl::target] [arg name] [arg info] [opt "[arg action] [const ""]"]] Declare a build product. This proc is just a shorthand for [emph {::practcl::LOCAL make task $name $info $action}] [para] Registering a build product with this command will create an entry in the global [variable make] array, and populate a value in the global [variable target] array. [para]Internals: [example { set obj [::practcl::LOCAL make task $name $info $action] set ::make($name) 0 set filename [$obj define get filename] if {$filename ne {}} { set ::target($name) $filename } }] [list_end] [section Classes] [subsection {Class practcl::doctool}] [example {{ set authors { {John Doe} {[email protected]} {Tom RichardHarry} {[email protected]} } # Create the object ::practcl::doctool create AutoDoc set fout [open [file join $moddir module.tcl] w] foreach file [glob [file join $srcdir *.tcl]] { set content [::practcl::cat [file join $srcdir $file]] # Scan the file AutoDoc scan_text $content # Strip the comments from the distribution puts $fout [::practcl::docstrip $content] } # Write out the manual page set manout [open [file join $moddir module.man] w] dict set args header [string map $modmap [::practcl::cat [file join $srcdir manual.txt]]] dict set args footer [string map $modmap [::practcl::cat [file join $srcdir footer.txt]]] dict set args authors $authors puts $manout [AutoDoc manpage {*}$args] close $manout }}] [para] Tool for build scripts to dynamically generate manual files from comments in source code files [para] [class {Methods}] [list_begin definitions] [call method [cmd "constructor"]] [call method [cmd "argspec"] [arg argspec]] Process an argument list into an informational dict. This method also understands non-positional arguments expressed in the notation of Tip 471 [uri https://core.tcl-lang.org/tips/doc/trunk/tip/479.md]. [para] The output will be a dictionary of all of the fields and whether the fields are [const positional], [const mandatory], and whether they have a [const default] value. [para] [para]Example: [example { my argspec {a b {c 10}} > a {positional 1 mandatory 1} b {positional 1 mandatory 1} c {positional 1 mandatory 0 default 10} }] [call method [cmd "comment"] [arg block]] Convert a block of comments into an informational dictionary. If lines in the comment start with a single word ending in a colon, all subsequent lines are appended to a dictionary field of that name. If no fields are given, all of the text is appended to the [const description] field. [para]Example: [example { my comment {Does something cool} > description {Does something cool} my comment { title : Something really cool author : Sean Woods author : John Doe description : This does something really cool! } > description {This does something really cool!} title {Something really cool} author {Sean Woods John Doe} }] [call method [cmd "keyword.Annotation"] [arg resultvar] [arg commentblock] [arg type] [arg name] [arg body]] [call method [cmd "keyword.Class"] [arg resultvar] [arg commentblock] [arg name] [arg body]] Process an oo::objdefine call that modifies the class object itself [call method [cmd "keyword.class"] [arg resultvar] [arg commentblock] [arg name] [arg body]] Process an oo::define, clay::define, etc statement. [call method [cmd "keyword.Class_Method"] [arg resultvar] [arg commentblock] [arg name] [opt "[arg args]"]] Process a statement for a clay style class method [call method [cmd "keyword.method"] [arg resultvar] [arg commentblock] [arg name] [opt "[arg args]"]] Process a statement for a tcloo style object method [call method [cmd "keyword.proc"] [arg commentblock] [arg name] [arg argspec]] Process a proc statement [call method [cmd "reset"]] Reset the state of the object and its embedded coroutine [call method [cmd "Main"]] Main body of the embedded coroutine for the object [call method [cmd "section.method"] [arg keyword] [arg method] [arg minfo]] Generate the manual page text for a method or proc [call method [cmd "section.annotation"] [arg type] [arg name] [arg iinfo]] [call method [cmd "section.class"] [arg class_name] [arg class_info]] Generate the manual page text for a class [call method [cmd "section.command"] [arg procinfo]] Generate the manual page text for the commands section [call method [cmd "manpage"] [opt "[option "header [emph value]"]"] [opt "[option "footer [emph value]"]"] [opt "[option "authors [emph list]"]"]] Generate the manual page. Returns the completed text suitable for saving in .man file. The header argument is a block of doctools text to go in before the machine generated section. footer is a block of doctools text to go in after the machine generated section. authors is a list of individual authors and emails in the form of AUTHOR EMAIL ?AUTHOR EMAIL?... [call method [cmd "scan_text"] [arg text]] Scan a block of text [call method [cmd "scan_file"] [arg filename]] Scan a file of text [list_end] [para] [subsection {Class practcl::metaclass}] The metaclass for all practcl objects [para] [class {Methods}] [list_begin definitions] [call method [cmd "_MorphPatterns"]] [call method [cmd "define"] [arg submethod] [opt "[arg args]"]] [call method [cmd "graft"] [opt "[arg args]"]] [call method [cmd "initialize"]] [call method [cmd "link"] [arg command] [opt "[arg args]"]] [call method [cmd "morph"] [arg classname]] [call method [cmd "script"] [arg script]] [call method [cmd "select"]] [call method [cmd "source"] [arg filename]] [list_end] [para] [subsection {Class practcl::toolset}] Ancestor-less class intended to be a mixin which defines a family of build related behaviors that are modified when targetting either gcc or msvc [para] [class {Class Methods}] [list_begin definitions] [call classmethod [cmd select] [arg object]] Perform the selection for the toolset mixin [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "config.sh"]] find or fake a key/value list describing this project [call method [cmd "BuildDir"] [arg PWD]] Compute the location where the product will be built [call method [cmd "MakeDir"] [arg srcdir]] Return where the Makefile is located relative to [emph srcdir]. For this implementation the MakeDir is always srcdir. [call method [cmd "read_configuration"]] Read information about the build process for this package. For this implementation, data is sought in the following locations in the following order: config.tcl (generated by practcl.) PKGConfig.sh. The Makefile [para] If the Makefile needs to be consulted, but does not exist, the Configure method is invoked [call method [cmd "build-cflags"] [arg PROJECT] [arg DEFS] [arg namevar] [arg versionvar] [arg defsvar]] method DEFS This method populates 4 variables: name - The name of the package version - The version of the package defs - C flags passed to the compiler includedir - A list of paths to feed to the compiler for finding headers [call method [cmd "critcl"] [opt "[arg args]"]] Invoke critcl in an external process [list_end] [para] [subsection {Class practcl::toolset.gcc}] [emph "ancestors"]: [class practcl::toolset] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "Autoconf"]] [call method [cmd "BuildDir"] [arg PWD]] [call method [cmd "ConfigureOpts"]] [call method [cmd "MakeDir"] [arg srcdir]] Detect what directory contains the Makefile template [call method [cmd "make {} autodetect"]] [call method [cmd "make {} clean"]] [call method [cmd "make {} compile"]] [call method [cmd "make {} install"] [arg DEST]] [call method [cmd "build-compile-sources"] [arg PROJECT] [arg COMPILE] [arg CPPCOMPILE] [arg INCLUDES]] [call method [cmd "build-Makefile"] [arg path] [arg PROJECT]] [call method [cmd "build-library"] [arg outfile] [arg PROJECT]] Produce a static or dynamic library [call method [cmd "build-tclsh"] [arg outfile] [arg PROJECT] [opt "[arg path] [const "auto"]"]] Produce a static executable [list_end] [para] [subsection {Class practcl::toolset.msvc}] [emph "ancestors"]: [class practcl::toolset] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "BuildDir"] [arg PWD]] MSVC always builds in the source directory [call method [cmd "make {} autodetect"]] Do nothing [call method [cmd "make {} clean"]] [call method [cmd "make {} compile"]] [call method [cmd "make {} install"] [arg DEST]] [call method [cmd "MakeDir"] [arg srcdir]] Detect what directory contains the Makefile template [call method [cmd "NmakeOpts"]] [list_end] [para] [subsection {Class practcl::make_obj}] [emph "ancestors"]: [class practcl::metaclass] [para] A build deliverable object. Normally an object file, header, or tcl script which must be compiled or generated in some way [para] [class {Methods}] [list_begin definitions] [call method [cmd "constructor"] [arg module_object] [arg name] [arg info] [opt "[arg action_body] [const ""]"]] [call method [cmd "do"]] [call method [cmd "check"]] [call method [cmd "output"]] [call method [cmd "reset"]] [call method [cmd "triggers"]] [list_end] [para] [subsection {Class practcl::object}] [emph "ancestors"]: [class practcl::metaclass] [para] A generic Practcl object [para] [class {Methods}] [list_begin definitions] [call method [cmd "constructor"] [arg parent] [opt "[arg args]"]] [call method [cmd "child"] [arg method]] [call method [cmd "go"]] [list_end] [para] [subsection {Class practcl::dynamic}] Dynamic blocks do not generate their own .c files, instead the contribute to the amalgamation of the main library file [para] [class {Methods}] [list_begin definitions] [call method [cmd "cstructure"] [arg name] [arg definition] [opt "[arg argdat] [const ""]"]] Parser functions [call method [cmd "include"] [arg header]] [call method [cmd "include_dir"] [opt "[arg args]"]] [call method [cmd "include_directory"] [opt "[arg args]"]] [call method [cmd "c_header"] [arg body]] [call method [cmd "c_code"] [arg body]] [call method [cmd "c_function"] [arg header] [arg body] [opt "[arg info] [const ""]"]] [call method [cmd "c_tcloomethod"] [arg name] [arg body] [opt "[arg arginfo] [const ""]"]] [call method [cmd "cmethod"] [arg name] [arg body] [opt "[arg arginfo] [const ""]"]] Alias to classic name [call method [cmd "c_tclproc_nspace"] [arg nspace]] [call method [cmd "c_tclcmd"] [arg name] [arg body] [opt "[arg arginfo] [const ""]"]] [call method [cmd "c_tclproc_raw"] [arg name] [arg body] [opt "[arg arginfo] [const ""]"]] Alias to classic name [call method [cmd "tcltype"] [arg name] [arg argdat]] [call method [cmd "project-compile-products"]] Module interactions [call method [cmd "implement"] [arg path]] [call method [cmd "initialize"]] Practcl internals [call method [cmd "linktype"]] [call method [cmd "generate-cfile-constant"]] [call method [cmd "generate-cfile-header"]] [call method [cmd "generate-cfile-tclapi"]] Generate code that provides implements Tcl API calls [call method [cmd "generate-loader-module"]] Generate code that runs when the package/module is initialized into the interpreter [call method [cmd "Collate_Source"] [arg CWD]] [call method [cmd "select"]] Once an object marks itself as some flavor of dynamic, stop trying to morph it into something else [list_end] [para] [subsection {Class practcl::product}] A deliverable for the build system [para] [class {Class Methods}] [list_begin definitions] [call classmethod [cmd select] [arg object]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "code"] [arg section] [arg body]] [call method [cmd "Collate_Source"] [arg CWD]] [call method [cmd "project-compile-products"]] [call method [cmd "generate-debug"] [opt "[arg spaces] [const ""]"]] [call method [cmd "generate-cfile-constant"]] [call method [cmd "generate-cfile-public-structure"]] Populate const static data structures [call method [cmd "generate-cfile-header"]] [call method [cmd "generate-cfile-global"]] [call method [cmd "generate-cfile-private-typedef"]] [call method [cmd "generate-cfile-private-structure"]] [call method [cmd "generate-cfile-functions"]] Generate code that provides subroutines called by Tcl API methods [call method [cmd "generate-cfile-tclapi"]] Generate code that provides implements Tcl API calls [call method [cmd "generate-hfile-public-define"]] [call method [cmd "generate-hfile-public-macro"]] [call method [cmd "generate-hfile-public-typedef"]] [call method [cmd "generate-hfile-public-structure"]] [call method [cmd "generate-hfile-public-headers"]] [call method [cmd "generate-hfile-public-function"]] [call method [cmd "generate-hfile-public-includes"]] [call method [cmd "generate-hfile-public-verbatim"]] [call method [cmd "generate-loader-external"]] [call method [cmd "generate-loader-module"]] [call method [cmd "generate-stub-function"]] [call method [cmd "IncludeAdd"] [arg headervar] [opt "[arg args]"]] [call method [cmd "generate-tcl-loader"]] [call method [cmd "generate-tcl-pre"]] This methods generates any Tcl script file which is required to pre-initialize the C library [call method [cmd "generate-tcl-post"]] [call method [cmd "linktype"]] [call method [cmd "Ofile"] [arg filename]] [call method [cmd "project-static-packages"]] Methods called by the master project [call method [cmd "toolset-include-directory"]] Methods called by the toolset [call method [cmd "target"] [arg method] [opt "[arg args]"]] [list_end] [para] [subsection {Class practcl::product.cheader}] [emph "ancestors"]: [class practcl::product] [para] A product which generated from a C header file. Which is to say, nothing. [para] [class {Methods}] [list_begin definitions] [call method [cmd "project-compile-products"]] [call method [cmd "generate-loader-module"]] [list_end] [para] [subsection {Class practcl::product.csource}] [emph "ancestors"]: [class practcl::product] [para] A product which generated from a C source file. Normally an object (.o) file. [para] [class {Methods}] [list_begin definitions] [call method [cmd "project-compile-products"]] [list_end] [para] [subsection {Class practcl::product.clibrary}] [emph "ancestors"]: [class practcl::product] [para] A product which is generated from a compiled C library. Usually a .a or a .dylib file, but in complex cases may actually just be a conduit for one project to integrate the source code of another [para] [class {Methods}] [list_begin definitions] [call method [cmd "linker-products"] [arg configdict]] [list_end] [para] [subsection {Class practcl::product.dynamic}] [emph "ancestors"]: [class practcl::dynamic] [class practcl::product] [para] A product which is generated from C code that itself is generated by practcl or some other means. This C file may or may not produce its own .o file, depending on whether it is eligible to become part of an amalgamation [para] [class {Methods}] [list_begin definitions] [call method [cmd "initialize"]] [list_end] [para] [subsection {Class practcl::product.critcl}] [emph "ancestors"]: [class practcl::dynamic] [class practcl::product] [para] A binary product produced by critcl. Note: The implementation is not written yet, this class does nothing. [para] [subsection {Class practcl::module}] [emph "ancestors"]: [class practcl::object] [class practcl::product.dynamic] [para] In the end, all C code must be loaded into a module This will either be a dynamically loaded library implementing a tcl extension, or a compiled in segment of a custom shell/app [para] [class {Variable}] [list_begin definitions] [call variable [cmd make_object]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "_MorphPatterns"]] [call method [cmd "add"] [opt "[arg args]"]] [call method [cmd "install-headers"] [opt "[arg args]"]] [call method [cmd "make {} _preamble"]] [call method [cmd "make {} pkginfo"]] [call method [cmd "make {} objects"]] Return a dictionary of all handles and associated objects [call method [cmd "make {} object"] [arg name]] Return the object associated with handle [emph name] [call method [cmd "make {} reset"]] Reset all deputy objects [call method [cmd "make {} trigger"] [opt "[arg args]"]] Exercise the triggers method for all handles listed [call method [cmd "make {} depends"] [opt "[arg args]"]] Exercise the check method for all handles listed [call method [cmd "make {} filename"] [arg name]] Return the file name of the build product for the listed handle [call method [cmd "make {} target"] [arg name] [arg Info] [arg body]] [call method [cmd "make {} todo"]] Return a list of handles for object which return true for the do method [call method [cmd "make {} do"]] For each target exercise the action specified in the [emph action] definition if the [emph do] method returns true [call method [cmd "child"] [arg which]] [call method [cmd "generate-c"]] This methods generates the contents of an amalgamated .c file which implements the loader for a batch of tools [call method [cmd "generate-h"]] This methods generates the contents of an amalgamated .h file which describes the public API of this module [call method [cmd "generate-loader"]] [call method [cmd "initialize"]] [call method [cmd "implement"] [arg path]] [call method [cmd "linktype"]] [list_end] [para] [subsection {Class practcl::project}] [emph "ancestors"]: [class practcl::module] [para] A toplevel project that is a collection of other projects [para] [class {Methods}] [list_begin definitions] [call method [cmd "_MorphPatterns"]] [call method [cmd "constructor"] [opt "[arg args]"]] [call method [cmd "add_object"] [arg object]] [call method [cmd "add_project"] [arg pkg] [arg info] [opt "[arg oodefine] [const ""]"]] [call method [cmd "add_tool"] [arg pkg] [arg info] [opt "[arg oodefine] [const ""]"]] [call method [cmd "build-tclcore"]] Compile the Tcl core. If the define [emph tk] is true, compile the Tk core as well [call method [cmd "child"] [arg which]] [call method [cmd "linktype"]] [call method [cmd "project"] [arg pkg] [opt "[arg args]"]] Exercise the methods of a sub-object [call method [cmd "tclcore"]] [call method [cmd "tkcore"]] [call method [cmd "tool"] [arg pkg] [opt "[arg args]"]] [list_end] [para] [subsection {Class practcl::library}] [emph "ancestors"]: [class practcl::project] [para] A toplevel project that produces a library [para] [class {Methods}] [list_begin definitions] [call method [cmd "clean"] [arg PATH]] [call method [cmd "project-compile-products"]] [call method [cmd "go"]] [call method [cmd "generate-decls"] [arg pkgname] [arg path]] [call method [cmd "implement"] [arg path]] [call method [cmd "generate-make"] [arg path]] Backward compadible call [call method [cmd "linktype"]] [call method [cmd "package-ifneeded"] [opt "[arg args]"]] Create a "package ifneeded" Args are a list of aliases for which this package will answer to [call method [cmd "shared_library"] [opt "[arg filename] [const ""]"]] [call method [cmd "static_library"] [opt "[arg filename] [const ""]"]] [list_end] [para] [subsection {Class practcl::tclkit}] [emph "ancestors"]: [class practcl::library] [para] A toplevel project that produces a self-contained executable [para] [class {Methods}] [list_begin definitions] [call method [cmd "build-tclkit_main"] [arg PROJECT] [arg PKG_OBJS]] [call method [cmd "Collate_Source"] [arg CWD]] [call method [cmd "wrap"] [arg PWD] [arg exename] [arg vfspath] [opt "[arg args]"]] Wrap an executable [list_end] [para] [subsection {Class practcl::distribution}] Standalone class to manage code distribution This class is intended to be mixed into another class (Thus the lack of ancestors) [para] [class {Class Methods}] [list_begin definitions] [call classmethod [cmd Sandbox] [arg object]] [call classmethod [cmd select] [arg object]] [call classmethod [cmd claim_option]] [call classmethod [cmd claim_object] [arg object]] [call classmethod [cmd claim_path] [arg path]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "scm_info"]] [call method [cmd "DistroMixIn"]] [call method [cmd "Sandbox"]] [call method [cmd "SrcDir"]] [call method [cmd "ScmTag"]] [call method [cmd "ScmClone"]] [call method [cmd "ScmUnpack"]] [call method [cmd "ScmUpdate"]] [call method [cmd "Unpack"]] [list_end] [para] [subsection {Class practcl::distribution.snapshot}] [emph "ancestors"]: [class practcl::distribution] [para] A file distribution from zip, tarball, or other non-scm archive format [para] [class {Class Methods}] [list_begin definitions] [call classmethod [cmd claim_object] [arg object]] [call classmethod [cmd claim_option]] [call classmethod [cmd claim_path] [arg path]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "ScmUnpack"]] [list_end] [para] [subsection {Class practcl::distribution.fossil}] [emph "ancestors"]: [class practcl::distribution] [para] A file distribution based on fossil [para] [class {Class Methods}] [list_begin definitions] [call classmethod [cmd claim_object] [arg obj]] Check for markers in the metadata [call classmethod [cmd claim_option]] [call classmethod [cmd claim_path] [arg path]] Check for markers in the source root [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "scm_info"]] [call method [cmd "ScmClone"]] Clone the source [call method [cmd "ScmTag"]] [call method [cmd "ScmUnpack"]] [call method [cmd "ScmUpdate"]] [list_end] [para] [subsection {Class practcl::distribution.git}] [emph "ancestors"]: [class practcl::distribution] [para] A file distribution based on git [para] [class {Class Methods}] [list_begin definitions] [call classmethod [cmd claim_object] [arg obj]] [call classmethod [cmd claim_option]] [call classmethod [cmd claim_path] [arg path]] [list_end] [para] [class {Methods}] [list_begin definitions] [call method [cmd "ScmTag"]] [call method [cmd "ScmUnpack"]] [call method [cmd "ScmUpdate"]] [list_end] [para] [subsection {Class practcl::subproject}] [emph "ancestors"]: [class practcl::module] [para] A subordinate project [para] [class {Methods}] [list_begin definitions] [call method [cmd "_MorphPatterns"]] [call method [cmd "BuildDir"] [arg PWD]] [call method [cmd "child"] [arg which]] [call method [cmd "compile"]] [call method [cmd "go"]] [call method [cmd "install"] [opt "[arg args]"]] Install project into the local build system [call method [cmd "linktype"]] [call method [cmd "linker-products"] [arg configdict]] [call method [cmd "linker-external"] [arg configdict]] [call method [cmd "linker-extra"] [arg configdict]] [call method [cmd "env-bootstrap"]] Methods for packages/tools that can be downloaded possibly built and used internally by this Practcl process Load the facility into the interpreter [call method [cmd "env-exec"]] Return a file path that exec can call [call method [cmd "env-install"]] Install the tool into the local environment [call method [cmd "env-load"]] Do whatever is necessary to get the tool into the local environment [call method [cmd "env-present"]] Check if tool is available for load/already loaded [call method [cmd "sources"]] [call method [cmd "update"]] [call method [cmd "unpack"]] [list_end] [para] [subsection {Class practcl::subproject.source}] [emph "ancestors"]: [class practcl::subproject] [class practcl::library] [para] A project which the kit compiles and integrates the source for itself [para] [class {Methods}] [list_begin definitions] [call method [cmd "env-bootstrap"]] [call method [cmd "env-present"]] [call method [cmd "linktype"]] [list_end] [para] [subsection {Class practcl::subproject.teapot}] [emph "ancestors"]: [class practcl::subproject] [para] a copy from the teapot [para] [class {Methods}] [list_begin definitions] [call method [cmd "env-bootstrap"]] [call method [cmd "env-install"]] [call method [cmd "env-present"]] [call method [cmd "install"] [arg DEST]] [list_end] [para] [subsection {Class practcl::subproject.kettle}] [emph "ancestors"]: [class practcl::subproject] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "kettle"] [arg path] [opt "[arg args]"]] [call method [cmd "install"] [arg DEST]] [list_end] [para] [subsection {Class practcl::subproject.critcl}] [emph "ancestors"]: [class practcl::subproject] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "install"] [arg DEST]] [list_end] [para] [subsection {Class practcl::subproject.sak}] [emph "ancestors"]: [class practcl::subproject] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "env-bootstrap"]] [call method [cmd "env-install"]] [call method [cmd "env-present"]] [call method [cmd "install"] [arg DEST]] [call method [cmd "install-module"] [arg DEST] [opt "[arg args]"]] [list_end] [para] [subsection {Class practcl::subproject.practcl}] [emph "ancestors"]: [class practcl::subproject] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "env-bootstrap"]] [call method [cmd "env-install"]] [call method [cmd "install"] [arg DEST]] [call method [cmd "install-module"] [arg DEST] [opt "[arg args]"]] [list_end] [para] [subsection {Class practcl::subproject.binary}] [emph "ancestors"]: [class practcl::subproject] [para] A subordinate binary package [para] [class {Methods}] [list_begin definitions] [call method [cmd "clean"]] [call method [cmd "env-install"]] [call method [cmd "project-compile-products"]] [call method [cmd "ComputeInstall"]] [call method [cmd "go"]] [call method [cmd "linker-products"] [arg configdict]] [call method [cmd "project-static-packages"]] [call method [cmd "BuildDir"] [arg PWD]] [call method [cmd "compile"]] [call method [cmd "Configure"]] [call method [cmd "install"] [arg DEST]] [list_end] [para] [subsection {Class practcl::subproject.tea}] [emph "ancestors"]: [class practcl::subproject.binary] [para] A subordinate TEA based binary package [para] [subsection {Class practcl::subproject.library}] [emph "ancestors"]: [class practcl::subproject.binary] [class practcl::library] [para] A subordinate C library built by this project [para] [class {Methods}] [list_begin definitions] [call method [cmd "install"] [arg DEST]] [list_end] [para] [subsection {Class practcl::subproject.external}] [emph "ancestors"]: [class practcl::subproject.binary] [para] A subordinate external C library [para] [class {Methods}] [list_begin definitions] [call method [cmd "install"] [arg DEST]] [list_end] [para] [subsection {Class practcl::subproject.core}] [emph "ancestors"]: [class practcl::subproject.binary] [para] [para] [class {Methods}] [list_begin definitions] [call method [cmd "env-bootstrap"]] [call method [cmd "env-present"]] [call method [cmd "env-install"]] [call method [cmd "go"]] [call method [cmd "linktype"]] [list_end] [para] [vset CATEGORY practcl] [include ../doctools2base/include/feedback.inc] [manpage_end] |
Changes to modules/practcl/practcl.tcl.
1 2 3 4 5 | ### # Amalgamated package for practcl # Do not edit directly, tweak the source in src/ and rerun # build.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 | ### # Amalgamated package for practcl # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### package require Tcl 8.6 package provide practcl 0.16.3 namespace eval ::practcl {} ### # START: httpwget/wget.tcl ### ### # END: httpwget/wget.tcl ### ### # START: clay/clay.tcl ### ### # END: clay/clay.tcl ### ### # START: setup.tcl ### package require TclOO set tcllib_path {} foreach path {.. ../.. ../../..} { foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] { set tclib_path $path lappend ::auto_path $path break } if {$tcllib_path ne {}} break } namespace eval ::practcl { } namespace eval ::practcl::OBJECT { } ### # END: setup.tcl ### ### # START: doctool.tcl ### namespace eval ::practcl { } proc ::practcl::cat fname { if {![file exists $fname]} { return } set fin [open $fname r] set data [read $fin] close $fin return $data } proc ::practcl::docstrip text { set result {} foreach line [split $text \n] { append thisline $line \n if {![info complete $thisline]} continue set outline $thisline set thisline {} if {[string trim $outline] eq {}} { continue } if {[string index [string trim $outline] 0] eq "#"} continue set cmd [string trim [lindex $outline 0] :] if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } if {[string match "*::define" $cmd] && [llength $outline]==3} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } append result $outline } return $result } proc ::putb {buffername args} { upvar 1 $buffername buffer switch [llength $args] { 1 { append buffer [lindex $args 0] \n } 2 { append buffer [string map {*}$args] \n } default { error "usage: putb buffername ?map? string" } } } ::oo::class create ::practcl::doctool { constructor {} { my reset } method argspec {argspec} { set result [dict create] foreach arg $argspec { set name [lindex $arg 0] dict set result $name positional 1 dict set result $name mandatory 1 if {$name in {args dictargs}} { switch [llength $arg] { 1 { dict set result $name mandatory 0 } 2 { dict for {optname optinfo} [lindex $arg 1] { set optname [string trim $optname -:] dict set result $optname {positional 1 mandatory 0} dict for {f v} $optinfo { dict set result $optname [string trim $f -:] $v } } } default { error "Bad argument" } } } else { switch [llength $arg] { 1 { dict set result $name mandatory 1 } 2 { dict set result $name mandatory 0 dict set result $name default [lindex $arg 1] } default { error "Bad argument" } } } } return $result } method comment block { set count 0 set field description set result [dict create description {}] foreach line [split $block \n] { set sline [string trim $line] set fwidx [string first " " $sline] if {$fwidx < 0} { set firstword [string range $sline 0 end] set restline {} } else { set firstword [string range $sline 0 [expr {$fwidx-1}]] set restline [string range $sline [expr {$fwidx+1}] end] } if {[string index $firstword end] eq ":"} { set field [string tolower [string trim $firstword -:]] switch $field { dictargs - arglist { set field argspec } desc { set field description } } if {[string length $restline]} { dict append result $field "$restline\n" } } else { dict append result $field "$line\n" } } return $result } method keyword.Annotation {resultvar commentblock type name body} { upvar 1 $resultvar result set name [string trim $name :] if {[dict exists $result $type $name]} { set info [dict get $result $type $name] } else { set info [my comment $commentblock] } foreach {f v} $body { dict set info $f $v } dict set result $type $name $info } method keyword.Class {resultvar commentblock name body} { upvar 1 $resultvar result set name [string trim $name :] if {[dict exists $result class $name]} { set info [dict get $result class $name] } else { set info [my comment $commentblock] } set commentblock {} foreach line [split $body \n] { append thisline $line \n if {![info complete $thisline]} continue set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} { append commentblock [string trimleft $thisline #] \n set thisline {} continue } set cmd [string trim [lindex $thisline 0] ":"] switch $cmd { Option - option { my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } variable - Variable { my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list type scaler default [lindex $thisline 2]] set commentblock {} } Dict - Array { set iinfo [lindex $thisline 2] dict set iinfo type [string tolower $cmd] my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo set commentblock {} } Componant - Delegate { my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } method - Ensemble { my keyword.Class_Method info $commentblock {*}[lrange $thisline 1 end-1] set commentblock {} } } set thisline {} } dict set result class $name $info } method keyword.class {resultvar commentblock name body} { upvar 1 $resultvar result set name [string trim $name :] if {[dict exists $result class $name]} { set info [dict get $result class $name] } else { set info [my comment $commentblock] } set commentblock {} foreach line [split $body \n] { append thisline $line \n if {![info complete $thisline]} continue set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} { append commentblock [string trimleft $thisline #] \n set thisline {} continue } set cmd [string trim [lindex $thisline 0] ":"] switch $cmd { Option - option { puts [list keyword.Annotation $cmd $thisline] my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } variable - Variable { my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list default [lindex $thisline 2]] set commentblock {} } Dict - Array { set iinfo [lindex $thisline 2] dict set iinfo type [string tolower $cmd] my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo set commentblock {} } Componant - Delegate { my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2] set commentblock {} } superclass { dict set info ancestors [lrange $thisline 1 end] set commentblock {} } classmethod - class_method - Class_Method { my keyword.Class_Method info $commentblock {*}[lrange $thisline 1 end-1] set commentblock {} } destructor - constructor { my keyword.method info $commentblock {*}[lrange $thisline 0 end-1] set commentblock {} } method - Ensemble { my keyword.method info $commentblock {*}[lrange $thisline 1 end-1] set commentblock {} } } set thisline {} } dict set result class $name $info } method keyword.Class_Method {resultvar commentblock name args} { upvar 1 $resultvar result set info [my comment $commentblock] if {[dict exists $info show_body] && [dict get $info show_body]} { dict set info internals [lindex $args end] } if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result Class_Method "${name} $method" $minfo } } else { switch [llength $args] { 1 { set argspec [lindex $args 0] } 0 { set argspec dictargs #set body [lindex $args 0] } default {error "could not interpret method $name {*}$args"} } if {![dict exists $info argspec]} { dict set info argspec [my argspec $argspec] } dict set result Class_Method [string trim $name :] $info } } method keyword.method {resultvar commentblock name args} { upvar 1 $resultvar result set info [my comment $commentblock] if {[dict exists $info show_body] && [dict get $info show_body]} { dict set info internals [lindex $args end] } if {[dict exists $info ensemble]} { dict for {method minfo} [dict get $info ensemble] { dict set result method "\"${name} $method\"" $minfo } } else { switch [llength $args] { 1 { set argspec [lindex $args 0] } 0 { set argspec dictargs #set body [lindex $args 0] } default {error "could not interpret method $name {*}$args"} } if {![dict exists $info argspec]} { dict set info argspec [my argspec $argspec] } dict set result method "\"[split [string trim $name :] ::]\"" $info } } method keyword.proc {commentblock name argspec} { set info [my comment $commentblock] if {![dict exists $info argspec]} { dict set info argspec [my argspec $argspec] } return $info } method reset {} { my variable coro set coro [info object namespace [self]]::coro oo::objdefine [self] forward coro $coro if {[info command $coro] ne {}} { rename $coro {} } coroutine $coro {*}[namespace code {my Main}] } method Main {} { my variable info set info [dict create] yield [info coroutine] set thisline {} set commentblock {} set linec 0 while 1 { set line [yield] append thisline $line \n if {![info complete $thisline]} continue set thisline [string trim $thisline] if {[string index $thisline 0] eq "#"} { append commentblock [string trimleft $thisline #] \n set thisline {} continue } set cmd [string trim [lindex $thisline 0] ":"] switch $cmd { dictargs::proc { set procinfo [my keyword.proc $commentblock [lindex $thisline 1] [list args [list dictargs [lindex $thisline 2]]]] if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} { dict set procinfo internals [lindex $thisline end] } dict set info proc [string trim [lindex $thisline 1] :] $procinfo set commentblock {} } tcllib::PROC - PROC - Proc - proc { set procinfo [my keyword.proc $commentblock {*}[lrange $thisline 1 2]] if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} { dict set procinfo internals [lindex $thisline end] } dict set info proc [string trim [lindex $thisline 1] :] $procinfo set commentblock {} } oo::objdefine { if {[llength $thisline]==3} { lassign $thisline tcmd name body my keyword.Class info $commentblock $name $body } else { puts "Warning: bare oo::define in library" } } oo::define { if {[llength $thisline]==3} { lassign $thisline tcmd name body my keyword.class info $commentblock $name $body } else { puts "Warning: bare oo::define in library" } } tao::define - clay::define - tool::define { lassign $thisline tcmd name body my keyword.class info $commentblock $name $body set commentblock {} } oo::class { lassign $thisline tcmd mthd name body my keyword.class info $commentblock $name $body set commentblock {} } default { if {[lindex [split $cmd ::] end] eq "define"} { lassign $thisline tcmd name body my keyword.class info $commentblock $name $body set commentblock {} } set commentblock {} } } set thisline {} } } method section.method {keyword method minfo} { set result {} set line "\[call $keyword \[cmd $method\]" if {[dict exists $minfo argspec]} { dict for {argname arginfo} [dict get $minfo argspec] { set positional 1 set mandatory 1 set repeating 0 dict with arginfo {} if {$mandatory==0} { append line " \[opt \"" } else { append line " " } if {$positional} { append line "\[arg $argname" } else { append line "\[option \"$argname" if {[dict exists $arginfo type]} { append line " \[emph [dict get $arginfo type]\]" } else { append line " \[emph value\]" } append line "\"" } append line "\]" if {$mandatory==0} { if {[dict exists $arginfo default]} { append line " \[const \"[dict get $arginfo default]\"\]" } append line "\"\]" } if {$repeating} { append line " \[opt \[option \"$argname...\"\]\]" } } } append line \] putb result $line if {[dict exists $minfo description]} { putb result [dict get $minfo description] } if {[dict exists $minfo example]} { putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]" } if {[dict exists $minfo internals]} { putb result "\[para\]Internals: \[example [list [dict get $minfo internals]]\]" } return $result } method section.annotation {type name iinfo} { set result "\[call $type \[cmd $name\]\]" if {[dict exists $iinfo description]} { putb result [dict get $iinfo description] } if {[dict exists $iinfo example]} { putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]" } return $result } method section.class {class_name class_info} { set result {} putb result "\[subsection \{Class $class_name\}\]" if {[dict exists $class_info ancestors]} { set line "\[emph \"ancestors\"\]:" foreach {c} [dict get $class_info ancestors] { append line " \[class [string trim $c :]\]" } putb result $line putb result {[para]} } dict for {f v} $class_info { if {$f in {Class_Method method description ancestors example option variable delegate}} continue putb result "\[emph \"$f\"\]: $v" putb result {[para]} } if {[dict exists $class_info example]} { putb result "\[example \{[list [dict get $class_info example]]\}\]" putb result {[para]} } if {[dict exists $class_info description]} { putb result [dict get $class_info description] putb result {[para]} } dict for {f v} $class_info { if {$f ni {option variable delegate}} continue putb result "\[class \{[string totitle $f]\}\]" #putb result "Methods on the class object itself." putb result {[list_begin definitions]} dict for {item iinfo} [dict get $class_info $f] { putb result [my section.annotation $f $item $iinfo] } putb result {[list_end]} putb result {[para]} } if {[dict exists $class_info Class_Method]} { putb result "\[class \{Class Methods\}\]" #putb result "Methods on the class object itself." putb result {[list_begin definitions]} dict for {method minfo} [dict get $class_info Class_Method] { putb result [my section.method classmethod $method $minfo] } putb result {[list_end]} putb result {[para]} } if {[dict exists $class_info method]} { putb result "\[class {Methods}\]" putb result {[list_begin definitions]} dict for {method minfo} [dict get $class_info method] { putb result [my section.method method $method $minfo] } putb result {[list_end]} putb result {[para]} } return $result } method section.command {procinfo} { set result {} putb result "\[section \{Commands\}\]" putb result {[list_begin definitions]} dict for {method minfo} $procinfo { putb result [my section.method proc $method $minfo] } putb result {[list_end]} return $result } method manpage args { my variable info set map {%version% 0.0 %module% {Your_Module_Here}} set result {} set header {} set footer {} set authors {} dict with args {} dict set map %keyword% comment putb result $map {[%keyword% {-*- tcl -*- doctools manpage}] [vset PACKAGE_VERSION %version%] [manpage_begin %module% n [vset PACKAGE_VERSION]]} putb result $map $header dict for {sec_type sec_info} $info { switch $sec_type { proc { putb result [my section.command $sec_info] } class { putb result "\[section Classes\]" dict for {class_name class_info} $sec_info { putb result [my section.class $class_name $class_info] } } default { putb result "\[section [list $sec_type $sec_name]\]" if {[dict exists $sec_info description]} { putb result [dict get $sec_info description] } } } } if {[llength $authors]} { putb result {[section AUTHORS]} foreach {name email} $authors { putb result "$name \[uri mailto:$email\]\[para\]" } } putb result $footer putb result {[manpage_end]} return $result } method scan_text {text} { my variable linecount coro set linecount 0 foreach line [split $text \n] { incr linecount $coro $line } } method scan_file {filename} { my variable linecount coro set fin [open $filename r] set linecount 0 while {[gets $fin line]>=0} { incr linecount $coro $line } close $fin } } ### # END: doctool.tcl ### ### # START: buildutil.tcl ### proc Proc {name arglist body} { if {[info command $name] ne {}} return proc $name $arglist $body } Proc ::noop args {} proc ::practcl::debug args { #puts $args ::practcl::cputs ::DEBUG_INFO $args } proc ::practcl::doexec args { puts [list {*}$args] exec {*}$args >&@ stdout } proc ::practcl::doexec_in {path args} { set PWD [pwd] cd $path puts [list {*}$args] exec {*}$args >&@ stdout cd $PWD } proc ::practcl::dotclexec args { puts [list [info nameofexecutable] {*}$args] exec [info nameofexecutable] {*}$args >&@ stdout } proc ::practcl::domake {path args} { set PWD [pwd] cd $path puts [list *** $path ***] puts [list make {*}$args] exec make {*}$args >&@ stdout cd $PWD } proc ::practcl::domake.tcl {path args} { set PWD [pwd] cd $path puts [list *** $path ***] puts [list make.tcl {*}$args] exec [info nameofexecutable] make.tcl {*}$args >&@ stdout cd $PWD } proc ::practcl::fossil {path args} { set PWD [pwd] cd $path puts [list {*}$args] exec fossil {*}$args >&@ stdout cd $PWD } proc ::practcl::fossil_status {dir} { if {[info exists ::fosdat($dir)]} { return $::fosdat($dir) } set result { tags experimental version {} |
︙ | ︙ | |||
192 193 194 195 196 197 198 | dict set result tags $tags break } } set ::fosdat($dir) $result return $result } | < > > > | > > > | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 | dict set result tags $tags break } } set ::fosdat($dir) $result return $result } proc ::practcl::os {} { return [${::practcl::MAIN} define get TEACUP_OS] } proc ::practcl::mkzip {exename barekit vfspath} { ::practcl::tcllib_require zipfile::mkzip ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath } proc ::practcl::sort_dict list { return [::lsort -stride 2 -dictionary $list] } if {[::package vcompare $::tcl_version 8.6] < 0} { # Approximate ::zipfile::mkzip with exec calls proc ::practcl::mkzip {exename barekit vfspath} { set path [file dirname [file normalize $exename]] set zipfile [file join $path [file rootname $exename].zip] file copy -force $barekit $exename set pwd [pwd] |
︙ | ︙ | |||
223 224 225 226 227 228 229 | proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } | < < < < | < < < < < | 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 | proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } } proc ::practcl::local_os {} { # If we have already run this command, return # a cached copy of the data if {[info exists ::practcl::LOCAL_INFO]} { return $::practcl::LOCAL_INFO } set result [array get ::practcl::CONFIG] |
︙ | ︙ | |||
372 373 374 375 376 377 378 | if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { dict set result fossil_mirror $::env(FOSSIL_MIRROR) } set ::practcl::LOCAL_INFO $result return $result } | < < < < < < | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 | if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} { dict set result fossil_mirror $::env(FOSSIL_MIRROR) } set ::practcl::LOCAL_INFO $result return $result } proc ::practcl::config.tcl {path} { return [read_configuration $path] } proc ::practcl::read_configuration {path} { dict set result buildpath $path set result [local_os] set OS [dict get $result TEACUP_OS] set windows 0 dict set result USEMSVC 0 if {[file exists [file join $path config.tcl]]} { |
︙ | ︙ | |||
422 423 424 425 426 427 428 | } dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] dict set result TEACUP_OS windows dict set result EXEEXT .exe } return $result } | < < < < < < < < < < | | < < < < < | 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 | } dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH] dict set result TEACUP_OS windows dict set result EXEEXT .exe } return $result } if {$::tcl_platform(platform) eq "windows"} { proc ::practcl::msys_to_tclpath msyspath { return [exec sh -c "cd $msyspath ; pwd -W"] } proc ::practcl::tcl_to_myspath tclpath { set path [file normalize $tclpath] return "/[string index $path 0][string range $path 2 end]" #return [exec sh -c "cd $tclpath ; pwd"] } } else { proc ::practcl::msys_to_tclpath msyspath { return [file normalize $msyspath] } proc ::practcl::tcl_to_myspath msyspath { return [file normalize $msyspath] } } proc ::practcl::tcllib_require {pkg args} { # Try to load the package from the local environment if {[catch [list ::package require $pkg {*}$args] err]==0} { return $err } ::practcl::LOCAL tool tcllib env-load uplevel #0 [list ::package require $pkg {*}$args] } namespace eval ::practcl::platform { } proc ::practcl::platform::tcl_core_options {os} { ### # Download our required packages ### set tcl_config_opts {} # Auto-guess options for the local operating system switch $os { windows { #lappend tcl_config_opts --disable-stubs } linux { } macosx { lappend tcl_config_opts --enable-corefoundation=yes --enable-framework=no } } lappend tcl_config_opts --with-tzdata return $tcl_config_opts } proc ::practcl::platform::tk_core_options {os} { ### # Download our required packages ### set tk_config_opts {} # Auto-guess options for the local operating system switch $os { windows { } linux { lappend tk_config_opts --enable-xft=no --enable-xss=no } macosx { lappend tk_config_opts --enable-aqua=yes } } return $tk_config_opts } proc ::practcl::read_rc_file {filename {localdat {}}} { set result $localdat set fin [open $filename r] set bufline {} set rawcount 0 set linecount 0 while {[gets $fin thisline]>=0} { |
︙ | ︙ | |||
524 525 526 527 528 529 530 | #set key [lindex $line 0] #set value [lindex $line 1] #dict set result $key $value } close $fin return $result } | < < < < < < < < < | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 | #set key [lindex $line 0] #set value [lindex $line 1] #dict set result $key $value } close $fin return $result } proc ::practcl::read_sh_subst {line info} { regsub -all {\x28} $line \x7B line regsub -all {\x29} $line \x7D line #set line [string map $key [string trim $line]] foreach {field value} $info { catch {set $field $value} } if [catch {subst $line} result] { return {} } set result [string trim $result] return [string trim $result '] } proc ::practcl::read_sh_file {filename {localdat {}}} { set fin [open $filename r] set result {} if {$localdat eq {}} { set top 1 set local [array get ::env] dict set local EXE {} |
︙ | ︙ | |||
593 594 595 596 597 598 599 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } | < < < < < | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } proc ::practcl::read_Config.sh filename { set fin [open $filename r] set result {} set linecount 0 while {[gets $fin line] >= 0} { set line [string trim $line] if {[string index $line 0] eq "#"} continue |
︙ | ︙ | |||
624 625 626 627 628 629 630 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } | < < < < < | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 | #puts $opts puts "Error reading line:\n$line\nerr: $err\n***" return $err {*}$opts } } return $result } proc ::practcl::read_Makefile filename { set fin [open $filename r] set result {} while {[gets $fin line] >= 0} { set line [string trim $line] if {[string index $line 0] eq "#"} continue if {$line eq {}} continue |
︙ | ︙ | |||
679 680 681 682 683 684 685 | # the Compile field is about where most TEA files start getting silly if {$field eq "compile"} { break } } return $result } | < < < < < < < < | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 | # the Compile field is about where most TEA files start getting silly if {$field eq "compile"} { break } } return $result } proc ::practcl::cputs {varname args} { upvar 1 $varname buffer if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { } if {[info exist buffer]} { if {[string index $buffer end] ne "\n"} { append buffer \n } } else { set buffer \n } # Trim leading \n's append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] } proc ::practcl::tcl_to_c {body} { set result {} foreach rawline [split $body \n] { set line [string map [list \" \\\" \\ \\\\] $rawline] cputs result "\n \"$line\\n\" \\" } return [string trimright $result \\] } proc ::practcl::_tagblock {text {style tcl} {note {}}} { if {[string length [string trim $text]]==0} { return {} } set output {} switch $style { tcl { |
︙ | ︙ | |||
740 741 742 743 744 745 746 | } default { ::practcl::cputs output "# END $note" } } return $output } | < | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 | } default { ::practcl::cputs output "# END $note" } } return $output } proc ::practcl::de_shell {data} { set values {} foreach flag {DEFS TCL_DEFS TK_DEFS} { if {[dict exists $data $flag]} { #set value {} #foreach item [dict get $data $flag] { # append value " " [string map {{ } {\ }} $item] |
︙ | ︙ | |||
799 800 801 802 803 804 805 | ### # END: buildutil.tcl ### ### # START: fileutil.tcl ### | < < < < < < < < < < < < < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | > > > > > > > > > | > > > > > > > > > > > > < < < | > > > > > > > > > > | | < > | > > > > > > | > > > | < > > > > > > > > > > | > | > > > > > > > > > > > | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 | ### # END: buildutil.tcl ### ### # START: fileutil.tcl ### proc ::practcl::grep {pattern {files {}}} { set result [list] if {[llength $files] == 0} { # read from stdin set lnum 0 while {[gets stdin line] >= 0} { incr lnum if {[regexp -- $pattern $line]} { lappend result "${lnum}:${line}" } } } else { foreach filename $files { set file [open $filename r] set lnum 0 while {[gets $file line] >= 0} { incr lnum if {[regexp -- $pattern $line]} { lappend result "${filename}:${lnum}:${line}" } } close $file } } return $result } proc ::practcl::file_lexnormalize {sp} { set spx [file split $sp] # Resolution of embedded relative modifiers (., and ..). if { ([lsearch -exact $spx . ] < 0) && ([lsearch -exact $spx ..] < 0) } { # Quick path out if there are no relative modifiers return $sp } set absolute [expr {![string equal [file pathtype $sp] relative]}] # A volumerelative path counts as absolute for our purposes. set sp $spx set np {} set noskip 1 while {[llength $sp]} { set ele [lindex $sp 0] set sp [lrange $sp 1 end] set islast [expr {[llength $sp] == 0}] if {[string equal $ele ".."]} { if { ($absolute && ([llength $np] > 1)) || (!$absolute && ([llength $np] >= 1)) } { # .. : Remove the previous element added to the # new path, if there actually is enough to remove. set np [lrange $np 0 end-1] } } elseif {[string equal $ele "."]} { # Ignore .'s, they stay at the current location continue } else { # A regular element. lappend np $ele } } if {[llength $np] > 0} { return [eval [linsert $np 0 file join]] # 8.5: return [file join {*}$np] } return {} } proc ::practcl::file_relative {base dst} { # Ensure that the link to directory 'dst' is properly done relative to # the directory 'base'. if {![string equal [file pathtype $base] [file pathtype $dst]]} { return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" } set base [file_lexnormalize [file join [pwd] $base]] set dst [file_lexnormalize [file join [pwd] $dst]] set save $dst set base [file split $base] set dst [file split $dst] while {[string equal [lindex $dst 0] [lindex $base 0]]} { set dst [lrange $dst 1 end] set base [lrange $base 1 end] if {![llength $dst]} {break} } set dstlen [llength $dst] set baselen [llength $base] if {($dstlen == 0) && ($baselen == 0)} { # Cases: # (a) base == dst set dst . } else { # Cases: # (b) base is: base/sub = sub # dst is: base = {} # (c) base is: base = {} # dst is: base/sub = sub while {$baselen > 0} { set dst [linsert $dst 0 ..] incr baselen -1 } # 8.5: set dst [file join {*}$dst] set dst [eval [linsert $dst 0 file join]] } return $dst } proc ::practcl::findByPattern {basedir patterns} { set queue $basedir set result {} while {[llength $queue]} { set item [lindex $queue 0] set queue [lrange $queue 1 end] if {[file isdirectory $item]} { foreach path [glob -nocomplain [file join $item *]] { lappend queue $path } continue } foreach pattern $patterns { set fname [file tail $item] if {[string match $pattern $fname]} { lappend result $item break } } } return $result } proc ::practcl::log {fname comment} { set fname [file normalize $fname] if {[info exists ::practcl::logchan($fname)]} { set fout $::practcl::logchan($fname) after cancel $::practcl::logevent($fname) } else { set fout [open $fname a] } puts $fout $comment # Defer close until idle set ::practcl::logevent($fname) [after idle "close $fout ; unset ::practcl::logchan($fname)"] } ### # END: fileutil.tcl ### ### # START: installutil.tcl ### proc ::practcl::_pkgindex_simpleIndex {path} { set buffer {} set pkgidxfile [file join $path pkgIndex.tcl] set modfile [file join $path [file tail $path].tcl] set use_pkgindex [file exists $pkgidxfile] set tclfiles {} set found 0 set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl] foreach file [glob -nocomplain [file join $path *.tcl]] { if {[file tail $file] ni $mlist} { puts [list NONMODFILE $file] return {} } } foreach file [glob -nocomplain [file join $path *.tcl]] { if { [file tail $file] == "version_info.tcl" } continue set fin [open $file r] set dat [read $fin] close $fin if {![regexp "package provide" $dat]} continue set fname [file rootname [file tail $file]] # Look for a package provide statement foreach line [split $dat \n] { set line [string trim $line] if { [string range $line 0 14] != "package provide" } continue set package [lindex $line 2] set version [lindex $line 3] if {[string index $package 0] in "\$ \[ @"} continue if {[string index $version 0] in "\$ \[ @"} continue puts "PKGLINE $line" append buffer "package ifneeded $package $version \[list source \[file join %DIR% [file tail $file]\]\]" \n break } } return $buffer } proc ::practcl::_pkgindex_directory {path} { set buffer {} set pkgidxfile [file join $path pkgIndex.tcl] set modfile [file join $path [file tail $path].tcl] set use_pkgindex [file exists $pkgidxfile] set tclfiles {} if {$use_pkgindex && [file exists $modfile]} { set use_pkgindex 0 set mlist [list pkgIndex.tcl [file tail $modfile]] foreach file [glob -nocomplain [file join $path *.tcl]] { lappend tclfiles [file tail $file] if {[file tail $file] in $mlist} continue incr use_pkgindex } } if {!$use_pkgindex} { # No pkgIndex file, read the source foreach file [glob -nocomplain $path/*.tm] { set file [file normalize $file] set fname [file rootname [file tail $file]] ### # We used to be able to ... Assume the package is correct in the filename # No hunt for a "package provides" |
︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 | } append buffer $thisline \n set thisline {} } if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} return $buffer } | < < < < < < | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 | } append buffer $thisline \n set thisline {} } if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]} return $buffer } proc ::practcl::_pkgindex_path_subdir {path} { set result {} if {[file exists [file join $path src build.tcl]]} { # Tool style module, don't dive into subdirectories return $path } foreach subpath [glob -nocomplain [file join $path *]] { if {[file isdirectory $subpath]} { if {[file tail $subpath] eq "build" && [file exists [file join $subpath build.tcl]]} continue lappend result $subpath {*}[_pkgindex_path_subdir $subpath] } } return $result } proc ::practcl::pkgindex_path {args} { set stack {} set buffer { lappend ::PATHSTACK $dir set IDXPATH [lindex $::PATHSTACK end] } set preindexed {} |
︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 | set path_indexed($path) 0 } } else { puts [list WARNING: NO PATHS FOUND IN $base] } set path_indexed($base) 1 set path_indexed([file join $base boot tcl]) 1 foreach path $paths { if {$path_indexed($path)} continue set thisdir [file_relative $base $path] set idxbuf [::practcl::_pkgindex_directory $path] if {[string length $idxbuf]} { incr path_indexed($path) append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n } } } append buffer { set dir [lindex $::PATHSTACK end] set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] } return $buffer } | > > > > > > > > > > > > > < | 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 | set path_indexed($path) 0 } } else { puts [list WARNING: NO PATHS FOUND IN $base] } set path_indexed($base) 1 set path_indexed([file join $base boot tcl]) 1 append buffer \n {# SINGLE FILE MODULES BEGIN} \n {set dir [lindex $::PATHSTACK end]} \n foreach path $paths { if {$path_indexed($path)} continue set thisdir [file_relative $base $path] set simpleIdx [_pkgindex_simpleIndex $path] if {[string length $simpleIdx]==0} continue incr path_indexed($path) if {[string length $simpleIdx]} { incr path_indexed($path) append buffer [string map [list %DIR% "\$dir \{$thisdir\}"] [string trimright $simpleIdx]] \n } } append buffer {# SINGLE FILE MODULES END} \n foreach path $paths { if {$path_indexed($path)} continue set thisdir [file_relative $base $path] set idxbuf [::practcl::_pkgindex_directory $path] if {[string length $idxbuf]} { incr path_indexed($path) append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n } } } append buffer { set dir [lindex $::PATHSTACK end] set ::PATHSTACK [lrange $::PATHSTACK 0 end-1] } return $buffer } proc ::practcl::installDir {d1 d2} { puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]] file delete -force -- $d2 file mkdir $d2 foreach ftail [glob -directory $d1 -nocomplain -tails *] { set f [file join $d1 $ftail] |
︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | if {$::tcl_platform(platform) eq {unix}} { file attributes $d2 -permissions 0755 } else { file attributes $d2 -readonly 1 } } | < | 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 | if {$::tcl_platform(platform) eq {unix}} { file attributes $d2 -permissions 0755 } else { file attributes $d2 -readonly 1 } } proc ::practcl::copyDir {d1 d2 {toplevel 1}} { #if {$toplevel} { # puts [list ::practcl::copyDir $d1 -> $d2] #} #file delete -force -- $d2 file mkdir $d2 if {[file isfile $d1]} { |
︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 | } else { file attributes [file join $d2 $ftail] -readonly 1 } } } } } ### # END: installutil.tcl ### ### # START: makeutil.tcl ### | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < > | < < < | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 | } else { file attributes [file join $d2 $ftail] -readonly 1 } } } } } proc ::practcl::buildModule {modpath} { set buildscript [file join $modpath build build.tcl] if {![file exists $buildscript]} return set pkgIndexFile [file join $modpath pkgIndex.tcl] if {[file exists $pkgIndexFile]} { set latest 0 foreach file [::practcl::findByPattern [file dirname $buildscript] *.tcl] { set mtime [file mtime $file] if {$mtime>$latest} { set latest $mtime } } set IdxTime [file mtime $pkgIndexFile] if {$latest<$IdxTime} return } ::practcl::dotclexec $buildscript } proc ::practcl::installModule {modpath DEST} { set dpath [file join $DEST modules [file tail $modpath]] puts [list ::practcl::installModule $modpath -> $dpath] if {[file exists [file join $modpath index.tcl]]} { # IRM/Tao style modules non-amalgamated ::practcl::installDir $modpath $dpath return } if {[file exists [file join $modpath build build.tcl]]} { buildModule $modpath } set files [glob -nocomplain [file join $modpath *.tcl]] if {[llength $files]} { if {[llength $files]>1} { if {![file exists [file join $modpath pkgIndex.tcl]]} { pkg_mkIndex $modpath } } file delete -force $dpath file mkdir $dpath foreach file $files { file copy $file $dpath } } if {[file exists [file join $modpath htdocs]]} { ::practcl::copyDir [file join $modpath htdocs] [file join $dpath htdocs] } } ### # END: installutil.tcl ### ### # START: makeutil.tcl ### proc ::practcl::trigger {args} { ::practcl::LOCAL make trigger {*}$args foreach {name obj} [::practcl::LOCAL make objects] { set ::make($name) [$obj do] } } proc ::practcl::depends {args} { ::practcl::LOCAL make depends {*}$args } proc ::practcl::target {name info {action {}}} { set obj [::practcl::LOCAL make task $name $info $action] set ::make($name) 0 set filename [$obj define get filename] if {$filename ne {}} { set ::target($name) $filename } } ### # END: makeutil.tcl ### ### # START: class metaclass.tcl ### ::clay::define ::practcl::metaclass { method _MorphPatterns {} { return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}} } method define {submethod args} { my variable define switch $submethod { dump { return [array get define] } add { |
︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 | } } default { array $submethod define {*}$args } } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 | } } default { array $submethod define {*}$args } } } method graft args { return [my clay delegate {*}$args] } method initialize {} {} method link {command args} { my variable links switch $command { object { foreach obj $args { foreach linktype [$obj linktype] { my link add $linktype $obj |
︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 | return $links($linktype) } dump { return [array get links] } } } | < | 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 | return $links($linktype) } dump { return [array get links] } } } method morph classname { my variable define if {$classname ne {}} { set map [list @name@ $classname] foreach pattern [string map $map [my _MorphPatterns]] { set pattern [string trim $pattern] set matches [info commands $pattern] |
︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 | } { if {[string match $pattern $class]} { set mixinslot $slot break } } if {$mixinslot ne {}} { | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 | } { if {[string match $pattern $class]} { set mixinslot $slot break } } if {$mixinslot ne {}} { my clay mixinmap $mixinslot $class } elseif {[info command $class] ne {}} { if {[info object class [self]] ne $class} { ::oo::objdefine [self] class $class ::practcl::debug [self] morph $class my define set class $class } } else { error "[self] Could not detect class for $classname" } } if {[::info exists define(oodefine)]} { ::oo::objdefine [self] $define(oodefine) #unset define(oodefine) } } method script script { eval $script } method select {} { my variable define if {[info exists define(class)]} { my morph $define(class) } else { if {[::info exists define(oodefine)]} { ::oo::objdefine [self] $define(oodefine) #unset define(oodefine) } } } method source filename { source $filename } } ### # END: class metaclass.tcl ### ### # START: class toolset baseclass.tcl ### ::clay::define ::practcl::toolset { method config.sh {} { return [my read_configuration] } method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } method MakeDir {srcdir} { return $srcdir } method read_configuration {} { my variable conf_result if {[info exists conf_result]} { return $conf_result } set result {} set name [my define get name] |
︙ | ︙ | |||
1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 | } set conf_result $result return $result } ### # Oh man... we have to guess ### set filename [file join $builddir Makefile] if {![file exists $filename]} { error "Could not locate any configuration data in $srcdir" } foreach {field dat} [::practcl::read_Makefile $filename] { dict set result $field $dat } if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} { dict set result PRACTCL_PKG_LIBS [dict get $result LIBS] } set conf_result $result cd $PWD return $result } | > > > < < < < < < < < | 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 | } set conf_result $result return $result } ### # Oh man... we have to guess ### if {![file exists [file join $builddir Makefile]]} { my Configure } set filename [file join $builddir Makefile] if {![file exists $filename]} { error "Could not locate any configuration data in $srcdir" } foreach {field dat} [::practcl::read_Makefile $filename] { dict set result $field $dat } if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} { dict set result PRACTCL_PKG_LIBS [dict get $result LIBS] } set conf_result $result cd $PWD return $result } method build-cflags {PROJECT DEFS namevar versionvar defsvar} { upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]] set NAME [string toupper $name] set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]] if {$version eq {}} { set version 0.1a |
︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 | set defs "$predef $postdef" } } append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" return $defs } | < | < < < < | < | | | < | < > | < < | 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 | set defs "$predef $postdef" } } append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\"" append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\"" return $defs } method critcl args { if {![info exists critcl]} { ::practcl::LOCAL tool critcl env-load set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl } set srcdir [my SourceRoot] set PWD [pwd] cd $srcdir ::practcl::dotclexec $critcl {*}$args cd $PWD } } oo::objdefine ::practcl::toolset { # Perform the selection for the toolset mixin method select object { ### # Select the toolset to use for this project ### if {[$object define exists toolset]} { return [$object define get toolset] } set class [$object define get toolset] if {$class ne {}} { $object clay mixinmap toolset $class } else { if {[info exists ::env(VisualStudioVersion)]} { $object clay mixinmap toolset ::practcl::toolset.msvc } else { $object clay mixinmap toolset ::practcl::toolset.gcc } } } } ### # END: class toolset baseclass.tcl ### ### # START: class toolset gcc.tcl ### ::clay::define ::practcl::toolset.gcc { superclass ::practcl::toolset method Autoconf {} { ### # Re-run autoconf for this project # Not a good idea in practice... but in the right hands it can be useful ### set pwd [pwd] set srcdir [file normalize [my define get srcdir]] set localsrcdir [my MakeDir $srcdir] cd $localsrcdir foreach template {configure.ac configure.in} { set input [file join $srcdir $template] if {[file exists $input]} { puts "autoconf -f $input > [file join $srcdir configure]" exec autoconf -f $input > [file join $srcdir configure] } } cd $pwd } method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } method ConfigureOpts {} { set opts {} set builddir [my define get builddir] if {[my define get broken_destroot 0]} { set PREFIX [my <project> define get prefix_broken_destdir] } else { |
︙ | ︙ | |||
1791 1792 1793 1794 1795 1796 1797 | } } if {[my <project> define get CONFIG_SITE] != {}} { lappend opts --host=[my <project> define get HOST] } set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]] lappend opts --with-tclsh=[info nameofexecutable] | > > | | | | | | | | | < > > > > > > > > > | > > | | | 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 | } } if {[my <project> define get CONFIG_SITE] != {}} { lappend opts --host=[my <project> define get HOST] } set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]] lappend opts --with-tclsh=[info nameofexecutable] if {[my define get tk 0]} { if {![my <project> define get LOCAL 0]} { set obj [my <project> tclcore] if {$obj ne {}} { if {$inside_msys} { lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] } else { lappend opts --with-tcl=[file normalize [$obj define get builddir]] } } set obj [my <project> tkcore] if {$obj ne {}} { if {$inside_msys} { lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] } else { lappend opts --with-tk=[file normalize [$obj define get builddir]] } } } else { lappend opts --with-tcl=[file join $PREFIX lib] lappend opts --with-tk=[file join $PREFIX lib] } } else { if {![my <project> define get LOCAL 0]} { set obj [my <project> tclcore] if {$obj ne {}} { if {$inside_msys} { lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]] } else { lappend opts --with-tcl=[file normalize [$obj define get builddir]] } } } else { lappend opts --with-tcl=[file join $PREFIX lib] } } lappend opts {*}[my define get config_opts] if {![regexp -- "--prefix" $opts]} { lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX } if {[my define get debug 0]} { |
︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 | #--disable-stubs # } else { lappend opts --enable-shared } return $opts } | < < > > > > > < | | > > > | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 | #--disable-stubs # } else { lappend opts --enable-shared } return $opts } method MakeDir {srcdir} { set localsrcdir $srcdir if {[file exists [file join $srcdir generic]]} { my define add include_dir [file join $srcdir generic] } set os [my <project> define get TEACUP_OS] switch $os { windows { if {[file exists [file join $srcdir win]]} { my define add include_dir [file join $srcdir win] } if {[file exists [file join $srcdir win Makefile.in]]} { set localsrcdir [file join $srcdir win] } } macosx { if {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } default { if {[file exists [file join $srcdir $os]]} { my define add include_dir [file join $srcdir $os] } if {[file exists [file join $srcdir unix]]} { my define add include_dir [file join $srcdir unix] } if {[file exists [file join $srcdir $os Makefile.in]]} { set localsrcdir [file join $srcdir $os] } elseif {[file exists [file join $srcdir unix Makefile.in]]} { set localsrcdir [file join $srcdir unix] } } } return $localsrcdir } Ensemble make::autodetect {} { set srcdir [my define get srcdir] set localsrcdir [my MakeDir $srcdir] if {$localsrcdir eq {}} { set localsrcdir $srcdir } if {$srcdir eq $localsrcdir} { if {![file exists [file join $srcdir tclconfig install-sh]]} { # ensure we have tclconfig with all of the trimmings set teapath {} if {[file exists [file join $srcdir .. tclconfig install-sh]]} { set teapath [file join $srcdir .. tclconfig] } else { |
︙ | ︙ | |||
1914 1915 1916 1917 1918 1919 1920 | cd $builddir if {[my <project> define get CONFIG_SITE] ne {}} { set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] } catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} cd $::CWD } | < | < | | 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 | cd $builddir if {[my <project> define get CONFIG_SITE] ne {}} { set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE] } catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]} cd $::CWD } Ensemble make::clean {} { set builddir [file normalize [my define get builddir]] catch {::practcl::domake $builddir clean} } Ensemble make::compile {} { set name [my define get name] set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } |
︙ | ︙ | |||
1944 1945 1946 1947 1948 1949 1950 | } else { ::practcl::domake.tcl $builddir all } } else { ::practcl::domake $builddir all } } | < | | 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 | } else { ::practcl::domake.tcl $builddir all } } else { ::practcl::domake $builddir all } } Ensemble make::install DEST { set PWD [pwd] set builddir [my define get builddir] if {[my <project> define get LOCAL 0] || $DEST eq {}} { if {[file exists [file join $builddir make.tcl]]} { puts "[self] Local INSTALL (Practcl)" ::practcl::domake.tcl $builddir install } elseif {[my define get broken_destroot 0] == 0} { |
︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 | ::practcl::domake $builddir $install ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] file delete -force $BROKENROOT } } cd $PWD } | < | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 | ::practcl::domake $builddir $install ::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]] file delete -force $BROKENROOT } } cd $PWD } method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} { set objext [my define get OBJEXT o] set EXTERN_OBJS {} set OBJECTS {} set result {} set builddir [$PROJECT define get builddir] file mkdir [file join $builddir objs] |
︙ | ︙ | |||
2077 2078 2079 2080 2081 2082 2083 | continue } error "Failed to produce $filename" } } return $result } | < | 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 | continue } error "Failed to produce $filename" } } return $result } method build-Makefile {path PROJECT} { array set proj [$PROJECT define dump] set path $proj(builddir) cd $path set includedir . set objext [my define get OBJEXT o] |
︙ | ︙ | |||
2169 2170 2171 2172 2173 2174 2175 | $PROJECT define set static_library $outfile dict set map %OUTFILE% $outfile ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" ::practcl::cputs result {} return $result } | < < < < > > > > > > > > > > > > > > > > | 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 | $PROJECT define set static_library $outfile dict set map %OUTFILE% $outfile ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)" ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]" ::practcl::cputs result {} return $result } method build-library {outfile PROJECT} { array set proj [$PROJECT define dump] set path $proj(builddir) cd $path set includedir . #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]] if {[$PROJECT define get TEA_PRIVATE_TCL_HEADERS 0]} { if {[$PROJECT define get TEA_PLATFORM] eq "windows"} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]] } else { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]] } } lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]] if {[$PROJECT define get tk 0]} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]] lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]] if {[$PROJECT define get TEA_PRIVATE_TK_HEADERS 0]} { if {[$PROJECT define get TEA_PLATFORM] eq "windows"} { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]] } else { lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]] } } lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]] } foreach include [$PROJECT toolset-include-directory] { set cpath [::practcl::file_relative $path [file normalize $include]] if {$cpath ni $includedir} { lappend includedir $cpath } |
︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 | exec {*}$cmd >&@ stdout } set ranlib [$PROJECT define get RANLIB] if {$ranlib ni {{} :}} { catch {exec $ranlib $outfile} } } | > > > > > > > > > > > > > > | < | < < | > > > > > | < | | < < < < < < < < < | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 | exec {*}$cmd >&@ stdout } set ranlib [$PROJECT define get RANLIB] if {$ranlib ni {{} :}} { catch {exec $ranlib $outfile} } } method build-tclsh {outfile PROJECT {path {auto}}} { if {[my define get tk 0] && [my define get static_tk 0]} { puts " BUILDING STATIC TCL/TK EXE $PROJECT" set TKOBJ [$PROJECT tkcore] if {[info command $TKOBJ] eq {}} { set TKOBJ ::noop $PROJECT define set static_tk 0 } else { ::practcl::toolset select $TKOBJ array set TK [$TKOBJ read_configuration] set do_tk [$TKOBJ define get static] $PROJECT define set static_tk $do_tk $PROJECT define set tk $do_tk set TKSRCDIR [$TKOBJ define get srcdir] } } else { puts " BUILDING STATIC TCL EXE $PROJECT" set TKOBJ ::noop my define set static_tk 0 } set TCLOBJ [$PROJECT tclcore] ::practcl::toolset select $TCLOBJ set PKG_OBJS {} foreach item [$PROJECT link list core.library] { if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } foreach item [$PROJECT link list package] { if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } array set TCL [$TCLOBJ read_configuration] if {$path in {{} auto}} { set path [file dirname [file normalize $outfile]] } if {$path eq "."} { set path [pwd] } cd $path ### # For a static Tcl shell, we need to build all local sources # with the same DEFS flags as the tcl core was compiled with. # The DEFS produced by a TEA extension aren't intended to operate # with the internals of a staticly linked Tcl ### |
︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 | append COMPILE " " $defs lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES] set TCLSRC [file normalize $TCLSRCDIR] if {[${PROJECT} define get TEACUP_OS] eq "windows"} { set windres [$PROJECT define get RC windres] | | > > > > | > > > > > > | 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 | append COMPILE " " $defs lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES] set TCLSRC [file normalize $TCLSRCDIR] if {[${PROJECT} define get TEACUP_OS] eq "windows"} { set windres [$PROJECT define get RC windres] set RSOBJ [file join $path objs tclkit.res.o] set RCSRC [${PROJECT} define get kit_resource_file] set RCMAN [${PROJECT} define get kit_manifest_file] set RCICO [${PROJECT} define get kit_icon_file] set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]] if {[$PROJECT define get static_tk]} { if {$RCSRC eq {} || ![file exists $RCSRC]} { set RCSRC [file join $TKSRCDIR win rc wish.rc] } if {$RCMAN eq {} || ![file exists $RCMAN]} { set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest] } if {$RCICO eq {} || ![file exists $RCICO]} { set RCICO [file join $TKSRCDIR win rc wish.ico] } set TKSRC [file normalize $TKSRCDIR] lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \ --include [::practcl::file_relative $path [file join $TKSRC win]] \ --include [::practcl::file_relative $path [file join $TKSRC win rc]] } else { if {$RCSRC eq {} || ![file exists $RCSRC]} { set RCSRC [file join $TCLSRCDIR win tclsh.rc] } if {$RCMAN eq {} || ![file exists $RCMAN]} { set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest] } if {$RCICO eq {} || ![file exists $RCICO]} { set RCICO [file join $TCLSRCDIR win tclsh.ico] } } foreach item [${PROJECT} define get resource_include] { lappend cmd --include [::practcl::file_relative $path [file normalize $item]] } lappend cmd [file tail $RCSRC] if {![file exists [file join $path [file tail $RCSRC]]]} { file copy -force $RCSRC [file join $path [file tail $RCSRC]] } if {![file exists [file join $path [file tail $RCMAN]]]} { file copy -force $RCMAN [file join $path [file tail $RCMAN]] } if {![file exists [file join $path [file tail $RCICO]]]} { file copy -force $RCICO [file join $path [file tail $RCICO]] } ::practcl::doexec {*}$cmd lappend OBJECTS $RSOBJ } puts "***" set cmd "$TCL(cc)" if {$debug} { append cmd " $TCL(cflags_debug)" |
︙ | ︙ | |||
2469 2470 2471 2472 2473 2474 2475 | set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} append cmd " $LDFLAGS_CONSOLE" } puts "LINK: $cmd" exec {*}[string map [list "\n" " " " " " "] $cmd] >&@ stdout } | < | < < < < < | < | < | | 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 | set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc} set LDFLAGS_WINDOW {-mwindows -pipe -static-libgcc} append cmd " $LDFLAGS_CONSOLE" } puts "LINK: $cmd" exec {*}[string map [list "\n" " " " " " "] $cmd] >&@ stdout } } ### # END: class toolset gcc.tcl ### ### # START: class toolset msvc.tcl ### ::clay::define ::practcl::toolset.msvc { superclass ::practcl::toolset method BuildDir {PWD} { set srcdir [my define get srcdir] return $srcdir } Ensemble make::autodetect {} { } Ensemble make::clean {} { set PWD [pwd] set srcdir [my define get srcdir] cd $srcdir catch {::practcl::doexec nmake -f makefile.vc clean} cd $PWD } Ensemble make::compile {} { set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } cd $srcdir |
︙ | ︙ | |||
2525 2526 2527 2528 2529 2530 2531 | cd [file join $srcdir win] ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release } else { error "No make.tcl or makefile.vc found for project $name" } } } | < | | 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 | cd [file join $srcdir win] ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release } else { error "No make.tcl or makefile.vc found for project $name" } } } Ensemble make::install DEST { set PWD [pwd] set srcdir [my define get srcdir] cd $srcdir if {$DEST eq {}} { error "No destination given" } if {[my <project> define get LOCAL 0] || $DEST eq {}} { |
︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 | } else { puts "[self] VFS INSTALL $DEST" ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install } } cd $PWD } | < < < | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 | } else { puts "[self] VFS INSTALL $DEST" ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install } } cd $PWD } method MakeDir {srcdir} { set localsrcdir $srcdir if {[file exists [file join $srcdir generic]]} { my define add include_dir [file join $srcdir generic] } if {[file exists [file join $srcdir win]]} { my define add include_dir [file join $srcdir win] } if {[file exists [file join $srcdir makefile.vc]]} { set localsrcdir [file join $srcdir win] } return $localsrcdir } method NmakeOpts {} { set opts {} set builddir [file normalize [my define get builddir]] if {[my <project> define exists tclsrcdir]} { ### # On Windows we are probably running under MSYS, which doesn't deal with |
︙ | ︙ | |||
2600 2601 2602 2603 2604 2605 2606 | ### # END: class toolset msvc.tcl ### ### # START: class target.tcl ### | < | < < < | 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 | ### # END: class toolset msvc.tcl ### ### # START: class target.tcl ### ::clay::define ::practcl::make_obj { superclass ::practcl::metaclass constructor {module_object name info {action_body {}}} { my variable define triggered domake set triggered 0 set domake 0 set define(name) $name set define(action) {} array set define $info my select my initialize foreach {stub obj} [$module_object child organs] { my graft $stub $obj } if {$action_body ne {}} { set define(action) $action_body } } method do {} { my variable domake return $domake } method check {} { my variable needs_make domake if {$domake} { return 1 } if {[info exists needs_make]} { return $needs_make |
︙ | ︙ | |||
2656 2657 2658 2659 2660 2661 2662 | if {$filename ne {} && ![file exists $filename]} { set needs_make 1 } } } return $needs_make } | < < < | 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 | if {$filename ne {} && ![file exists $filename]} { set needs_make 1 } } } return $needs_make } method output {} { set result {} set filename [my define get filename] if {$filename ne {}} { lappend result $filename } foreach filename [my define get files] { if {$filename ne {}} { lappend result $filename } } return $result } method reset {} { my variable triggered domake needs_make set triggerd 0 set domake 0 set needs_make 0 } method triggers {} { my variable triggered domake define if {$triggered} { return $domake } set triggered 1 set make_objects [my <module> make objects] |
︙ | ︙ | |||
2710 2711 2712 2713 2714 2715 2716 | ### # END: class target.tcl ### ### # START: class object.tcl ### | | < | < < < < < < < < | < < < < < < < < < < < | 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 | ### # END: class target.tcl ### ### # START: class object.tcl ### ::clay::define ::practcl::object { superclass ::practcl::metaclass constructor {parent args} { my variable links define set organs [$parent child organs] my clay delegate {*}$organs array set define $organs array set define [$parent child define] array set links {} if {[llength $args]==1 && [file exists [lindex $args 0]]} { my define set filename [lindex $args 0] ::practcl::product select [self] } elseif {[llength $args] == 1} { set data [uplevel 1 [list subst [lindex $args 0]]] array set define $data my select } else { array set define [uplevel 1 [list subst $args]] my select } my initialize } method child {method} { return {} } method go {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable links foreach {linktype objs} [array get links] { foreach obj $objs { $obj go } } ::practcl::debug [list /[self] [self method] [self class]] } } ### # END: class object.tcl ### ### # START: class dynamic.tcl ### ::clay::define ::practcl::dynamic { method cstructure {name definition {argdat {}}} { my variable cstruct dict set cstruct $name body $definition foreach {f v} $argdat { dict set cstruct $name $f $v } if {![dict exists $cstruct $name public]} { dict set cstruct $name public 1 } } method include header { my define add include $header } method include_dir args { my define add include_dir {*}$args } method include_directory args { my define add include_dir {*}$args } method c_header body { my variable code ::practcl::cputs code(header) $body } method c_code body { my variable code ::practcl::cputs code(funct) $body } method c_function {header body {info {}}} { set header [string map "\t \ \n \ \ \ \ " $header] my variable code cfunct foreach regexp { {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)} } { |
︙ | ︙ | |||
2849 2850 2851 2852 2853 2854 2855 | } puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body" ::practcl::cputs code(header) "$header\;" # Could not parse that block as a function # append it verbatim to our c_implementation ::practcl::cputs code(funct) "$header [list $body]" } | < < < < < < < < | 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 | } puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body" ::practcl::cputs code(header) "$header\;" # Could not parse that block as a function # append it verbatim to our c_implementation ::practcl::cputs code(funct) "$header [list $body]" } method c_tcloomethod {name body {arginfo {}}} { my variable methods code foreach {f v} $arginfo { dict set methods $name $f $v } dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ $body" } method cmethod {name body {arginfo {}}} { my variable methods code foreach {f v} $arginfo { dict set methods $name $f $v } dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */ $body" } method c_tclproc_nspace nspace { my variable code if {![info exists code(nspace)]} { set code(nspace) {} } if {$nspace ni $code(nspace)} { lappend code(nspace) $nspace } } method c_tclcmd {name body {arginfo {}}} { my variable tclprocs code foreach {f v} $arginfo { dict set tclprocs $name $f $v } dict set tclprocs $name body $body } method c_tclproc_raw {name body {arginfo {}}} { my variable tclprocs code foreach {f v} $arginfo { dict set tclprocs $name $f $v } dict set tclprocs $name body $body } method tcltype {name argdat} { my variable tcltype foreach {f v} $argdat { dict set tcltype $name $f $v } if {![dict exists tcltype $name cname]} { dict set tcltype $name cname [string tolower $name]_tclobjtype |
︙ | ︙ | |||
2928 2929 2930 2931 2932 2933 2934 | # We were given a function name to call if {[llength $body] eq 1} continue set fname [string map [list @Name@ [string totitle $name]] $fpat] my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] dict set tcltype $name $func $fname } } | < < < < < < | 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 | # We were given a function name to call if {[llength $body] eq 1} continue set fname [string map [list @Name@ [string totitle $name]] $fpat] my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body] dict set tcltype $name $func $fname } } method project-compile-products {} { set filename [my define get output_c] set result {} if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { |
︙ | ︙ | |||
2965 2966 2967 2968 2969 2970 2971 | } } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } | < < < < < < < < < < < | 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 | } } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } method implement path { my go my Collate_Source $path if {[my define get output_c] eq {}} return set filename [file join $path [my define get output_c]] ::practcl::debug [self] [my define get filename] WANTS TO GENERATE $filename my define set cfile $filename set fout [open $filename w] puts $fout [my generate-c] if {[my define get initfunc] ne {}} { puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B" puts $fout [my generate-loader-module] if {[my define get pkg_name] ne {}} { puts $fout " Tcl_PkgProvide(interp, \"[my define get pkg_name]\", \"[my define get pkg_vers]\");" } puts $fout " return TCL_OK\;" puts $fout "\x7D" } close $fout } method initialize {} { set filename [my define get filename] if {$filename eq {}} { return } if {[my define get name] eq {}} { my define set name [file tail [file rootname $filename]] } if {[my define get localpath] eq {}} { my define set localpath [my <module> define get localpath]_[my define get name] } ::source $filename } method linktype {} { return {subordinate product dynamic} } method generate-cfile-constant {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code cstruct methods tcltype if {[info exists code(constant)]} { ::practcl::cputs result "/* [my define get filename] CONSTANT */" ::practcl::cputs result $code(constant) |
︙ | ︙ | |||
3096 3097 3098 3099 3100 3101 3102 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-constant] } return $result } | < | 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-constant] } return $result } method generate-cfile-header {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct cstruct methods tcltype tclprocs set result {} if {[info exists code(header)]} { ::practcl::cputs result $code(header) } |
︙ | ︙ | |||
3142 3143 3144 3145 3146 3147 3148 | ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" } } return $result } | < < < < < | 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 | ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" } } return $result } method generate-cfile-tclapi {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code methods tclprocs set result {} if {[info exists code(method)]} { ::practcl::cputs result $code(method) } |
︙ | ︙ | |||
3236 3237 3238 3239 3240 3241 3242 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-tclapi] } return $result } | < < < < < | 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 | foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-tclapi] } return $result } method generate-loader-module {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code methods tclprocs if {[info exists code(nspace)]} { ::practcl::cputs result " \{\n Tcl_Namespace *modPtr;" foreach nspace $code(nspace) { |
︙ | ︙ | |||
3303 3304 3305 3306 3307 3308 3309 | ::practcl::cputs result [$obj generate-loader-external] } else { ::practcl::cputs result [$obj generate-loader-module] } } return $result } | < | 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 | ::practcl::cputs result [$obj generate-loader-external] } else { ::practcl::cputs result [$obj generate-loader-module] } } return $result } method Collate_Source CWD { my variable methods code cstruct tclprocs if {[info exists methods]} { ::practcl::debug [self] methods [my define get cclass] set thisclass [my define get cclass] foreach {name info} $methods { # Provide a callproc |
︙ | ︙ | |||
3346 3347 3348 3349 3350 3351 3352 | } if {[dict exists $info body] && ![dict exists $info header]} { dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" } } } } | < < < < | < < < < | < < < < < < < < < < < < < | 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 | } if {[dict exists $info body] && ![dict exists $info header]} { dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])" } } } } method select {} {} } ### # END: class dynamic.tcl ### ### # START: class product.tcl ### ::clay::define ::practcl::product { method code {section body} { my variable code ::practcl::cputs code($section) $body } method Collate_Source CWD {} method project-compile-products {} { set result {} noop { set filename [my define get filename] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { set ofile [my define get ofile] } else { set ofile [my Ofile $filename] my define set ofile $ofile } lappend result $ofile [list cfile $filename include [my define get include] extra [my define get extra] external [string is true -strict [my define get external]] object [self]] } } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } method generate-debug {{spaces {}}} { set result {} ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]" foreach item [my link list subordinate] { practcl::cputs result [$item generate-debug "$spaces "] } return $result } method generate-cfile-constant {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code cstruct methods tcltype if {[info exists code(constant)]} { ::practcl::cputs result "/* [my define get filename] CONSTANT */" ::practcl::cputs result $code(constant) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-constant] } return $result } method generate-cfile-public-structure {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct methods tcltype set result {} if {[info exists code(struct)]} { ::practcl::cputs result $code(struct) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-public-structure] } return $result } method generate-cfile-header {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct cstruct methods tcltype tclprocs set result {} if {[info exists code(header)]} { ::practcl::cputs result $code(header) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue set dat [$obj generate-cfile-header] if {[string length [string trim $dat]]} { ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */" } } return $result } method generate-cfile-global {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct cstruct methods tcltype tclprocs set result {} if {[info exists code(global)]} { ::practcl::cputs result $code(global) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue set dat [$obj generate-cfile-global] if {[string length [string trim $dat]]} { ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-global */" ::practcl::cputs result $dat ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-global */" } } return $result } method generate-cfile-private-typedef {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(private-typedef)]} { ::practcl::cputs result $code(private-typedef) } |
︙ | ︙ | |||
3502 3503 3504 3505 3506 3507 3508 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-typedef] } return $result } | < | 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-typedef] } return $result } method generate-cfile-private-structure {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(private-structure)]} { ::practcl::cputs result $code(private-structure) } |
︙ | ︙ | |||
3525 3526 3527 3528 3529 3530 3531 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-structure] } return $result } | < < < < < < | 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-cfile-private-structure] } return $result } method generate-cfile-functions {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct set result {} if {[info exists code(funct)]} { ::practcl::cputs result $code(funct) } |
︙ | ︙ | |||
3557 3558 3559 3560 3561 3562 3563 | if {[$obj define get output_c] ne {}} { continue } ::practcl::cputs result [$obj generate-cfile-functions] } return $result } | < < < < < < < < < | 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 | if {[$obj define get output_c] ne {}} { continue } ::practcl::cputs result [$obj generate-cfile-functions] } return $result } method generate-cfile-tclapi {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code methods tclprocs set result {} if {[info exists code(method)]} { ::practcl::cputs result $code(method) } foreach obj [my link list product] { # Exclude products that will generate their own C files if {[$obj define get output_c] ne {}} continue ::practcl::cputs result [$obj generate-cfile-tclapi] } return $result } method generate-hfile-public-define {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code set result {} if {[info exists code(public-define)]} { ::practcl::cputs result $code(public-define) } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-define] } return $result } method generate-hfile-public-macro {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code set result {} if {[info exists code(public-macro)]} { ::practcl::cputs result $code(public-macro) } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-macro] } return $result } method generate-hfile-public-typedef {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(public-typedef)]} { ::practcl::cputs result $code(public-typedef) } |
︙ | ︙ | |||
3631 3632 3633 3634 3635 3636 3637 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-typedef] } return $result } | < | 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-typedef] } return $result } method generate-hfile-public-structure {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cstruct set result {} if {[info exists code(public-structure)]} { ::practcl::cputs result $code(public-structure) } |
︙ | ︙ | |||
3654 3655 3656 3657 3658 3659 3660 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-structure] } return $result } | < | 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-structure] } return $result } method generate-hfile-public-headers {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code tcltype set result {} if {[info exists code(public-header)]} { ::practcl::cputs result $code(public-header) } |
︙ | ︙ | |||
3682 3683 3684 3685 3686 3687 3688 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-headers] } return $result } | < < < < < < < < < | 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 | } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-headers] } return $result } method generate-hfile-public-function {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct tcltype set result {} if {[my define get initfunc] ne {}} { ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);" } if {[info exists cfunct]} { foreach {funcname info} $cfunct { if {![dict get $info public]} continue ::practcl::cputs result "[dict get $info header]\;" } } set result [::practcl::_tagblock $result c [my define get filename]] foreach mod [my link list product] { ::practcl::cputs result [$mod generate-hfile-public-function] } return $result } method generate-hfile-public-includes {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set includes {} foreach item [my define get public-include] { if {$item ni $includes} { lappend includes $item } } foreach mod [my link list product] { foreach item [$mod generate-hfile-public-includes] { if {$item ni $includes} { lappend includes $item } } } return $includes } method generate-hfile-public-verbatim {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set includes {} foreach item [my define get public-verbatim] { if {$item ni $includes} { lappend includes $item } } foreach mod [my link list subordinate] { foreach item [$mod generate-hfile-public-verbatim] { if {$item ni $includes} { lappend includes $item } } } return $includes } method generate-loader-external {} { if {[my define get initfunc] eq {}} { return "/* [my define get filename] declared not initfunc */" } return " if([my define get initfunc](interp)) return TCL_ERROR\;" } method generate-loader-module {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code set result {} if {[info exists code(cinit)]} { ::practcl::cputs result $code(cinit) } if {[my define get initfunc] ne {}} { ::practcl::cputs result " if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;" } set result [::practcl::_tagblock $result c [my define get filename]] foreach item [my link list product] { if {[$item define get output_c] ne {}} { ::practcl::cputs result [$item generate-loader-external] } else { ::practcl::cputs result [$item generate-loader-module] } } return $result } method generate-stub-function {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] my variable code cfunct tcltype set result {} foreach mod [my link list product] { foreach {funct def} [$mod generate-stub-function] { dict set result $funct $def } } if {[info exists cfunct]} { foreach {funcname info} $cfunct { if {![dict get $info export]} continue dict set result $funcname [dict get $info header] } } return $result } method IncludeAdd {headervar args} { upvar 1 $headervar headers foreach inc $args { if {[string index $inc 0] ni {< \"}} { set inc "\"$inc\"" } if {$inc ni $headers} { lappend headers $inc } } } method generate-tcl-loader {} { set result {} set PKGINIT [my define get pkginit] set PKG_NAME [my define get name [my define get pkg_name]] set PKG_VERSION [my define get pkg_vers [my define get version]] if {[string is true [my define get SHARED_BUILD 0]]} { set LIBFILE [my define get libfile] |
︙ | ︙ | |||
3822 3823 3824 3825 3826 3827 3828 | # Tclkit Style load {} @PKGINIT@ package provide @PKG_NAME@ @PKG_VERSION@ }] } return $result } | < < < < < < < < < < < < < < < < < < < < | < < > | 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 | # Tclkit Style load {} @PKGINIT@ package provide @PKG_NAME@ @PKG_VERSION@ }] } return $result } method generate-tcl-pre {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code if {[info exists code(tcl)]} { set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] } if {[info exists code(tcl-pre)]} { set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]] } foreach mod [my link list product] { ::practcl::cputs result [$mod generate-tcl-pre] } return $result } method generate-tcl-post {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} my variable code if {[info exists code(tcl-post)]} { set result [::practcl::_tagblock $code(tcl-post) tcl [my define get filename]] } foreach mod [my link list product] { ::practcl::cputs result [$mod generate-tcl-post] } return $result } method linktype {} { return {subordinate product} } method Ofile filename { set lpath [my <module> define get localpath] if {$lpath eq {}} { set lpath [my <module> define get name] } return ${lpath}_[file rootname [file tail $filename]] } method project-static-packages {} { set result [my define get static_packages] set initfunc [my define get initfunc] if {$initfunc ne {}} { set pkg_name [my define get pkg_name] if {$pkg_name ne {}} { dict set result $pkg_name initfunc $initfunc dict set result $pkg_name version [my define get version [my define get pkg_vers]] dict set result $pkg_name autoload [my define get autoload 0] } } foreach item [my link list subordinate] { foreach {pkg info} [$item project-static-packages] { dict set result $pkg $info } } return $result } method toolset-include-directory {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result [my define get include_dir] foreach obj [my link list product] { foreach path [$obj toolset-include-directory] { lappend result $path } } return $result } method target {method args} { switch $method { is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] } } } } oo::objdefine ::practcl::product { method select {object} { set class [$object define get class] set mixin [$object define get product] if {$class eq {} && $mixin eq {}} { set filename [$object define get filename] if {$filename ne {} && [file exists $filename]} { switch [file extension $filename] { |
︙ | ︙ | |||
3952 3953 3954 3955 3956 3957 3958 | .a { set mixin ::practcl::product.clibrary } } } } if {$class ne {}} { | | | < < < < | < < | < < | < | < < | < | 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 | .a { set mixin ::practcl::product.clibrary } } } } if {$class ne {}} { $object clay mixinmap core $class } if {$mixin ne {}} { $object clay mixinmap product $mixin } } } ::clay::define ::practcl::product.cheader { superclass ::practcl::product method project-compile-products {} {} method generate-loader-module {} {} } ::clay::define ::practcl::product.csource { superclass ::practcl::product method project-compile-products {} { set result {} set filename [my define get filename] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename if {[my define exists ofile]} { set ofile [my define get ofile] } else { set ofile [my Ofile $filename] my define set ofile $ofile } lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]] object [self]] } foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } return $result } } ::clay::define ::practcl::product.clibrary { superclass ::practcl::product method linker-products {configdict} { return [my define get filename] } } ::clay::define ::practcl::product.dynamic { superclass ::practcl::dynamic ::practcl::product method initialize {} { set filename [my define get filename] if {$filename eq {}} { return } if {[my define get name] eq {}} { my define set name [file tail [file rootname $filename]] |
︙ | ︙ | |||
4029 4030 4031 4032 4033 4034 4035 | ::source $filename if {[my define get output_c] ne {}} { # Turn into a module if we have an output_c file my morph ::practcl::module } } } | < | < < < < < < < | | < < < | < < < < < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | < < | < < | | | | | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | < < < > < < < < < | 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 | ::source $filename if {[my define get output_c] ne {}} { # Turn into a module if we have an output_c file my morph ::practcl::module } } } ::clay::define ::practcl::product.critcl { superclass ::practcl::dynamic ::practcl::product } ### # END: class product.tcl ### ### # START: class module.tcl ### ::clay::define ::practcl::module { superclass ::practcl::object ::practcl::product.dynamic Dict make_object {} method _MorphPatterns {} { return {{@name@} {::practcl::module.@name@} ::practcl::module} } method add args { my variable links set object [::practcl::object new [self] {*}$args] foreach linktype [$object linktype] { lappend links($linktype) $object } return $object } method install-headers args {} Ensemble make::_preamble {} { my variable make_object if {![info exists make_object]} { set make_object {} } } Ensemble make::pkginfo {} { ### # Build local variables needed for install ### package require platform set result {} set dat [my define dump] set PKG_DIR [dict get $dat name][dict get $dat version] dict set result PKG_DIR $PKG_DIR dict with dat {} if {![info exists DESTDIR]} { set DESTDIR {} } dict set result profile [::platform::identify] dict set result os $::tcl_platform(os) dict set result platform $::tcl_platform(platform) foreach {field value} $dat { switch $field { includedir - mandir - datadir - libdir - libfile - name - output_tcl - version - authors - license - requires { dict set result $field $value } TEA_PLATFORM { dict set result platform $value } TEACUP_OS { dict set result os $value } TEACUP_PROFILE { dict set result profile $value } TEACUP_ZIPFILE { dict set result zipfile $value } } } if {![dict exists $result zipfile]} { dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip" } return $result } Ensemble make::objects {} { return $make_object } Ensemble make::object name { if {[dict exists $make_object $name]} { return [dict get $make_object $name] } return {} } Ensemble make::reset {} { foreach {name obj} $make_object { $obj reset } } Ensemble make::trigger args { foreach {name obj} $make_object { if {$name in $args} { $obj triggers } } } Ensemble make::depends args { foreach {name obj} $make_object { if {$name in $args} { $obj check } } } Ensemble make::filename name { if {[dict exists $make_object $name]} { return [[dict get $make_object $name] define get filename] } } Ensemble make::target {name Info body} { set info [uplevel #0 [list subst $Info]] set nspace [namespace current] if {[dict exist $make_object $name]} { set obj [dict get $$make_object $name] } else { set obj [::practcl::make_obj new [self] $name $info $body] dict set make_object $name $obj dict set target_make $name 0 dict set target_trigger $name 0 } if {[dict exists $info aliases]} { foreach item [dict get $info aliases] { if {![dict exists $make_object $item]} { dict set make_object $item $obj } } } return $obj } clay set method_ensemble make target aliases {task add} Ensemble make::todo {} { foreach {name obj} $make_object { if {[$obj do]} { lappend result $name } } return $result } Ensemble make::do {} { global CWD SRCDIR project SANDBOX foreach {name obj} $make_object { if {[$obj do]} { eval [$obj define get action] } } } method child which { switch $which { delegate - organs { return [list project [my define get project] module [self]] } } } method generate-c {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result { /* This file was generated by practcl */ } set includes {} |
︙ | ︙ | |||
4263 4264 4265 4266 4267 4268 4269 | ::practcl::cputs result $dat ::practcl::cputs result "/* END $method [my define get filename] */" } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] return $result } | < < < < < < > > > > > > > > < < < | 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 | ::practcl::cputs result $dat ::practcl::cputs result "/* END $method [my define get filename] */" } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] return $result } method generate-h {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} foreach method { generate-hfile-public-define generate-hfile-public-macro } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } set includes [my generate-hfile-public-includes] foreach inc $includes { if {[string index $inc 0] ni {< \"}} { ::practcl::cputs result "#include \"$inc\"" } else { ::practcl::cputs result "#include $inc" } } foreach method { generate-hfile-public-typedef generate-hfile-public-structure } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } |
︙ | ︙ | |||
4308 4309 4310 4311 4312 4313 4314 | } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } return $result } | < | 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 | } { ::practcl::cputs result "/* BEGIN SECTION $method */" ::practcl::cputs result [my $method] ::practcl::cputs result "/* END SECTION $method */" } return $result } method generate-loader {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set result {} if {[my define get initfunc] eq {}} return ::practcl::cputs result " extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \{" ::practcl::cputs result { |
︙ | ︙ | |||
4356 4357 4358 4359 4360 4361 4362 | if {[my define get localpath] eq {}} { my define set localpath [my <project> define get name]_[my define get name] } my graft module [self] ::practcl::debug [self] SOURCE $filename my source $filename } | < | 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 | if {[my define get localpath] eq {}} { my define set localpath [my <project> define get name]_[my define get name] } my graft module [self] ::practcl::debug [self] SOURCE $filename my source $filename } method implement path { my go my Collate_Source $path set errs {} foreach item [my link list dynamic] { if {[catch {$item implement $path} err errdat]} { lappend errs "Skipped $item: [$item define get filename] $err" |
︙ | ︙ | |||
4382 4383 4384 4385 4386 4387 4388 | lappend errs [dict get $errdat -errorinfo] } else { lappend errs $errdat } } } if {[llength $errs]} { | | | 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 | lappend errs [dict get $errdat -errorinfo] } else { lappend errs $errdat } } } if {[llength $errs]} { set logfile [file join $::CWD practcl.log] ::practcl::log $logfile "*** ERRORS ***" foreach {item trace} $errs { ::practcl::log $logfile "###\n# ERROR\n###\n$item" ::practcl::log $logfile "###\n# TRACE\n###\n$trace" } ::practcl::log $logfile "*** DEBUG INFO ***" ::practcl::log $logfile $::DEBUG_INFO |
︙ | ︙ | |||
4409 4410 4411 4412 4413 4414 4415 | ** any changes will be overwritten the next time it is run */}] puts $cout [my generate-c] puts $cout [my generate-loader] close $cout ::practcl::debug [list /[self] [self method] [self class]] } | < < | < < | 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 | ** any changes will be overwritten the next time it is run */}] puts $cout [my generate-c] puts $cout [my generate-loader] close $cout ::practcl::debug [list /[self] [self method] [self class]] } method linktype {} { return {subordinate product dynamic module} } } ### # END: class module.tcl ### ### # START: class project baseclass.tcl ### ::clay::define ::practcl::project { superclass ::practcl::module method _MorphPatterns {} { return {{@name@} {::practcl::@name@} {::practcl::project.@name@} {::practcl::project}} } constructor args { my variable define if {[llength $args] == 1} { set rawcontents [lindex $args 0] } else { set rawcontents $args } |
︙ | ︙ | |||
4460 4461 4462 4463 4464 4465 4466 | } } my graft module [self] array set define $contents ::practcl::toolset select [self] my initialize } | < < | 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 | } } my graft module [self] array set define $contents ::practcl::toolset select [self] my initialize } method add_object object { my link object $object } method add_project {pkg info {oodefine {}}} { ::practcl::debug [self] add_project $pkg $info set os [my define get TEACUP_OS] if {$os eq {}} { set os [::practcl::os] my define set os $os } |
︙ | ︙ | |||
4492 4493 4494 4495 4496 4497 4498 | } my link object $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } | < | 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 | } my link object $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } method add_tool {pkg info {oodefine {}}} { ::practcl::debug [self] add_tool $pkg $info set info [dict merge [::practcl::local_os] $info] set os [dict get $info TEACUP_OS] set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]] if {[dict exists $info os] && ($os ni [dict get $info os])} return |
︙ | ︙ | |||
4516 4517 4518 4519 4520 4521 4522 | } my link add tool $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } | < | | | | | | | | | | | > < < < < < < | | 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 | } my link add tool $obj oo::objdefine $obj $oodefine $obj define set masterpath $::CWD $obj go return $obj } method build-tclcore {} { set os [my define get TEACUP_OS] set tcl_config_opts [::practcl::platform::tcl_core_options $os] set tk_config_opts [::practcl::platform::tk_core_options $os] lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix] set tclobj [my tclcore] if {[my define get debug 0]} { $tclobj define set debug 1 lappend tcl_config_opts --enable-symbols=true } $tclobj define set config_opts $tcl_config_opts $tclobj go $tclobj compile set _TclSrcDir [$tclobj define get localsrcdir] my define set tclsrcdir $_TclSrcDir if {[my define get tk 0]} { set tkobj [my tkcore] lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir] [$tclobj define get builddir]] if {[my define get debug 0]} { $tkobj define set debug 1 lappend tk_config_opts --enable-symbols=true } $tkobj define set config_opts $tk_config_opts $tkobj compile } } method child which { switch $which { delegate - organs { # A library can be a project, it can be a module. Any # subordinate modules will indicate their existance return [list project [self] module [self]] } } } method linktype {} { return project } method project {pkg args} { set obj [namespace current]::PROJECT.$pkg if {[llength $args]==0} { return $obj } ${obj} {*}$args } method tclcore {} { if {[info commands [set obj [my clay delegate tclcore]]] ne {}} { return $obj } if {[info commands [set obj [my project TCLCORE]]] ne {}} { my graft tclcore $obj return $obj } if {[info commands [set obj [my project tcl]]] ne {}} { |
︙ | ︙ | |||
4594 4595 4596 4597 4598 4599 4600 | set obj [my add_tool tcl { tag release class subproject.core fossil_url http://core.tcl.tk/tcl }] my graft tclcore $obj return $obj } | < | < < | < < < < < | 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 | set obj [my add_tool tcl { tag release class subproject.core fossil_url http://core.tcl.tk/tcl }] my graft tclcore $obj return $obj } method tkcore {} { if {[set obj [my clay delegate tkcore]] ne {}} { return $obj } if {[set obj [my project tk]] ne {}} { my graft tkcore $obj return $obj } if {[set obj [my tool tk]] ne {}} { my graft tkcore $obj return $obj } # Provide a fallback set obj [my add_tool tk { tag release class tool.core fossil_url http://core.tcl.tk/tk }] my graft tkcore $obj return $obj } method tool {pkg args} { set obj ::practcl::OBJECT::TOOL.$pkg if {[llength $args]==0} { return $obj } ${obj} {*}$args } } ### # END: class project baseclass.tcl ### ### # START: class project library.tcl ### ::clay::define ::practcl::library { superclass ::practcl::project method clean {PATH} { set objext [my define get OBJEXT o] foreach {ofile info} [my project-compile-products] { if {[file exists [file join $PATH objs $ofile].${objext}]} { file delete [file join $PATH objs $ofile].${objext} } } foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] { file delete $ofile } foreach ofile [glob -nocomplain [file join $PATH objs *]] { file delete $ofile } set libfile [my define get libfile] if {[file exists [file join $PATH $libfile]]} { file delete [file join $PATH $libfile] } my implement $PATH } method project-compile-products {} { set result {} foreach item [my link list subordinate] { lappend result {*}[$item project-compile-products] } set filename [my define get output_c] if {$filename ne {}} { ::practcl::debug [self] [self class] [self method] project-compile-products $filename set ofile [file rootname [file tail $filename]]_main lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]] } return $result } method go {} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set name [my define getnull name] if {$name eq {}} { set name generic my define name generic } |
︙ | ︙ | |||
4719 4720 4721 4722 4723 4724 4725 | foreach {linktype objs} [array get links] { foreach obj $objs { $obj go } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] } | < < | 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 | foreach {linktype objs} [array get links] { foreach obj $objs { $obj go } } ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]] } method generate-decls {pkgname path} { ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]] set outfile [file join $path/$pkgname.decls] ### # Build the decls file ## # |
︙ | ︙ | |||
4814 4815 4816 4817 4818 4819 4820 | return NULL; } return actualVersion; } }] close $cout } | < | 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 | return NULL; } return actualVersion; } }] close $cout } method implement path { my go my Collate_Source $path set errs {} foreach item [my link list dynamic] { if {[catch {$item implement $path} err errdat]} { lappend errs "Skipped $item: [$item define get filename] $err" |
︙ | ︙ | |||
4885 4886 4887 4888 4889 4890 4891 | ###" puts $tclout [my generate-tcl-pre] puts $tclout [my generate-tcl-loader] puts $tclout [my generate-tcl-post] close $tclout } } | < < < < < < | < < < < < | < | 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 | ###" puts $tclout [my generate-tcl-pre] puts $tclout [my generate-tcl-loader] puts $tclout [my generate-tcl-post] close $tclout } } method generate-make path { my build-Makefile $path [self] } method linktype {} { return library } method package-ifneeded {args} { set result {} set name [my define get pkg_name [my define get name]] set version [my define get pkg_vers [my define get version]] if {$version eq {}} { set version 0.1a } set output_tcl [my define get output_tcl] if {$output_tcl ne {}} { set script "\[list source \[file join \$dir $output_tcl\]\]" } elseif {[my define get SHARED_BUILD 0]} { set script "\[list load \[file join \$dir [my define get libfile]\] $name\]" } else { # Provide a null passthrough set script "\[list package provide $name $version\]" } set result "package ifneeded [list $name] [list $version] $script" foreach alias $args { set script "package require $name $version \; package provide $alias $version" append result \n\n [list package ifneeded $alias $version $script] } return $result } method shared_library {{filename {}}} { set name [string tolower [my define get name [my define get pkg_name]]] set NAME [string toupper $name] set version [my define get version [my define get pkg_vers]] set map {} lappend map %LIBRARY_NAME% $name lappend map %LIBRARY_VERSION% $version lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] lappend map %LIBRARY_PREFIX% [my define getnull libprefix] set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]][my define get SHLIB_SUFFIX] return $outfile } method static_library {{filename {}}} { set name [string tolower [my define get name [my define get pkg_name]]] set NAME [string toupper $name] set version [my define get version [my define get pkg_vers]] set map {} lappend map %LIBRARY_NAME% $name lappend map %LIBRARY_VERSION% $version lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version] lappend map %LIBRARY_PREFIX% [my define getnull libprefix] set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]].a return $outfile } } ### # END: class project library.tcl ### ### # START: class project tclkit.tcl ### ::clay::define ::practcl::tclkit { superclass ::practcl::library method build-tclkit_main {PROJECT PKG_OBJS} { ### # Build static package list ### set statpkglist {} foreach cobj [list {*}${PKG_OBJS} $PROJECT] { foreach {pkg info} [$cobj project-static-packages] { |
︙ | ︙ | |||
5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 | set map {} foreach var { vfsroot mainhook mainfunc vfs_main } { dict set map %${var}% [set $var] } set preinitscript { set ::odie(boot_vfs) %vfsroot% set ::SRCDIR $::odie(boot_vfs) if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { set ::tcl_library [file join %vfsroot% tcl_library] set ::auto_path {} } if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { set ::tk_library [file join %vfsroot% tk_library] } } ; # Preinitscript set zvfsboot { /* * %mainhook% -- * Performs the argument munging for the shell */ } ::practcl::cputs zvfsboot { | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 | set map {} foreach var { vfsroot mainhook mainfunc vfs_main } { dict set map %${var}% [set $var] } set preinitscript { set ::odie(boot_vfs) %vfsroot% set ::SRCDIR $::odie(boot_vfs) namespace eval ::starkit {} set ::starkit::topdir %vfsroot% if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { set ::tcl_library [file join %vfsroot% tcl_library] set ::auto_path {} } if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { set ::tk_library [file join %vfsroot% tk_library] } } ; # Preinitscript set main_init_script {} set thread_init_script {} append preinitscript \n {namespace eval ::starkit {}} append preinitscript \n [list set ::starkit::topdir $vfsroot] foreach {statpkg info} $statpkglist { set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] append preinitscript \n $script if {[dict get $info autoload]} { append main_init_script \n [list ::load {} $statpkg] } } append preinitscript \n { if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} { #In a wrapped exe, we don't go out to the environment set dir $::starkit::topdir source [file join $::starkit::topdir pkgIndex.tcl] }} append main_init_script \n { # Specify a user-specific startup file to invoke if the application # is run interactively. Typically the startup file is "~/.apprc" # where "app" is the name of the application. If this line is deleted # then no user-specific startup file will be run under any conditions. } append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] append preinitscript \n [list set ::starkit::thread_init $thread_init_script] append preinitscript \n {eval $::starkit::thread_init} set zvfsboot { /* * %mainhook% -- * Performs the argument munging for the shell */ } ::practcl::cputs zvfsboot { |
︙ | ︙ | |||
5125 5126 5127 5128 5129 5130 5131 | return TCL_ERROR; } } if {![$PROJECT define get tip_430 0]} { ::practcl::cputs appinit { TclZipfs_Init(interp);} } | < < < < < < < < < < | < < < < < < < | | 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 | return TCL_ERROR; } } if {![$PROJECT define get tip_430 0]} { ::practcl::cputs appinit { TclZipfs_Init(interp);} } foreach {statpkg info} $statpkglist { set initfunc {} if {[dict exists $info initfunc]} { set initfunc [dict get $info initfunc] } if {$initfunc eq {}} { set initfunc [string totitle ${statpkg}]_Init } if {![dict exists $info version]} { error "$statpkg HAS NO VERSION" } # We employ a NULL to prevent the package system from thinking the # package is actually loaded into the interpreter $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" if {[dict get $info autoload]} { ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" } else { ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" } } practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $main_init_script]);" practcl::cputs appinit { return TCL_OK;} $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] } method Collate_Source CWD { next $CWD set name [my define get name] # Assume a static shell if {[my define exists SHARED_BUILD]} { my define set SHARED_BUILD 0 } if {![my define exists TCL_LOCAL_APPINIT]} { my define set TCL_LOCAL_APPINIT Tclkit_AppInit } if {![my define exists TCL_LOCAL_MAIN_HOOK]} { my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook } set PROJECT [self] set os [$PROJECT define get TEACUP_OS] if {[my define get SHARED_BUILD 0]} { puts [list BUILDING TCLSH FOR OS $os] } else { puts [list BUILDING KIT FOR OS $os] } set TCLOBJ [$PROJECT tclcore] ::practcl::toolset select $TCLOBJ |
︙ | ︙ | |||
5206 5207 5208 5209 5210 5211 5212 | if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK if {$os eq "windows"} { set PLATFORM_SRC_DIR win | | | | 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 | if {[string is true [$item define get static]]} { lappend PKG_OBJS $item } } # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK if {$os eq "windows"} { set PLATFORM_SRC_DIR win if {![my define get SHARED_BUILD 0]} { my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1 my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1 } my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] } else { set PLATFORM_SRC_DIR unix my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]] } if {![my define get SHARED_BUILD 0]} { ### # Add local static Zlib implementation ### set cdir [file join $TCLSRCDIR compat zlib] foreach file { adler32.c compress.c crc32.c deflate.c infback.c inffast.c |
︙ | ︙ | |||
5246 5247 5248 5249 5250 5251 5252 | if {[file exists $zipfs]} { $TCLOBJ define set tip_430 1 my define set tip_430 1 } else { # The Tclconfig project maintains a mirror of the version # released with the Tcl core my define set tip_430 0 | > > | | > > > | < < < | > | | | | | 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 | if {[file exists $zipfs]} { $TCLOBJ define set tip_430 1 my define set tip_430 1 } else { # The Tclconfig project maintains a mirror of the version # released with the Tcl core my define set tip_430 0 set tclzipfs_c [my define get tclzipfs_c] if {![file exists $tclzipfs_c]} { ::practcl::LOCAL tool tclconfig unpack set COMPATSRCROOT [::practcl::LOCAL tool tclconfig define get srcdir] set tclzipfs_c [file join $COMPATSRCROOT compat tclZipfs.c] } my add class csource ofile tclZipfs.o filename $tclzipfs_c \ extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]] } my define add include_dir [file join $TCLSRCDIR generic] my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR] # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK my build-tclkit_main $PROJECT $PKG_OBJS } method wrap {PWD exename vfspath args} { cd $PWD if {![file exists $vfspath]} { file mkdir $vfspath } foreach item [my link list core.library] { set name [$item define get name] set libsrcdir [$item define get srcdir] if {[file exists [file join $libsrcdir library]]} { ::practcl::copyDir [file join $libsrcdir library] [file join $vfspath ${name}_library] } } # Assume the user will populate the VFS path #if {[my define get installdir] ne {}} { # ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib] #} foreach arg $args { ::practcl::copyDir $arg $vfspath } set fout [open [file join $vfspath pkgIndex.tcl] w] puts $fout [string map [list %platform% [my define get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}] puts $fout { namespace eval ::starkit {} set ::PKGIDXFILE [info script] set dir [file dirname $::PKGIDXFILE] if {$::tcl_platform(platform) eq "windows"} { set ::starkit::localHome [file join [file normalize $::env(LOCALAPPDATA)] tcl] } else { set ::starkit::localHome [file normalize ~/tcl] } set ::tcl_teapot [file join $::starkit::localHome teapot $::tcl_teapot_profile] lappend ::auto_path $::tcl_teapot } puts $fout [list proc installDir [info args ::practcl::installDir] [info body ::practcl::installDir]] set buffer [::practcl::pkgindex_path $vfspath] puts $fout $buffer puts $fout { # Advertise statically linked packages foreach {pkg script} [array get ::starkit::static_packages] { eval $script } } puts $fout { ### # Cache binary packages distributed as dynamic libraries in a known location ### |
︙ | ︙ | |||
5330 5331 5332 5333 5334 5335 5336 | ### # END: class project tclkit.tcl ### ### # START: class distro baseclass.tcl ### | < < < < < < | < < < | < < < < < | | 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 | ### # END: class project tclkit.tcl ### ### # START: class distro baseclass.tcl ### ::clay::define ::practcl::distribution { method scm_info {} { return { scm None hash {} maxdate {} tags {} isodate {} } } method DistroMixIn {} { my define set scm none } method Sandbox {} { if {[my define exists sandbox]} { return [my define get sandbox] } if {[my clay delegate project] ni {::noop {}}} { set sandbox [my <project> define get sandbox] if {$sandbox ne {}} { my define set sandbox $sandbox return $sandbox } } set sandbox [file normalize [file join $::CWD ..]] my define set sandbox $sandbox return $sandbox } method SrcDir {} { set pkg [my define get name] if {[my define exists srcdir]} { return [my define get srcdir] } set sandbox [my Sandbox] set srcdir [file join [my Sandbox] $pkg] my define set srcdir $srcdir return $srcdir } method ScmTag {} {} method ScmClone {} {} method ScmUnpack {} {} method ScmUpdate {} {} method Unpack {} { set srcdir [my SrcDir] if {[file exists $srcdir]} { return } set pkg [my define get name] if {[my define exists download]} { # Utilize a staged download set download [my define get download] if {[file exists [file join $download $pkg.zip]]} { ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir return } } my ScmUnpack } } oo::objdefine ::practcl::distribution { method Sandbox {object} { if {[$object define exists sandbox]} { return [$object define get sandbox] } if {[$object clay delegate project] ni {::noop {}}} { set sandbox [$object <project> define get sandbox] if {$sandbox ne {}} { $object define set sandbox $sandbox return $sandbox } } set pkg [$object define get name] |
︙ | ︙ | |||
5439 5440 5441 5442 5443 5444 5445 | $object define set srcdir $srcdir } set classprefix ::practcl::distribution. if {[file exists $srcdir]} { foreach class [::info commands ${classprefix}*] { if {[$class claim_path $srcdir]} { | | > | | | > | | > | | | | | > > > > > < | < | 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 | $object define set srcdir $srcdir } set classprefix ::practcl::distribution. if {[file exists $srcdir]} { foreach class [::info commands ${classprefix}*] { if {[$class claim_path $srcdir]} { $object clay mixinmap distribution $class set name [$class claim_option] $object define set scm $name return $name } } } foreach class [::info commands ${classprefix}*] { if {[$class claim_object $object]} { $object clay mixinmap distribution $class set name [$class claim_option] $object define set scm $name return $name } } if {[$object define get scm] eq {} && [$object define exists file_url]} { set class ::practcl::distribution.snapshot set name [$class claim_option] $object define set scm $name $object clay mixinmap distribution $class return $name } error "Cannot determine source distribution method" } method claim_option {} { return Unknown } method claim_object object { return false } method claim_path path { return false } } ### # END: class distro baseclass.tcl ### ### # START: class distro snapshot.tcl ### ::clay::define ::practcl::distribution.snapshot { superclass ::practcl::distribution method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .download]]} { return 0 } set dpath [::practcl::LOCAL define get download] set url [my define get file_url] |
︙ | ︙ | |||
5517 5518 5519 5520 5521 5522 5523 5524 | set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } } | > > > > | > > > > < < < < | < < < | 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 | set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } } oo::objdefine ::practcl::distribution.snapshot { method claim_object object { return false } method claim_option {} { return snapshot } method claim_path path { if {[file exists [file join $path .download]]} { return true } return false } } ### # END: class distro snapshot.tcl ### ### # START: class distro fossil.tcl ### ::clay::define ::practcl::distribution.fossil { superclass ::practcl::distribution method scm_info {} { set info [next] dict set info scm fossil foreach {field value} [::practcl::fossil_status [my define get srcdir]] { dict set info $field $value } return $info } method ScmClone {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .fslckout]]} { return } if {[file exists [file join $srcdir _FOSSIL_]]} { return |
︙ | ︙ | |||
5608 5609 5610 5611 5612 5613 5614 | return $fosdb } } # Fall back to the fossil mirror on the island of misfit toys ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb return $fosdb } | < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > < < | < < < | < < < < | < < > > > > > > > > > > > | < < < < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | < < < | < < < < < | < < < | < < < | < < < < < > > | | | > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < | < < | < < | 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 | return $fosdb } } # Fall back to the fossil mirror on the island of misfit toys ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb return $fosdb } method ScmTag {} { if {[my define exists scm_tag]} { return [my define get scm_tag] } if {[my define exists tag]} { set tag [my define get tag] } else { set tag trunk } my define set scm_tag $tag return $tag } method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .fslckout]]} { return 0 } if {[file exists [file join $srcdir _FOSSIL_]]} { return 0 } set CWD [pwd] set fosdb [my ScmClone] set tag [my ScmTag] file mkdir $srcdir ::practcl::fossil $srcdir open $fosdb $tag return 1 } method ScmUpdate {} { if {[my ScmUnpack]} { return } set srcdir [my SrcDir] set tag [my ScmTag] ::practcl::fossil $srcdir update $tag } } oo::objdefine ::practcl::distribution.fossil { # Check for markers in the metadata method claim_object obj { set path [$obj define get srcdir] if {[my claim_path $path]} { return true } if {[$obj define get fossil_url] ne {}} { return true } return false } method claim_option {} { return fossil } # Check for markers in the source root method claim_path path { if {[file exists [file join $path .fslckout]]} { return true } if {[file exists [file join $path _FOSSIL_]]} { return true } return false } } ### # END: class distro fossil.tcl ### ### # START: class distro git.tcl ### ::clay::define ::practcl::distribution.git { superclass ::practcl::distribution method ScmTag {} { if {[my define exists scm_tag]} { return [my define get scm_tag] } if {[my define exists tag]} { set tag [my define get tag] } else { set tag master } my define set scm_tag $tag return $tag } method ScmUnpack {} { set srcdir [my SrcDir] if {[file exists [file join $srcdir .git]]} { return 0 } set CWD [pwd] set tag [my ScmTag] set pkg [my define get name] if {[my define exists git_url]} { ::practcl::doexec git clone --branch $tag [my define get git_url] $srcdir } else { ::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir } return 1 } method ScmUpdate {} { if {[my ScmUnpack]} { return } set CWD [pwd] set srcdir [my SrcDir] set tag [my ScmTag] ::practcl::doexec_in $srcdir git pull cd $CWD } } oo::objdefine ::practcl::distribution.git { method claim_object obj { set path [$obj define get srcdir] if {[my claim_path $path]} { return true } if {[$obj define get git_url] ne {}} { return true } return false } method claim_option {} { return git } method claim_path path { if {[file exists [file join $path .git]]} { return true } return false } } ### # END: class distro git.tcl ### ### # START: class subproject baseclass.tcl ### ::clay::define ::practcl::subproject { superclass ::practcl::module method _MorphPatterns {} { return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}} } method BuildDir {PWD} { return [my define get srcdir] } method child which { switch $which { delegate - organs { # A library can be a project, it can be a module. Any # subordinate modules will indicate their existance return [list project [self] module [self]] } } } method compile {} {} method go {} { ::practcl::distribution select [self] set name [my define get name] my define set builddir [my BuildDir [my define get masterpath]] my define set builddir [my BuildDir [my define get masterpath]] my sources } method install args {} method linktype {} { return {subordinate package} } method linker-products {configdict} {} method linker-external {configdict} { if {[dict exists $configdict PRACTCL_PKG_LIBS]} { return [dict get $configdict PRACTCL_PKG_LIBS] } if {[dict exists $configdict LIBS]} { return [dict get $configdict LIBS] } } method linker-extra {configdict} { if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} { return [dict get $configdict PRACTCL_LINKER_EXTRA] } return {} } method env-bootstrap {} { set pkg [my define get pkg_name [my define get name]] package require $pkg } method env-exec {} {} method env-install {} { my unpack } method env-load {} { my variable loaded if {[info exists loaded]} { return 0 } if {![my env-present]} { my env-install } my env-bootstrap set loaded 1 } method env-present {} { set pkg [my define get pkg_name [my define get name]] if {[catch [list package require $pkg]]} { return 0 } return 1 } method sources {} {} method update {} { my ScmUpdate } method unpack {} { cd $::CWD ::practcl::distribution select [self] my Unpack ::practcl::toolset select [self] cd $::CWD } } ::clay::define ::practcl::subproject.source { superclass ::practcl::subproject ::practcl::library method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } } method env-present {} { set path [my define get srcdir] return [file exists $path] } method linktype {} { return {subordinate package source} } } ::clay::define ::practcl::subproject.teapot { superclass ::practcl::subproject method env-bootstrap {} { set pkg [my define get pkg_name [my define get name]] package require $pkg } method env-install {} { set pkg [my define get pkg_name [my define get name]] set download [my <project> define get download] my unpack set prefix [string trimleft [my <project> define get prefix] /] ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg] } method env-present {} { set pkg [my define get pkg_name [my define get name]] if {[catch [list package require $pkg]]} { return 0 } return 1 } method install DEST { set pkg [my define get pkg_name [my define get name]] set download [my <project> define get download] my unpack set prefix [string trimleft [my <project> define get prefix] /] ::practcl::tcllib_require zipfile::decode ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg] } } ::clay::define ::practcl::subproject.kettle { superclass ::practcl::subproject method kettle {path args} { my variable kettle if {![info exists kettle]} { ::practcl::LOCAL tool kettle env-load set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle] } set srcdir [my SourceRoot] ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args } method install DEST { my kettle reinstall --prefix $DEST } } ::clay::define ::practcl::subproject.critcl { superclass ::practcl::subproject method install DEST { my critcl -pkg [my define get name] set srcdir [my SourceRoot] ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]] } } ::clay::define ::practcl::subproject.sak { superclass ::practcl::subproject method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } } method env-install {} { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir installer.tcl] \ -apps -app-path [file join $prefix apps] \ -html -html-path [file join $prefix doc html $pkg] \ -pkg-path [file join $prefix lib $pkg] \ -no-nroff -no-wait -no-gui } method env-present {} { set path [my define get srcdir] return [file exists $path] } method install DEST { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [string trimleft [my <project> define get prefix] /] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir installer.tcl] \ -pkg-path [file join $DEST $prefix lib $pkg] \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps } method install-module {DEST args} { set srcdir [my define get srcdir] if {[llength $args]==1 && [lindex $args 0] in {* all}} { set pkg [my define get pkg_name [my define get name]] ::practcl::dotclexec [file join $srcdir installer.tcl] \ -pkg-path [file join $DEST $pkg] \ -no-examples -no-html -no-nroff \ -no-wait -no-gui -no-apps } else { foreach module $args { ::practcl::installModule [file join $srcdir modules $module] [file join $DEST $module] } } } } ::clay::define ::practcl::subproject.practcl { superclass ::practcl::subproject method env-bootstrap {} { set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]] if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} { set ::auto_path [linsert $::auto_path 0 $LibraryRoot] } } method env-install {} { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $prefix lib $pkg] } method install DEST { ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] my unpack set prefix [string trimleft [my <project> define get prefix] /] set srcdir [my define get srcdir] puts [list INSTALLING [my define get name] to [file join $DEST $prefix lib $pkg]] ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $DEST $prefix lib $pkg] } method install-module {DEST args} { set pkg [my define get pkg_name [my define get name]] set srcdir [my define get srcdir] ::practcl::dotclexec [file join $srcdir make.tcl] install-module $DEST {*}$args } } ### # END: class subproject baseclass.tcl ### ### # START: class subproject binary.tcl ### ::clay::define ::practcl::subproject.binary { superclass ::practcl::subproject method clean {} { set builddir [file normalize [my define get builddir]] if {![file exists $builddir]} return if {[file exists [file join $builddir make.tcl]]} { ::practcl::domake.tcl $builddir clean } else { catch {::practcl::domake $builddir clean} } } method env-install {} { ### # Handle tea installs ### set pkg [my define get pkg_name [my define get name]] set os [::practcl::local_os] my define set os $os my unpack set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] set srcdir [my define get srcdir] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options my go my clean my compile my make install {} } method project-compile-products {} {} method ComputeInstall {} { if {[my define exists install]} { switch [my define get install] { static { my define set static 1 my define set autoload 0 } |
︙ | ︙ | |||
6096 6097 6098 6099 6100 6101 6102 | } default { } } } } | < < < | 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 | } default { } } } } method go {} { next ::practcl::distribution select [self] my ComputeInstall my define set builddir [my BuildDir [my define get masterpath]] } method linker-products {configdict} { if {![my define get static 0]} { return {} } set srcdir [my define get builddir] if {[dict exists $configdict libfile]} { return " [file join $srcdir [dict get $configdict libfile]]" } } method project-static-packages {} { if {![my define get static 0]} { return {} } set result [my define get static_packages] set statpkg [my define get static_pkg] set initfunc [my define get initfunc] |
︙ | ︙ | |||
6148 6149 6150 6151 6152 6153 6154 | foreach item [my link list subordinate] { foreach {pkg info} [$item project-static-packages] { dict set result $pkg $info } } return $result } | < < | < | < | < | | < < | < < | < | < < < | < < < < < < < | 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 | foreach item [my link list subordinate] { foreach {pkg info} [$item project-static-packages] { dict set result $pkg $info } } return $result } method BuildDir {PWD} { set name [my define get name] set debug [my define get debug 0] if {[my <project> define get LOCAL 0]} { return [my define get builddir [file join $PWD local $name]] } if {$debug} { return [my define get builddir [file join $PWD debug $name]] } else { return [my define get builddir [file join $PWD pkg $name]] } } method compile {} { set name [my define get name] set PWD $::CWD cd $PWD my unpack set srcdir [file normalize [my SrcDir]] set localsrcdir [my MakeDir $srcdir] my define set localsrcdir $localsrcdir my Collate_Source $PWD ### # Build a starter VFS for both Tcl and wish ### set srcdir [my define get srcdir] if {[my define get static 1]} { puts "BUILDING Static $name $srcdir" } else { puts "BUILDING Dynamic $name $srcdir" } my make compile cd $PWD } method Configure {} { cd $::CWD my unpack ::practcl::toolset select [self] set srcdir [file normalize [my define get srcdir]] set builddir [file normalize [my define get builddir]] file mkdir $builddir my make autodetect } method install DEST { set PWD [pwd] set PREFIX [my <project> define get prefix] ### # Handle teapot installs ### set pkg [my define get pkg_name [my define get name]] if {[my <project> define get teapot] ne {}} { set TEAPOT [my <project> define get teapot] set found 0 foreach ver [my define get pkg_vers [my define get version]] { set teapath [file join $TEAPOT $pkg$ver] if {[file exists $teapath]} { set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]] ::practcl::copyDir $teapath $dest return } } } my compile my make install $DEST cd $PWD } } ::clay::define ::practcl::subproject.tea { superclass ::practcl::subproject.binary } ::clay::define ::practcl::subproject.library { superclass ::practcl::subproject.binary ::practcl::library method install DEST { my compile } } ::clay::define ::practcl::subproject.external { superclass ::practcl::subproject.binary method install DEST { my compile } } ### # END: class subproject binary.tcl ### ### # START: class subproject core.tcl ### ::clay::define ::practcl::subproject.core { superclass ::practcl::subproject.binary method env-bootstrap {} {} method env-present {} { set PREFIX [my <project> define get prefix] set name [my define get name] set fname [file join $PREFIX lib ${name}Config.sh] return [file exists $fname] } method env-install {} { my unpack set os [::practcl::local_os] set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]] lappend options --prefix $prefix --exec-prefix $prefix my define set config_opts $options puts [list [self] OS [dict get $os TEACUP_OS] options $options] my go my compile my make install {} } method go {} { my define set core_binary 1 next } method linktype {} { return {subordinate core.library} } } ### # END: class subproject core.tcl ### ### # START: class tool.tcl ### set ::practcl::MAIN ::practcl::LOCAL set ::auto_index(::practcl::LOCAL) { ::practcl::project create ::practcl::LOCAL ::practcl::LOCAL define set [::practcl::local_os] ::practcl::LOCAL define set LOCAL 1 # Until something better comes along, use ::practcl::LOCAL # as our main project |
︙ | ︙ |