File: object.tcl

package info (click to toggle)
tcllib 1.21%2Bdfsg-1
  • links: PTS
  • area: main
  • in suites: bookworm
  • size: 69,456 kB
  • sloc: tcl: 266,493; ansic: 14,259; sh: 2,936; xml: 1,766; yacc: 1,145; pascal: 881; makefile: 112; perl: 84; f90: 84; python: 33; ruby: 13; php: 11
file content (647 lines) | stat: -rw-r--r-- 23,876 bytes parent folder | download | duplicates (4)
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
# 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.}
  # }
  # cache {
  #   argspec {path {mandatory 1 positional 1} value {mandatory 1 positional 1}}
  #   description {Store VALUE in such a way that request in SEARCH for PATH will always return it until the cache is flushed}
  # }
  # 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.}}
  # search {
  #   argspec {path {mandatory 1 positional 1} valuevar {mandatory 1 positional 1} isleafvar {mandatory 1 positional 1}}
  #   description {Return true, and set valuevar to the value and isleafar to true for false if PATH was found in the cache.}
  #}
  # 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 . {}
        }
      }
      busy {
        my variable clay_busy
        if {[llength $args]} {
          set clay_busy [string is true [lindex $args 0]]
          set claycache {}
        }
        if {![info exists clay_busy]} {
          set clay_busy 0
        }
        return $clay_busy
      }
      cache {
        set path [lindex $args 0]
        set value [lindex $args 1]
        dict set claycache $path $value
      }
      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 path [::clay::tree::storage method_ensemble]
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        set emap {}
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          dict for {ensemble einfo} [$class clay dget {*}$path] {
            if {$ensemble eq "."} continue
            dict for {method body} $einfo {
              if {$method eq "."} continue
              dict set emap $ensemble $method class: $class
              dict set emap $ensemble $method body: $body
            }
          }
        }
        if {[dict exists $clay {*}$path]} {
          dict for {ensemble einfo} [dict get $clay {*}$path] {
            dict for {method body} $einfo {
              if {$method eq "."} continue
              dict set emap $ensemble $method class: $class
              dict set emap $ensemble $method body: $body
            }
          }
        }
        dict set claycache {*}$path $emap
        return $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
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        # Search in our local cache
        if {[my clay search $path value isleaf]} {
          return $value
        }

        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]
            my clay cache $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
        #}
        my clay cache $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]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        # Search in our local cache
        if {[my clay search $path value isleaf]} {
          if {!$isleaf} {
            return [clay::tree::sanitize $value]
          } else {
            return $value
          }
        }
        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]
            my clay cache $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]
        #}
        my clay cache $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 {[my clay search $path value isleaf]} {
          if {!$isleaf} {
            return [clay::tree::sanitize $value]
          } else {
            return $value
          }
        }
        # 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]
            my clay cache $path $value
            return $value
          }
        }
      }
      merge {
        foreach arg $args {
          ::clay::tree::dictmerge clay {*}$arg
        }
      }
      mixin {
        ###
        # Mix in the class
        ###
        my clay flush
        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 {
        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 {}
      }
      refcount {
        my variable refcount
        if {![info exists refcount]} {
          return 0
        }
        return $refcount
      }
      refcount_incr {
        my variable refcount
        incr refcount
      }
      refcount_decr {
        my variable refcount
        incr refcount -1
        if {$refcount <= 0} {
          ::clay::object_destroy [self]
        }
      }
      replace {
        set clay [lindex $args 0]
      }
      search {
        set path [lindex $args 0]
        upvar 1 [lindex $args 1] value [lindex $args 2] isleaf
        set isleaf [expr {![dict exists $claycache $path .]}]
        if {[dict exists $claycache $path]} {
          set value [dict get $claycache $path]
          return 1
        }
        return 0
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        ::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 clay_busy
    if {[info exists clay_busy] && $clay_busy} {
      # Avoid repeated calls to InitializePublic if we know that someone is
      # going to invoke it at the end of whatever process is going on
      return
    }
    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]
      }
    }

    foreach {ensemble einfo} [my clay ensemble_map] {
      #if {[dict exists $einfo _body]} continue
      if {$ensemble eq "."} 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