« back to all changes in this revision
Viewing changes to hv/snit.tcl
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Package Import Robot
- Author(s): Ole Streicher
- Date: 2012-03-02 18:45:00 UTC
- Revision ID: package-import@ubuntu.com-20120302184500-np17d7d6gd1jedj0
Tags: upstream-3.0~fossil20110109
Import upstream version 3.0~fossil20110109
- files added:
- doc
- hv
- src
- tclconfig
- tests
- tests/page1
- tests/page2
- tests/page3
- tests/page4
- tools
- tools/rules
- webpage
added
removed
hv/snit.tcl
1
#-----------------------------------------------------------------------
2
# TITLE:
3
# snit.tcl
4
#
5
# AUTHOR:
6
# Will Duquette
7
#
8
# DESCRIPTION:
9
# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
10
#
11
# Copyright (C) 2003-2005 by William H. Duquette
12
# This code is licensed as described in license.txt.
13
#
14
#-----------------------------------------------------------------------
15
16
package provide snit 1.0
17
18
#-----------------------------------------------------------------------
19
# Namespace
20
21
namespace eval ::snit:: {
22
namespace export \
23
compile type widget widgetadaptor typemethod method macro
24
}
25
26
#-----------------------------------------------------------------------
27
# Some Snit variables
28
29
namespace eval ::snit:: {
30
variable reservedArgs {type selfns win self}
31
32
# If true, get a pretty, fixed-up stack trace. Otherwise, get raw
33
# stack trace.
34
# NOTE: Not Yet Implemented
35
variable prettyStackTrace 1
36
}
37
38
#-----------------------------------------------------------------------
39
# Snit Type Implementation template
40
41
namespace eval ::snit:: {
42
# Template type definition: All internal and user-visible Snit
43
# implementation code.
44
#
45
# The following placeholders will automatically be replaced with
46
# the client's code, in two passes:
47
#
48
# First pass:
49
# %COMPILEDDEFS% The compiled type definition.
50
#
51
# Second pass:
52
# %TYPE% The fully qualified type name.
53
# %IVARDECS% Instance variable declarations
54
# %TVARDECS% Type variable declarations
55
# %TCONSTBODY% Type constructor body
56
# %INSTANCEVARS% The compiled instance variable initialization code.
57
# %TYPEVARS% The compiled type variable initialization code.
58
59
# This is the overall type template.
60
variable typeTemplate
61
62
# This is the normal type proc
63
variable nominalTypeProc
64
65
# This is the "-hastypemethods no" type proc
66
variable simpleTypeProc
67
}
68
69
set ::snit::typeTemplate {
70
71
#-------------------------------------------------------------------
72
# The type's namespace definition and the user's type variables
73
74
namespace eval %TYPE% {%TYPEVARS%
75
}
76
77
#----------------------------------------------------------------
78
# Commands for use in methods, typemethods, etc.
79
#
80
# These are implemented as aliases into the Snit runtime library.
81
82
interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
83
interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
84
interp alias {} %TYPE%::typevariable {} ::variable
85
interp alias {} %TYPE%::variable {} ::snit::RT.variable
86
interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
87
interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
88
interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
89
interp alias {} %TYPE%::varname {} ::snit::RT.myvar
90
interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
91
interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
92
interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
93
interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
94
interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
95
96
#-------------------------------------------------------------------
97
# Snit's internal variables
98
99
namespace eval %TYPE% {
100
# Array: General Snit Info
101
#
102
# ns: The type's namespace
103
# hasinstances: T or F, from pragma -hasinstances.
104
# simpledispatch: T or F, from pragma -hasinstances.
105
# canreplace: T or F, from pragma -canreplace.
106
# counter: Count of instances created so far.
107
# widgetclass: Set by widgetclass statement.
108
# hulltype: Hull type (frame or toplevel) for widgets only.
109
# exceptmethods: Methods explicitly not delegated to *
110
# excepttypemethods: Methods explicitly not delegated to *
111
# tvardecs: Type variable declarations--for dynamic methods
112
# ivardecs: Instance variable declarations--for dyn. methods
113
typevariable Snit_info
114
set Snit_info(ns) %TYPE%::
115
set Snit_info(hasinstances) 1
116
set Snit_info(simpledispatch) 0
117
set Snit_info(canreplace) 0
118
set Snit_info(counter) 0
119
set Snit_info(widgetclass) {}
120
set Snit_info(hulltype) frame
121
set Snit_info(exceptmethods) {}
122
set Snit_info(excepttypemethods) {}
123
set Snit_info(tvardecs) {%TVARDECS%}
124
set Snit_info(ivardecs) {%IVARDECS%}
125
126
# Array: Public methods of this type.
127
# The index is the method name, or "*".
128
# The value is [list $pattern $componentName], where
129
# $componentName is "" for normal methods.
130
typevariable Snit_typemethodInfo
131
array unset Snit_typemethodInfo
132
133
# Array: Public methods of instances of this type.
134
# The index is the method name, or "*".
135
# The value is [list $pattern $componentName], where
136
# $componentName is "" for normal methods.
137
typevariable Snit_methodInfo
138
array unset Snit_methodInfo
139
140
# Array: option information. See dictionary.txt.
141
typevariable Snit_optionInfo
142
array unset Snit_optionInfo
143
set Snit_optionInfo(local) {}
144
set Snit_optionInfo(delegated) {}
145
set Snit_optionInfo(starcomp) {}
146
set Snit_optionInfo(except) {}
147
}
148
149
#----------------------------------------------------------------
150
# Compiled Procs
151
#
152
# These commands are created or replaced during compilation:
153
154
155
# Snit_instanceVars selfns
156
#
157
# Initializes the instance variables, if any. Called during
158
# instance creation.
159
160
proc %TYPE%::Snit_instanceVars {selfns} {
161
%INSTANCEVARS%
162
}
163
164
# Type Constructor
165
proc %TYPE%::Snit_typeconstructor {type} {
166
%TVARDECS%
167
%TCONSTBODY%
168
}
169
170
#----------------------------------------------------------------
171
# Default Procs
172
#
173
# These commands might be replaced during compilation:
174
175
# Snit_destructor type selfns win self
176
#
177
# Default destructor for the type. By default, it does
178
# nothing. It's replaced by any user destructor.
179
# For types, it's called by method destroy; for widgettypes,
180
# it's called by a destroy event handler.
181
182
proc %TYPE%::Snit_destructor {type selfns win self} { }
183
184
#----------------------------------------------------------
185
# Compiled Definitions
186
187
%COMPILEDDEFS%
188
189
#----------------------------------------------------------
190
# Finally, call the Type Constructor
191
192
%TYPE%::Snit_typeconstructor %TYPE%
193
}
194
195
#-----------------------------------------------------------------------
196
# Type procs
197
#
198
# These procs expect the fully-qualified type name to be
199
# substituted in for %TYPE%.
200
201
# This is the nominal type proc. It supports typemethods and
202
# delegated typemethods.
203
set ::snit::nominalTypeProc {
204
# Type dispatcher function. Note: This function lives
205
# in the parent of the %TYPE% namespace! All accesses to
206
# %TYPE% variables and methods must be qualified!
207
proc %TYPE% {{method ""} args} {
208
# First, if there's no method, and no args, and there's a create
209
# method, and this isn't a widget, then method is "create" and
210
# "args" is %AUTO%.
211
if {$method eq "" && [llength $args] == 0} {
212
::variable %TYPE%::Snit_info
213
214
if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
215
set method create
216
lappend args %AUTO%
217
} else {
218
error "wrong \# args: should be \"%TYPE% method args\""
219
}
220
}
221
222
# Next, retrieve the command.
223
variable %TYPE%::Snit_typemethodCache
224
while 1 {
225
if {[catch {set Snit_typemethodCache($method)} commandRec]} {
226
set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]
227
228
if {[llength $commandRec] == 0} {
229
return -code error "\"%TYPE% $method\" is not defined"
230
}
231
}
232
233
# If we've got a real command, break.
234
if {[lindex $commandRec 0] == 0} {
235
break
236
}
237
238
# Otherwise, we need to look up again...if we can.
239
if {[llength $args] == 0} {
240
return -code error \
241
"wrong number args: should be \"%TYPE% $method method args\""
242
}
243
244
lappend method [lindex $args 0]
245
set args [lrange $args 1 end]
246
}
247
248
set command [lindex $commandRec 1]
249
250
# Pass along the return code unchanged.
251
set retval [catch {uplevel 1 $command $args} result]
252
253
if {$retval} {
254
if {$retval == 1} {
255
global errorInfo
256
global errorCode
257
return -code error -errorinfo $errorInfo \
258
-errorcode $errorCode $result
259
} else {
260
return -code $retval $result
261
}
262
}
263
264
return $result
265
}
266
}
267
268
# This is the simplified type proc for when there are no typemethods
269
# except create. In this case, it doesn't take a method argument;
270
# the method is always "create".
271
set ::snit::simpleTypeProc {
272
# Type dispatcher function. Note: This function lives
273
# in the parent of the %TYPE% namespace! All accesses to
274
# %TYPE% variables and methods must be qualified!
275
proc %TYPE% {args} {
276
::variable %TYPE%::Snit_info
277
278
# FIRST, if the are no args, the single arg is %AUTO%
279
if {[llength $args] == 0} {
280
if {$Snit_info(isWidget)} {
281
error "wrong \# args: should be \"%TYPE% name args\""
282
}
283
284
lappend args %AUTO%
285
}
286
287
# NEXT, we're going to call the create method.
288
# Pass along the return code unchanged.
289
if {$Snit_info(isWidget)} {
290
set command [list ::snit::RT.widget.typemethod.create %TYPE%]
291
} else {
292
set command [list ::snit::RT.type.typemethod.create %TYPE%]
293
}
294
295
set retval [catch {uplevel 1 $command $args} result]
296
297
if {$retval} {
298
if {$retval == 1} {
299
global errorInfo
300
global errorCode
301
return -code error -errorinfo $errorInfo \
302
-errorcode $errorCode $result
303
} else {
304
return -code $retval $result
305
}
306
}
307
308
return $result
309
}
310
}
311
312
#-----------------------------------------------------------------------
313
# Instance procs
314
#
315
# The following must be substituted into these proc bodies:
316
#
317
# %SELFNS% The instance namespace
318
# %WIN% The original instance name
319
# %TYPE% The fully-qualified type name
320
#
321
322
# Nominal instance proc body: supports method caching and delegation.
323
#
324
# proc $instanceName {method args} ....
325
set ::snit::nominalInstanceProc {
326
set self [set %SELFNS%::Snit_instance]
327
328
while {1} {
329
if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
330
set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]
331
332
if {[llength $commandRec] == 0} {
333
return -code error \
334
"\"$self $method\" is not defined"
335
}
336
}
337
338
# If we've got a real command, break.
339
if {[lindex $commandRec 0] == 0} {
340
break
341
}
342
343
# Otherwise, we need to look up again...if we can.
344
if {[llength $args] == 0} {
345
return -code error \
346
"wrong number args: should be \"$self $method method args\""
347
}
348
349
lappend method [lindex $args 0]
350
set args [lrange $args 1 end]
351
}
352
353
set command [lindex $commandRec 1]
354
355
# Pass along the return code unchanged.
356
set retval [catch {uplevel 1 $command $args} result]
357
358
if {$retval} {
359
if {$retval == 1} {
360
global errorInfo
361
global errorCode
362
return -code error -errorinfo $errorInfo \
363
-errorcode $errorCode $result
364
} else {
365
return -code $retval $result
366
}
367
}
368
369
return $result
370
}
371
372
# Simplified method proc body: No delegation allowed; no support for
373
# upvar or exotic return codes or hierarchical methods. Designed for
374
# max speed for simple types.
375
#
376
# proc $instanceName {method args} ....
377
378
set ::snit::simpleInstanceProc {
379
set self [set %SELFNS%::Snit_instance]
380
381
if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
382
set optlist [join ${%TYPE%::Snit_methods} ", "]
383
set optlist [linsert $optlist "end-1" "or"]
384
error "bad option \"$method\": must be $optlist"
385
}
386
387
eval [linsert $args 0 \
388
%TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
389
}
390
391
392
#=======================================================================
393
# Snit Type Definition
394
#
395
# These are the procs used to define Snit types, widgets, and
396
# widgetadaptors.
397
398
399
#-----------------------------------------------------------------------
400
# Snit Compilation Variables
401
#
402
# The following variables are used while Snit is compiling a type,
403
# and are disposed afterwards.
404
405
namespace eval ::snit:: {
406
# The compiler variable contains the name of the slave interpreter
407
# used to compile type definitions.
408
variable compiler ""
409
410
# The compile array accumulates information about the type or
411
# widgettype being compiled. It is cleared before and after each
412
# compilation. It has these indices:
413
#
414
# type: The name of the type being compiled, for use
415
# in compilation procs.
416
# defs: Compiled definitions, both standard and client.
417
# which: type, widget, widgetadaptor
418
# instancevars: Instance variable definitions and initializations.
419
# ivprocdec: Instance variable proc declarations.
420
# tvprocdec: Type variable proc declarations.
421
# typeconstructor: Type constructor body.
422
# widgetclass: The widgetclass, for snit::widgets, only
423
# hasoptions: False, initially; set to true when first
424
# option is defined.
425
# localoptions: Names of local options.
426
# delegatedoptions: Names of delegated options.
427
# localmethods: Names of locally defined methods.
428
# delegatesmethods: no if no delegated methods, yes otherwise.
429
# hashierarchic : no if no hierarchic methods, yes otherwise.
430
# components: Names of defined components.
431
# typecomponents: Names of defined typecomponents.
432
# typevars: Typevariable definitions and initializations.
433
# varnames: Names of instance variables
434
# typevarnames Names of type variables
435
# hasconstructor False, initially; true when constructor is
436
# defined.
437
# resource-$opt The option's resource name
438
# class-$opt The option's class
439
# -default-$opt The option's default value
440
# -validatemethod-$opt The option's validate method
441
# -configuremethod-$opt The option's configure method
442
# -cgetmethod-$opt The option's cget method.
443
# -hastypeinfo The -hastypeinfo pragma
444
# -hastypedestroy The -hastypedestroy pragma
445
# -hastypemethods The -hastypemethods pragma
446
# -hasinfo The -hasinfo pragma
447
# -hasinstances The -hasinstances pragma
448
# -simpledispatch The -simpledispatch pragma
449
# -canreplace The -canreplace pragma
450
variable compile
451
452
# This variable accumulates method dispatch information; it has
453
# the same structure as the %TYPE%::Snit_methodInfo array, and is
454
# used to initialize it.
455
variable methodInfo
456
457
# This variable accumulates typemethod dispatch information; it has
458
# the same structure as the %TYPE%::Snit_typemethodInfo array, and is
459
# used to initialize it.
460
variable typemethodInfo
461
462
# The following variable lists the reserved type definition statement
463
# names, e.g., the names you can't use as macros. It's built at
464
# compiler definition time using "info commands".
465
variable reservedwords {}
466
}
467
468
#-----------------------------------------------------------------------
469
# type compilation commands
470
#
471
# The type and widgettype commands use a slave interpreter to compile
472
# the type definition. These are the procs
473
# that are aliased into it.
474
475
# Initialize the compiler
476
proc ::snit::Comp.Init {} {
477
variable compiler
478
variable reservedwords
479
480
if {$compiler eq ""} {
481
# Create the compiler's interpreter
482
set compiler [interp create]
483
484
# Initialize the interpreter
485
$compiler eval {
486
# Load package information
487
# TBD: see if this can be moved outside.
488
catch {package require ::snit::__does_not_exist__}
489
490
# Protect some Tcl commands our type definitions
491
# will shadow.
492
rename proc _proc
493
rename variable _variable
494
}
495
496
# Define compilation aliases.
497
$compiler alias pragma ::snit::Comp.statement.pragma
498
$compiler alias widgetclass ::snit::Comp.statement.widgetclass
499
$compiler alias hulltype ::snit::Comp.statement.hulltype
500
$compiler alias constructor ::snit::Comp.statement.constructor
501
$compiler alias destructor ::snit::Comp.statement.destructor
502
$compiler alias option ::snit::Comp.statement.option
503
$compiler alias oncget ::snit::Comp.statement.oncget
504
$compiler alias onconfigure ::snit::Comp.statement.onconfigure
505
$compiler alias method ::snit::Comp.statement.method
506
$compiler alias typemethod ::snit::Comp.statement.typemethod
507
$compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
508
$compiler alias proc ::snit::Comp.statement.proc
509
$compiler alias typevariable ::snit::Comp.statement.typevariable
510
$compiler alias variable ::snit::Comp.statement.variable
511
$compiler alias typecomponent ::snit::Comp.statement.typecomponent
512
$compiler alias component ::snit::Comp.statement.component
513
$compiler alias delegate ::snit::Comp.statement.delegate
514
$compiler alias expose ::snit::Comp.statement.expose
515
516
# Get the list of reserved words
517
set reservedwords [$compiler eval {info commands}]
518
}
519
}
520
521
# Compile a type definition, and return the results as a list of two
522
# items: the fully-qualified type name, and a script that will define
523
# the type when executed.
524
#
525
# which type, widget, or widgetadaptor
526
# type the type name
527
# body the type definition
528
proc ::snit::Comp.Compile {which type body} {
529
variable typeTemplate
530
variable nominalTypeProc
531
variable simpleTypeProc
532
variable compile
533
variable compiler
534
variable methodInfo
535
variable typemethodInfo
536
537
# FIRST, qualify the name.
538
if {![string match "::*" $type]} {
539
# Get caller's namespace;
540
# append :: if not global namespace.
541
set ns [uplevel 2 [list namespace current]]
542
if {"::" != $ns} {
543
append ns "::"
544
}
545
546
set type "$ns$type"
547
}
548
549
# NEXT, create and initialize the compiler, if needed.
550
Comp.Init
551
552
# NEXT, initialize the class data
553
array unset methodInfo
554
array unset typemethodInfo
555
556
array unset compile
557
set compile(type) $type
558
set compile(defs) {}
559
set compile(which) $which
560
set compile(hasoptions) no
561
set compile(localoptions) {}
562
set compile(instancevars) {}
563
set compile(typevars) {}
564
set compile(delegatedoptions) {}
565
set compile(ivprocdec) {}
566
set compile(tvprocdec) {}
567
set compile(typeconstructor) {}
568
set compile(widgetclass) {}
569
set compile(hulltype) {}
570
set compile(localmethods) {}
571
set compile(delegatesmethods) no
572
set compile(hashierarchic) no
573
set compile(components) {}
574
set compile(typecomponents) {}
575
set compile(varnames) {}
576
set compile(typevarnames) {}
577
set compile(hasconstructor) no
578
set compile(-hastypedestroy) yes
579
set compile(-hastypeinfo) yes
580
set compile(-hastypemethods) yes
581
set compile(-hasinfo) yes
582
set compile(-hasinstances) yes
583
set compile(-simpledispatch) no
584
set compile(-canreplace) no
585
586
set isWidget [string match widget* $which]
587
set isWidgetAdaptor [string match widgetadaptor $which]
588
589
# NEXT, Evaluate the type's definition in the class interpreter.
590
$compiler eval $body
591
592
# NEXT, Add the standard definitions
593
append compile(defs) \
594
"\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
595
596
append compile(defs) \
597
"\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
598
599
# Indicate whether the type can create instances that replace
600
# existing commands.
601
append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
602
603
604
# Check pragmas for conflict.
605
606
if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
607
error "$which $type has neither typemethods nor instances"
608
}
609
610
if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
611
error "$which $type requests -simpledispatch but delegates methods."
612
}
613
614
if {$compile(-simpledispatch) && $compile(hashierarchic)} {
615
error "$which $type requests -simpledispatch but defines hierarchical methods."
616
}
617
618
# If there are typemethods, define the standard typemethods and
619
# the nominal type proc. Otherwise define the simple type proc.
620
if {$compile(-hastypemethods)} {
621
# Add the info typemethod unless the pragma forbids it.
622
if {$compile(-hastypeinfo)} {
623
Comp.statement.delegate typemethod info \
624
using {::snit::RT.typemethod.info %t}
625
}
626
627
# Add the destroy typemethod unless the pragma forbids it.
628
if {$compile(-hastypedestroy)} {
629
Comp.statement.delegate typemethod destroy \
630
using {::snit::RT.typemethod.destroy %t}
631
}
632
633
# Add the nominal type proc.
634
append compile(defs) $nominalTypeProc
635
} else {
636
# Add the simple type proc.
637
append compile(defs) $simpleTypeProc
638
}
639
640
# Add standard methods/typemethods that only make sense if the
641
# type has instances.
642
if {$compile(-hasinstances)} {
643
# If we're using simple dispatch, remember that.
644
if {$compile(-simpledispatch)} {
645
append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
646
}
647
648
# Add the info method unless the pragma forbids it.
649
if {$compile(-hasinfo)} {
650
if {!$compile(-simpledispatch)} {
651
Comp.statement.delegate method info \
652
using {::snit::RT.method.info %t %n %w %s}
653
} else {
654
Comp.statement.method info {args} {
655
eval [linsert $args 0 \
656
::snit::RT.method.info $type $selfns $win $self]
657
}
658
}
659
}
660
661
# Add the option handling stuff if there are any options.
662
if {$compile(hasoptions)} {
663
Comp.statement.variable options
664
665
if {!$compile(-simpledispatch)} {
666
Comp.statement.delegate method cget \
667
using {::snit::RT.method.cget %t %n %w %s}
668
Comp.statement.delegate method configurelist \
669
using {::snit::RT.method.configurelist %t %n %w %s}
670
Comp.statement.delegate method configure \
671
using {::snit::RT.method.configure %t %n %w %s}
672
} else {
673
Comp.statement.method cget {args} {
674
eval [linsert $args 0 \
675
::snit::RT.method.cget $type $selfns $win $self]
676
}
677
Comp.statement.method configurelist {args} {
678
eval [linsert $args 0 \
679
::snit::RT.method.configurelist $type $selfns $win $self]
680
}
681
Comp.statement.method configure {args} {
682
eval [linsert $args 0 \
683
::snit::RT.method.configure $type $selfns $win $self]
684
}
685
}
686
}
687
688
# Add a default constructor, if they haven't already defined one.
689
# If there are options, it will configure args; otherwise it
690
# will do nothing.
691
if {!$compile(hasconstructor)} {
692
if {$compile(hasoptions)} {
693
Comp.statement.constructor {args} {
694
$self configurelist $args
695
}
696
} else {
697
Comp.statement.constructor {} {}
698
}
699
}
700
701
if {!$isWidget} {
702
if {!$compile(-simpledispatch)} {
703
Comp.statement.delegate method destroy \
704
using {::snit::RT.method.destroy %t %n %w %s}
705
} else {
706
Comp.statement.method destroy {args} {
707
eval [linsert $args 0 \
708
::snit::RT.method.destroy $type $selfns $win $self]
709
}
710
}
711
712
Comp.statement.delegate typemethod create \
713
using {::snit::RT.type.typemethod.create %t}
714
} else {
715
Comp.statement.delegate typemethod create \
716
using {::snit::RT.widget.typemethod.create %t}
717
}
718
719
# Save the list of method names, for -simpledispatch; otherwise,
720
# save the method info.
721
if {$compile(-simpledispatch)} {
722
append compile(defs) \
723
"\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
724
} else {
725
append compile(defs) \
726
"\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
727
}
728
729
} else {
730
append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
731
}
732
733
# NEXT, compiling the type definition built up a set of information
734
# about the type's locally defined options; add this information to
735
# the compiled definition.
736
Comp.SaveOptionInfo
737
738
# NEXT, compiling the type definition built up a set of information
739
# about the typemethods; save the typemethod info.
740
append compile(defs) \
741
"\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
742
743
# NEXT, if this is a widget define the hull component if it isn't
744
# already defined.
745
if {$isWidget} {
746
Comp.DefineComponent hull
747
}
748
749
# NEXT, substitute the compiled definition into the type template
750
# to get the type definition script.
751
set defscript [Expand $typeTemplate \
752
%COMPILEDDEFS% $compile(defs)]
753
754
# NEXT, substitute the defined macros into the type definition script.
755
# This is done as a separate step so that the compile(defs) can
756
# contain the macros defined below.
757
758
set defscript [Expand $defscript \
759
%TYPE% $type \
760
%IVARDECS% $compile(ivprocdec) \
761
%TVARDECS% $compile(tvprocdec) \
762
%TCONSTBODY% $compile(typeconstructor) \
763
%INSTANCEVARS% $compile(instancevars) \
764
%TYPEVARS% $compile(typevars) \
765
]
766
767
array unset compile
768
769
return [list $type $defscript]
770
}
771
772
# Information about locally-defined options is accumulated during
773
# compilation, but not added to the compiled definition--the option
774
# statement can appear multiple times, so it's easier this way.
775
# This proc fills in Snit_optionInfo with the accumulated information.
776
#
777
# It also computes the option's resource and class names if needed.
778
#
779
# Note that the information for delegated options was put in
780
# Snit_optionInfo during compilation.
781
782
proc ::snit::Comp.SaveOptionInfo {} {
783
variable compile
784
785
foreach option $compile(localoptions) {
786
if {$compile(resource-$option) eq ""} {
787
set compile(resource-$option) [string range $option 1 end]
788
}
789
790
if {$compile(class-$option) eq ""} {
791
set compile(class-$option) [Capitalize $compile(resource-$option)]
792
}
793
794
# NOTE: Don't verify that the validate, configure, and cget
795
# values name real methods; the methods might be defined outside
796
# the typedefinition using snit::method.
797
798
Mappend compile(defs) {
799
# Option %OPTION%
800
lappend %TYPE%::Snit_optionInfo(local) %OPTION%
801
802
set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
803
set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
804
set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
805
set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
806
set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
807
set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
808
set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
809
set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
810
} %OPTION% $option \
811
%RESOURCE% $compile(resource-$option) \
812
%CLASS% $compile(class-$option) \
813
%DEFAULT% [list $compile(-default-$option)] \
814
%VALIDATE% [list $compile(-validatemethod-$option)] \
815
%CONFIGURE% [list $compile(-configuremethod-$option)] \
816
%CGET% [list $compile(-cgetmethod-$option)] \
817
%READONLY% $compile(-readonly-$option)
818
}
819
}
820
821
822
# Evaluates a compiled type definition, thus making the type available.
823
proc ::snit::Comp.Define {compResult} {
824
# The compilation result is a list containing the fully qualified
825
# type name and a script to evaluate to define the type.
826
set type [lindex $compResult 0]
827
set defscript [lindex $compResult 1]
828
829
# Execute the type definition script.
830
# Consider using namespace eval %TYPE%. See if it's faster.
831
if {[catch {eval $defscript} result]} {
832
namespace delete $type
833
catch {rename $type ""}
834
error $result
835
}
836
837
return $type
838
}
839
840
# Sets pragma options which control how the type is defined.
841
proc ::snit::Comp.statement.pragma {args} {
842
variable compile
843
844
set errRoot "Error in \"pragma...\""
845
846
foreach {opt val} $args {
847
switch -exact -- $opt {
848
-hastypeinfo -
849
-hastypedestroy -
850
-hastypemethods -
851
-hasinstances -
852
-simpledispatch -
853
-hasinfo -
854
-canreplace {
855
if {![string is boolean -strict $val]} {
856
error "$errRoot, \"$opt\" requires a boolean value"
857
}
858
set compile($opt) $val
859
}
860
default {
861
error "$errRoot, unknown pragma"
862
}
863
}
864
}
865
}
866
867
# Defines a widget's option class name.
868
# This statement is only available for snit::widgets,
869
# not for snit::types or snit::widgetadaptors.
870
proc ::snit::Comp.statement.widgetclass {name} {
871
variable compile
872
873
# First, widgetclass can only be set for true widgets
874
if {"widget" != $compile(which)} {
875
error "widgetclass cannot be set for snit::$compile(which)s"
876
}
877
878
# Next, validate the option name. We'll require that it begin
879
# with an uppercase letter.
880
set initial [string index $name 0]
881
if {![string is upper $initial]} {
882
error "widgetclass \"$name\" does not begin with an uppercase letter"
883
}
884
885
if {"" != $compile(widgetclass)} {
886
error "too many widgetclass statements"
887
}
888
889
# Next, save it.
890
Mappend compile(defs) {
891
set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
892
} %WIDGETCLASS% [list $name]
893
894
set compile(widgetclass) $name
895
}
896
897
# Defines a widget's hull type.
898
# This statement is only available for snit::widgets,
899
# not for snit::types or snit::widgetadaptors.
900
proc ::snit::Comp.statement.hulltype {name} {
901
variable compile
902
903
# First, hulltype can only be set for true widgets
904
if {"widget" != $compile(which)} {
905
error "hulltype cannot be set for snit::$compile(which)s"
906
}
907
908
# Next, it must be either "frame" or "toplevel"
909
if {"frame" != $name && "toplevel" != $name} {
910
error "invalid hulltype \"$name\", should be \"frame\" or \"toplevel\""
911
}
912
913
if {"" != $compile(hulltype)} {
914
error "too many hulltype statements"
915
}
916
917
# Next, save it.
918
Mappend compile(defs) {
919
set %TYPE%::Snit_info(hulltype) %HULLTYPE%
920
} %HULLTYPE% $name
921
922
set compile(hulltype) $name
923
}
924
925
# Defines a constructor.
926
proc ::snit::Comp.statement.constructor {arglist body} {
927
variable compile
928
929
CheckArgs "constructor" $arglist
930
931
# Next, add a magic reference to self.
932
set arglist [concat type selfns win self $arglist]
933
934
# Next, add variable declarations to body:
935
set body "%TVARDECS%%IVARDECS%\n$body"
936
937
set compile(hasconstructor) yes
938
append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
939
}
940
941
# Defines a destructor.
942
proc ::snit::Comp.statement.destructor {body} {
943
variable compile
944
945
# Next, add variable declarations to body:
946
set body "%TVARDECS%%IVARDECS%\n$body"
947
948
append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
949
}
950
951
# Defines a type option. The option value can be a triple, specifying
952
# the option's -name, resource name, and class name.
953
proc ::snit::Comp.statement.option {optionDef args} {
954
variable compile
955
956
# First, get the three option names.
957
set option [lindex $optionDef 0]
958
set resourceName [lindex $optionDef 1]
959
set className [lindex $optionDef 2]
960
961
set errRoot "Error in \"option [list $optionDef]...\""
962
963
# Next, validate the option name.
964
if {![Comp.OptionNameIsValid $option]} {
965
error "$errRoot, badly named option \"$option\""
966
}
967
968
if {[Contains $option $compile(delegatedoptions)]} {
969
error "$errRoot, cannot define \"$option\" locally, it has been delegated"
970
}
971
972
if {![Contains $option $compile(localoptions)]} {
973
# Remember that we've seen this one.
974
set compile(hasoptions) yes
975
lappend compile(localoptions) $option
976
977
# Initialize compilation info for this option.
978
set compile(resource-$option) ""
979
set compile(class-$option) ""
980
set compile(-default-$option) ""
981
set compile(-validatemethod-$option) ""
982
set compile(-configuremethod-$option) ""
983
set compile(-cgetmethod-$option) ""
984
set compile(-readonly-$option) 0
985
}
986
987
# NEXT, see if we have a resource name. If so, make sure it
988
# isn't being redefined differently.
989
if {$resourceName ne ""} {
990
if {$compile(resource-$option) eq ""} {
991
# If it's undefined, just save the value.
992
set compile(resource-$option) $resourceName
993
} elseif {$resourceName ne $compile(resource-$option)} {
994
# It's been redefined differently.
995
error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
996
}
997
}
998
999
# NEXT, see if we have a class name. If so, make sure it
1000
# isn't being redefined differently.
1001
if {$className ne ""} {
1002
if {$compile(class-$option) eq ""} {
1003
# If it's undefined, just save the value.
1004
set compile(class-$option) $className
1005
} elseif {$className ne $compile(class-$option)} {
1006
# It's been redefined differently.
1007
error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
1008
}
1009
}
1010
1011
# NEXT, handle the args; it's not an error to redefine these.
1012
if {[llength $args] == 1} {
1013
set compile(-default-$option) [lindex $args 0]
1014
} else {
1015
foreach {optopt val} $args {
1016
switch -exact -- $optopt {
1017
-default -
1018
-validatemethod -
1019
-configuremethod -
1020
-cgetmethod {
1021
set compile($optopt-$option) $val
1022
}
1023
-readonly {
1024
if {![string is boolean -strict $val]} {
1025
error "$errRoot, -readonly requires a boolean, got \"$val\""
1026
}
1027
set compile($optopt-$option) $val
1028
}
1029
default {
1030
error "$errRoot, unknown option definition option \"$optopt\""
1031
}
1032
}
1033
}
1034
}
1035
}
1036
1037
# 1 if the option name is valid, 0 otherwise.
1038
proc ::snit::Comp.OptionNameIsValid {option} {
1039
if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
1040
return 0
1041
}
1042
1043
return 1
1044
}
1045
1046
# Defines an option's cget handler
1047
proc ::snit::Comp.statement.oncget {option body} {
1048
variable compile
1049
1050
set errRoot "Error in \"oncget $option...\""
1051
1052
if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
1053
return -code error "$errRoot, option \"$option\" is delegated"
1054
}
1055
1056
if {[lsearch -exact $compile(localoptions) $option] == -1} {
1057
return -code error "$errRoot, option \"$option\" unknown"
1058
}
1059
1060
# Next, add variable declarations to body:
1061
set body "%TVARDECS%%IVARDECS%\n$body"
1062
1063
Comp.statement.method _cget$option {_option} $body
1064
Comp.statement.option $option -cgetmethod _cget$option
1065
}
1066
1067
# Defines an option's configure handler.
1068
proc ::snit::Comp.statement.onconfigure {option arglist body} {
1069
variable compile
1070
1071
if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
1072
return -code error "onconfigure $option: option \"$option\" is delegated"
1073
}
1074
1075
if {[lsearch -exact $compile(localoptions) $option] == -1} {
1076
return -code error "onconfigure $option: option \"$option\" unknown"
1077
}
1078
1079
if {[llength $arglist] != 1} {
1080
error \
1081
"onconfigure $option handler should have one argument, got \"$arglist\""
1082
}
1083
1084
CheckArgs "onconfigure $option" $arglist
1085
1086
# Next, add a magic reference to the option name
1087
set arglist [concat _option $arglist]
1088
1089
Comp.statement.method _configure$option $arglist $body
1090
Comp.statement.option $option -configuremethod _configure$option
1091
}
1092
1093
# Defines an instance method.
1094
proc ::snit::Comp.statement.method {method arglist body} {
1095
variable compile
1096
variable methodInfo
1097
1098
# FIRST, check the method name against previously defined
1099
# methods.
1100
Comp.CheckMethodName $method 0 ::snit::methodInfo \
1101
"Error in \"method [list $method]...\""
1102
1103
if {[llength $method] > 1} {
1104
set compile(hashierarchic) yes
1105
}
1106
1107
# Remeber this method
1108
lappend compile(localmethods) $method
1109
1110
CheckArgs "method [list $method]" $arglist
1111
1112
# Next, add magic references to type and self.
1113
set arglist [concat type selfns win self $arglist]
1114
1115
# Next, add variable declarations to body:
1116
set body "%TVARDECS%%IVARDECS%\n$body"
1117
1118
# Next, save the definition script.
1119
if {[llength $method] == 1} {
1120
set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1121
Mappend compile(defs) {
1122
proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
1123
} %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1124
} else {
1125
set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1126
1127
Mappend compile(defs) {
1128
proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
1129
} %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
1130
%BODY% [list $body]
1131
}
1132
}
1133
1134
# Check for name collisions; save prefix information.
1135
#
1136
# method The name of the method or typemethod.
1137
# delFlag 1 if delegated, 0 otherwise.
1138
# infoVar The fully qualified name of the array containing
1139
# information about the defined methods.
1140
# errRoot The root string for any error messages.
1141
1142
proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
1143
upvar $infoVar methodInfo
1144
1145
# FIRST, make sure the method name is a valid Tcl list.
1146
if {[catch {lindex $method 0}]} {
1147
error "$errRoot, the name \"$method\" must have list syntax."
1148
}
1149
1150
# NEXT, check whether we can define it.
1151
if {![catch {set methodInfo($method)} data]} {
1152
# We can't redefine methods with submethods.
1153
if {[lindex $data 0] == 1} {
1154
error "$errRoot, \"$method\" has submethods."
1155
}
1156
1157
# You can't delegate a method that's defined locally,
1158
# and you can't define a method locally if it's been delegated.
1159
if {$delFlag && [lindex $data 2] eq ""} {
1160
error "$errRoot, \"$method\" has been defined locally."
1161
} elseif {!$delFlag && [lindex $data 2] ne ""} {
1162
error "$errRoot, \"$method\" has been delegated"
1163
}
1164
}
1165
1166
# Handle hierarchical case.
1167
if {[llength $method] > 1} {
1168
set prefix {}
1169
set tokens $method
1170
while {[llength $tokens] > 1} {
1171
lappend prefix [lindex $tokens 0]
1172
set tokens [lrange $tokens 1 end]
1173
1174
if {![catch {set methodInfo($prefix)} result]} {
1175
# Prefix is known. If it's not a prefix, throw an
1176
# error.
1177
if {[lindex $result 0] == 0} {
1178
error "$errRoot, \"$prefix\" has no submethods."
1179
}
1180
}
1181
1182
set methodInfo($prefix) [list 1]
1183
}
1184
}
1185
}
1186
1187
# Defines a typemethod method.
1188
proc ::snit::Comp.statement.typemethod {method arglist body} {
1189
variable compile
1190
variable typemethodInfo
1191
1192
# FIRST, check the typemethod name against previously defined
1193
# typemethods.
1194
Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
1195
"Error in \"typemethod [list $method]...\""
1196
1197
CheckArgs "typemethod $method" $arglist
1198
1199
# First, add magic reference to type.
1200
set arglist [concat type $arglist]
1201
1202
# Next, add typevariable declarations to body:
1203
set body "%TVARDECS%\n$body"
1204
1205
# Next, save the definition script
1206
if {[llength $method] == 1} {
1207
set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1208
1209
Mappend compile(defs) {
1210
proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
1211
} %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1212
} else {
1213
set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1214
1215
Mappend compile(defs) {
1216
proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
1217
} %JMETHOD% [join $method _] \
1218
%ARGLIST% [list $arglist] %BODY% [list $body]
1219
}
1220
}
1221
1222
1223
# Defines a type constructor.
1224
proc ::snit::Comp.statement.typeconstructor {body} {
1225
variable compile
1226
1227
if {"" != $compile(typeconstructor)} {
1228
error "too many typeconstructors"
1229
}
1230
1231
set compile(typeconstructor) $body
1232
}
1233
1234
# Defines a static proc in the type's namespace.
1235
proc ::snit::Comp.statement.proc {proc arglist body} {
1236
variable compile
1237
1238
# If "ns" is defined, the proc can see instance variables.
1239
if {[lsearch -exact $arglist selfns] != -1} {
1240
# Next, add instance variable declarations to body:
1241
set body "%IVARDECS%\n$body"
1242
}
1243
1244
# The proc can always see typevariables.
1245
set body "%TVARDECS%\n$body"
1246
1247
append compile(defs) "
1248
1249
# Proc $proc
1250
proc [list %TYPE%::$proc $arglist $body]
1251
"
1252
}
1253
1254
# Defines a static variable in the type's namespace.
1255
proc ::snit::Comp.statement.typevariable {name args} {
1256
variable compile
1257
1258
set errRoot "Error in \"typevariable $name...\""
1259
1260
set len [llength $args]
1261
1262
if {$len > 2 ||
1263
($len == 2 && [lindex $args 0] ne "-array")} {
1264
error "$errRoot, too many initializers"
1265
}
1266
1267
if {[lsearch -exact $compile(varnames) $name] != -1} {
1268
error "$errRoot, \"$name\" is already an instance variable"
1269
}
1270
1271
lappend compile(typevarnames) $name
1272
1273
if {$len == 1} {
1274
append compile(typevars) \
1275
"\n\t [list ::variable $name [lindex $args 0]]"
1276
} elseif {$len == 2} {
1277
append compile(typevars) \
1278
"\n\t [list ::variable $name]"
1279
append compile(typevars) \
1280
"\n\t [list array set $name [lindex $args 1]]"
1281
} else {
1282
append compile(typevars) \
1283
"\n\t [list ::variable $name]"
1284
}
1285
1286
append compile(tvprocdec) "\n\t typevariable ${name}"
1287
}
1288
1289
# Defines an instance variable; the definition will go in the
1290
# type's create typemethod.
1291
proc ::snit::Comp.statement.variable {name args} {
1292
variable compile
1293
1294
set errRoot "Error in \"variable $name...\""
1295
1296
set len [llength $args]
1297
1298
if {$len > 2 ||
1299
($len == 2 && [lindex $args 0] ne "-array")} {
1300
error "$errRoot, too many initializers"
1301
}
1302
1303
if {[lsearch -exact $compile(typevarnames) $name] != -1} {
1304
error "$errRoot, \"$name\" is already a typevariable"
1305
}
1306
1307
lappend compile(varnames) $name
1308
1309
if {$len == 1} {
1310
append compile(instancevars) \
1311
"\nset \${selfns}::$name [list [lindex $args 0]]\n"
1312
} elseif {$len == 2} {
1313
append compile(instancevars) \
1314
"\narray set \${selfns}::$name [list [lindex $args 1]]\n"
1315
}
1316
1317
append compile(ivprocdec) "\n\t "
1318
Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
1319
}
1320
1321
# Defines a typecomponent, and handles component options.
1322
#
1323
# component The logical name of the delegate
1324
# args options.
1325
1326
proc ::snit::Comp.statement.typecomponent {component args} {
1327
variable compile
1328
1329
set errRoot "Error in \"typecomponent $component...\""
1330
1331
# FIRST, define the component
1332
Comp.DefineTypecomponent $component $errRoot
1333
1334
# NEXT, handle the options.
1335
set publicMethod ""
1336
set inheritFlag 0
1337
1338
foreach {opt val} $args {
1339
switch -exact -- $opt {
1340
-public {
1341
set publicMethod $val
1342
}
1343
-inherit {
1344
set inheritFlag $val
1345
if {![string is boolean $inheritFlag]} {
1346
error "typecomponent $component -inherit: expected boolean value, got \"$val\""
1347
}
1348
}
1349
default {
1350
error "typecomponent $component: Invalid option \"$opt\""
1351
}
1352
}
1353
}
1354
1355
# NEXT, if -public specified, define the method.
1356
if {$publicMethod ne ""} {
1357
Comp.statement.delegate typemethod [list $publicMethod *] to $component
1358
}
1359
1360
# NEXT, if "-inherit 1" is specified, delegate typemethod * to
1361
# this component.
1362
if {$inheritFlag} {
1363
Comp.statement.delegate typemethod "*" to $component
1364
}
1365
1366
}
1367
1368
1369
# Defines a name to be a typecomponent
1370
#
1371
# The name becomes a typevariable; in addition, it gets a
1372
# write trace so that when it is set, all of the component mechanisms
1373
# get updated.
1374
#
1375
# component The component name
1376
1377
proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
1378
variable compile
1379
1380
if {[lsearch -exact $compile(varnames) $component] != -1} {
1381
error "$errRoot, \"$component\" is already an instance variable"
1382
}
1383
1384
if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1385
# Remember we've done this.
1386
lappend compile(typecomponents) $component
1387
1388
# Make it a type variable with no initial value
1389
Comp.statement.typevariable $component ""
1390
1391
# Add a write trace to do the component thing.
1392
Mappend compile(typevars) {
1393
trace add variable %COMP% write \
1394
[list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
1395
} %TYPE% $compile(type) %COMP% $component
1396
}
1397
}
1398
1399
# Defines a component, and handles component options.
1400
#
1401
# component The logical name of the delegate
1402
# args options.
1403
#
1404
# TBD: Ideally, it should be possible to call this statement multiple
1405
# times, possibly changing the option values. To do that, I'd need
1406
# to cache the option values and not act on them until *after* I'd
1407
# read the entire type definition.
1408
1409
proc ::snit::Comp.statement.component {component args} {
1410
variable compile
1411
1412
set errRoot "Error in \"component $component...\""
1413
1414
# FIRST, define the component
1415
Comp.DefineComponent $component $errRoot
1416
1417
# NEXT, handle the options.
1418
set publicMethod ""
1419
set inheritFlag 0
1420
1421
foreach {opt val} $args {
1422
switch -exact -- $opt {
1423
-public {
1424
set publicMethod $val
1425
}
1426
-inherit {
1427
set inheritFlag $val
1428
if {![string is boolean $inheritFlag]} {
1429
error "component $component -inherit: expected boolean value, got \"$val\""
1430
}
1431
}
1432
default {
1433
error "component $component: Invalid option \"$opt\""
1434
}
1435
}
1436
}
1437
1438
# NEXT, if -public specified, define the method.
1439
if {$publicMethod ne ""} {
1440
Comp.statement.delegate method [list $publicMethod *] to $component
1441
}
1442
1443
# NEXT, if -inherit is specified, delegate method/option * to
1444
# this component.
1445
if {$inheritFlag} {
1446
Comp.statement.delegate method "*" to $component
1447
Comp.statement.delegate option "*" to $component
1448
}
1449
}
1450
1451
1452
# Defines a name to be a component
1453
#
1454
# The name becomes an instance variable; in addition, it gets a
1455
# write trace so that when it is set, all of the component mechanisms
1456
# get updated.
1457
#
1458
# component The component name
1459
1460
proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
1461
variable compile
1462
1463
if {[lsearch -exact $compile(typevarnames) $component] != -1} {
1464
error "$errRoot, \"$component\" is already a typevariable"
1465
}
1466
1467
if {[lsearch -exact $compile(components) $component] == -1} {
1468
# Remember we've done this.
1469
lappend compile(components) $component
1470
1471
# Make it an instance variable with no initial value
1472
Comp.statement.variable $component ""
1473
1474
# Add a write trace to do the component thing.
1475
Mappend compile(instancevars) {
1476
trace add variable ${selfns}::%COMP% write \
1477
[list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
1478
} %TYPE% $compile(type) %COMP% $component
1479
}
1480
}
1481
1482
# Creates a delegated method, typemethod, or option.
1483
proc ::snit::Comp.statement.delegate {what name args} {
1484
# FIRST, dispatch to correct handler.
1485
switch $what {
1486
typemethod { Comp.DelegatedTypemethod $name $args }
1487
method { Comp.DelegatedMethod $name $args }
1488
option { Comp.DelegatedOption $name $args }
1489
default {
1490
error "Error in \"delegate $what $name...\", \"$what\"?"
1491
}
1492
}
1493
1494
if {([llength $args] % 2) != 0} {
1495
error "Error in \"delegate $what $name...\", invalid syntax"
1496
}
1497
}
1498
1499
# Creates a delegated typemethod delegating it to a particular
1500
# typecomponent or an arbitrary command.
1501
#
1502
# method The name of the method
1503
# arglist Delegation options
1504
1505
proc ::snit::Comp.DelegatedTypemethod {method arglist} {
1506
variable compile
1507
variable typemethodInfo
1508
1509
set errRoot "Error in \"delegate typemethod [list $method]...\""
1510
1511
# Next, parse the delegation options.
1512
set component ""
1513
set target ""
1514
set exceptions {}
1515
set pattern ""
1516
set methodTail [lindex $method end]
1517
1518
foreach {opt value} $arglist {
1519
switch -exact $opt {
1520
to { set component $value }
1521
as { set target $value }
1522
except { set exceptions $value }
1523
using { set pattern $value }
1524
default {
1525
error "$errRoot, unknown delegation option \"$opt\""
1526
}
1527
}
1528
}
1529
1530
if {$component eq "" && $pattern eq ""} {
1531
error "$errRoot, missing \"to\""
1532
}
1533
1534
if {$methodTail eq "*" && $target ne ""} {
1535
error "$errRoot, cannot specify \"as\" with \"*\""
1536
}
1537
1538
if {$methodTail ne "*" && $exceptions ne ""} {
1539
error "$errRoot, can only specify \"except\" with \"*\""
1540
}
1541
1542
if {$pattern ne "" && $target ne ""} {
1543
error "$errRoot, cannot specify both \"as\" and \"using\""
1544
}
1545
1546
foreach token [lrange $method 1 end-1] {
1547
if {$token eq "*"} {
1548
error "$errRoot, \"*\" must be the last token."
1549
}
1550
}
1551
1552
# NEXT, define the component
1553
if {$component ne ""} {
1554
Comp.DefineTypecomponent $component $errRoot
1555
}
1556
1557
# NEXT, define the pattern.
1558
if {$pattern eq ""} {
1559
if {$methodTail eq "*"} {
1560
set pattern "%c %m"
1561
} elseif {$target ne ""} {
1562
set pattern "%c $target"
1563
} else {
1564
set pattern "%c %m"
1565
}
1566
}
1567
1568
# Make sure the pattern is a valid list.
1569
if {[catch {lindex $pattern 0} result]} {
1570
error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1571
}
1572
1573
# NEXT, check the method name against previously defined
1574
# methods.
1575
Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
1576
1577
set typemethodInfo($method) [list 0 $pattern $component]
1578
1579
if {[string equal $methodTail "*"]} {
1580
Mappend compile(defs) {
1581
set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
1582
} %EXCEPT% [list $exceptions]
1583
}
1584
}
1585
1586
1587
# Creates a delegated method delegating it to a particular
1588
# component or command.
1589
#
1590
# method The name of the method
1591
# arglist Delegation options.
1592
1593
proc ::snit::Comp.DelegatedMethod {method arglist} {
1594
variable compile
1595
variable methodInfo
1596
1597
set errRoot "Error in \"delegate method [list $method]...\""
1598
1599
# Next, parse the delegation options.
1600
set component ""
1601
set target ""
1602
set exceptions {}
1603
set pattern ""
1604
set methodTail [lindex $method end]
1605
1606
foreach {opt value} $arglist {
1607
switch -exact $opt {
1608
to { set component $value }
1609
as { set target $value }
1610
except { set exceptions $value }
1611
using { set pattern $value }
1612
default {
1613
error "$errRoot, unknown delegation option \"$opt\""
1614
}
1615
}
1616
}
1617
1618
if {$component eq "" && $pattern eq ""} {
1619
error "$errRoot, missing \"to\""
1620
}
1621
1622
if {$methodTail eq "*" && $target ne ""} {
1623
error "$errRoot, cannot specify \"as\" with \"*\""
1624
}
1625
1626
if {$methodTail ne "*" && $exceptions ne ""} {
1627
error "$errRoot, can only specify \"except\" with \"*\""
1628
}
1629
1630
if {$pattern ne "" && $target ne ""} {
1631
error "$errRoot, cannot specify both \"as\" and \"using\""
1632
}
1633
1634
foreach token [lrange $method 1 end-1] {
1635
if {$token eq "*"} {
1636
error "$errRoot, \"*\" must be the last token."
1637
}
1638
}
1639
1640
# NEXT, we delegate some methods
1641
set compile(delegatesmethods) yes
1642
1643
# NEXT, define the component. Allow typecomponents.
1644
if {$component ne ""} {
1645
if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1646
Comp.DefineComponent $component $errRoot
1647
}
1648
}
1649
1650
# NEXT, define the pattern.
1651
if {$pattern eq ""} {
1652
if {$methodTail eq "*"} {
1653
set pattern "%c %m"
1654
} elseif {$target ne ""} {
1655
set pattern "%c $target"
1656
} else {
1657
set pattern "%c %m"
1658
}
1659
}
1660
1661
# Make sure the pattern is a valid list.
1662
if {[catch {lindex $pattern 0} result]} {
1663
error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1664
}
1665
1666
# NEXT, check the method name against previously defined
1667
# methods.
1668
Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
1669
1670
# NEXT, save the method info.
1671
set methodInfo($method) [list 0 $pattern $component]
1672
1673
if {[string equal $methodTail "*"]} {
1674
Mappend compile(defs) {
1675
set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
1676
} %EXCEPT% [list $exceptions]
1677
}
1678
}
1679
1680
# Creates a delegated option, delegating it to a particular
1681
# component and, optionally, to a particular option of that
1682
# component.
1683
#
1684
# optionDef The option definition
1685
# args definition arguments.
1686
1687
proc ::snit::Comp.DelegatedOption {optionDef arglist} {
1688
variable compile
1689
1690
# First, get the three option names.
1691
set option [lindex $optionDef 0]
1692
set resourceName [lindex $optionDef 1]
1693
set className [lindex $optionDef 2]
1694
1695
set errRoot "Error in \"delegate option [list $optionDef]...\""
1696
1697
# Next, parse the delegation options.
1698
set component ""
1699
set target ""
1700
set exceptions {}
1701
1702
foreach {opt value} $arglist {
1703
switch -exact $opt {
1704
to { set component $value }
1705
as { set target $value }
1706
except { set exceptions $value }
1707
default {
1708
error "$errRoot, unknown delegation option \"$opt\""
1709
}
1710
}
1711
}
1712
1713
if {$component eq ""} {
1714
error "$errRoot, missing \"to\""
1715
}
1716
1717
if {$option eq "*" && $target ne ""} {
1718
error "$errRoot, cannot specify \"as\" with \"delegate option *\""
1719
}
1720
1721
if {$option ne "*" && $exceptions ne ""} {
1722
error "$errRoot, can only specify \"except\" with \"delegate option *\""
1723
}
1724
1725
# Next, validate the option name
1726
1727
if {"*" != $option} {
1728
if {![Comp.OptionNameIsValid $option]} {
1729
error "$errRoot, badly named option \"$option\""
1730
}
1731
}
1732
1733
if {[Contains $option $compile(localoptions)]} {
1734
error "$errRoot, \"$option\" has been defined locally"
1735
}
1736
1737
if {[Contains $option $compile(delegatedoptions)]} {
1738
error "$errRoot, \"$option\" is multiply delegated"
1739
}
1740
1741
# NEXT, define the component
1742
Comp.DefineComponent $component $errRoot
1743
1744
# Next, define the target option, if not specified.
1745
if {![string equal $option "*"] &&
1746
[string equal $target ""]} {
1747
set target $option
1748
}
1749
1750
# NEXT, save the delegation data.
1751
set compile(hasoptions) yes
1752
1753
if {![string equal $option "*"]} {
1754
lappend compile(delegatedoptions) $option
1755
1756
# Next, compute the resource and class names, if they aren't
1757
# already defined.
1758
1759
if {"" == $resourceName} {
1760
set resourceName [string range $option 1 end]
1761
}
1762
1763
if {"" == $className} {
1764
set className [Capitalize $resourceName]
1765
}
1766
1767
Mappend compile(defs) {
1768
set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
1769
set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
1770
set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
1771
lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
1772
set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
1773
lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
1774
} %OPTION% $option \
1775
%COMP% $component \
1776
%TARGET% $target \
1777
%RES% $resourceName \
1778
%CLASS% $className
1779
} else {
1780
Mappend compile(defs) {
1781
set %TYPE%::Snit_optionInfo(starcomp) %COMP%
1782
set %TYPE%::Snit_optionInfo(except) %EXCEPT%
1783
} %COMP% $component %EXCEPT% [list $exceptions]
1784
}
1785
}
1786
1787
# Exposes a component, effectively making the component's command an
1788
# instance method.
1789
#
1790
# component The logical name of the delegate
1791
# "as" sugar; if not "", must be "as"
1792
# methodname The desired method name for the component's command, or ""
1793
1794
proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
1795
variable compile
1796
1797
1798
# FIRST, define the component
1799
Comp.DefineComponent $component
1800
1801
# NEXT, define the method just as though it were in the type
1802
# definition.
1803
if {[string equal $methodname ""]} {
1804
set methodname $component
1805
}
1806
1807
Comp.statement.method $methodname args [Expand {
1808
if {[llength $args] == 0} {
1809
return $%COMPONENT%
1810
}
1811
1812
if {[string equal $%COMPONENT% ""]} {
1813
error "undefined component \"%COMPONENT%\""
1814
}
1815
1816
1817
set cmd [linsert $args 0 $%COMPONENT%]
1818
return [uplevel 1 $cmd]
1819
} %COMPONENT% $component]
1820
}
1821
1822
1823
1824
#-----------------------------------------------------------------------
1825
# Public commands
1826
1827
# Compile a type definition, and return the results as a list of two
1828
# items: the fully-qualified type name, and a script that will define
1829
# the type when executed.
1830
#
1831
# which type, widget, or widgetadaptor
1832
# type the type name
1833
# body the type definition
1834
proc ::snit::compile {which type body} {
1835
return [Comp.Compile $which $type $body]
1836
}
1837
1838
proc ::snit::type {type body} {
1839
return [Comp.Define [Comp.Compile type $type $body]]
1840
}
1841
1842
proc ::snit::widget {type body} {
1843
return [Comp.Define [Comp.Compile widget $type $body]]
1844
}
1845
1846
proc ::snit::widgetadaptor {type body} {
1847
return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
1848
}
1849
1850
proc ::snit::typemethod {type method arglist body} {
1851
# Make sure the type exists.
1852
if {![info exists ${type}::Snit_info]} {
1853
error "no such type: \"$type\""
1854
}
1855
1856
upvar ${type}::Snit_info Snit_info
1857
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
1858
1859
# FIRST, check the typemethod name against previously defined
1860
# typemethods.
1861
Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
1862
"Cannot define \"$method\""
1863
1864
# NEXT, check the arguments
1865
CheckArgs "snit::typemethod $type $method" $arglist
1866
1867
# Next, add magic reference to type.
1868
set arglist [concat type $arglist]
1869
1870
# Next, add typevariable declarations to body:
1871
set body "$Snit_info(tvardecs)\n$body"
1872
1873
# Next, define it.
1874
if {[llength $method] == 1} {
1875
set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1876
uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
1877
} else {
1878
set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1879
set suffix [join $method _]
1880
uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
1881
}
1882
}
1883
1884
proc ::snit::method {type method arglist body} {
1885
# Make sure the type exists.
1886
if {![info exists ${type}::Snit_info]} {
1887
error "no such type: \"$type\""
1888
}
1889
1890
upvar ${type}::Snit_methodInfo Snit_methodInfo
1891
upvar ${type}::Snit_info Snit_info
1892
1893
# FIRST, check the method name against previously defined
1894
# methods.
1895
Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
1896
"Cannot define \"$method\""
1897
1898
# NEXT, check the arguments
1899
CheckArgs "snit::method $type $method" $arglist
1900
1901
# Next, add magic references to type and self.
1902
set arglist [concat type selfns win self $arglist]
1903
1904
# Next, add variable declarations to body:
1905
set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"
1906
1907
# Next, define it.
1908
if {[llength $method] == 1} {
1909
set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1910
uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
1911
} else {
1912
set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1913
1914
set suffix [join $method _]
1915
uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
1916
}
1917
}
1918
1919
# Defines a proc within the compiler; this proc can call other
1920
# type definition statements, and thus can be used for meta-programming.
1921
proc ::snit::macro {name arglist body} {
1922
variable compiler
1923
variable reservedwords
1924
1925
# FIRST, make sure the compiler is defined.
1926
Comp.Init
1927
1928
# NEXT, check the macro name against the reserved words
1929
if {[lsearch -exact $reservedwords $name] != -1} {
1930
error "invalid macro name \"$name\""
1931
}
1932
1933
# NEXT, see if the name has a namespace; if it does, define the
1934
# namespace.
1935
set ns [namespace qualifiers $name]
1936
1937
if {$ns ne ""} {
1938
$compiler eval "namespace eval $ns {}"
1939
}
1940
1941
# NEXT, define the macro
1942
$compiler eval [list _proc $name $arglist $body]
1943
}
1944
1945
#-----------------------------------------------------------------------
1946
# Utility Functions
1947
#
1948
# These are utility functions used while compiling Snit types.
1949
1950
# Builds a template from a tagged list of text blocks, then substitutes
1951
# all symbols in the mapTable, returning the expanded template.
1952
proc ::snit::Expand {template args} {
1953
return [string map $args $template]
1954
}
1955
1956
# Expands a template and appends it to a variable.
1957
proc ::snit::Mappend {varname template args} {
1958
upvar $varname myvar
1959
1960
append myvar [string map $args $template]
1961
}
1962
1963
# Checks argument list against reserved args
1964
proc ::snit::CheckArgs {which arglist} {
1965
variable reservedArgs
1966
1967
foreach name $reservedArgs {
1968
if {[Contains $name $arglist]} {
1969
error "$which's arglist may not contain \"$name\" explicitly"
1970
}
1971
}
1972
}
1973
1974
# Returns 1 if a value is in a list, and 0 otherwise.
1975
proc ::snit::Contains {value list} {
1976
if {[lsearch -exact $list $value] != -1} {
1977
return 1
1978
} else {
1979
return 0
1980
}
1981
}
1982
1983
# Capitalizes the first letter of a string.
1984
proc ::snit::Capitalize {text} {
1985
set first [string index $text 0]
1986
set rest [string range $text 1 end]
1987
return "[string toupper $first]$rest"
1988
}
1989
1990
# Converts an arbitrary white-space-delimited string into a list
1991
# by splitting on white-space and deleting empty tokens.
1992
1993
proc ::snit::Listify {str} {
1994
set result {}
1995
foreach token [split [string trim $str]] {
1996
if {[string length $token] > 0} {
1997
lappend result $token
1998
}
1999
}
2000
2001
return $result
2002
}
2003
2004
2005
#=======================================================================
2006
# Snit Runtime Library
2007
#
2008
# These are procs used by Snit types and widgets at runtime.
2009
2010
#-----------------------------------------------------------------------
2011
# Object Creation
2012
2013
# Creates a new instance of the snit::type given its name and the args.
2014
#
2015
# type The snit::type
2016
# name The instance name
2017
# args Args to pass to the constructor
2018
2019
proc ::snit::RT.type.typemethod.create {type name args} {
2020
variable ${type}::Snit_info
2021
variable ${type}::Snit_optionInfo
2022
2023
# FIRST, qualify the name.
2024
if {![string match "::*" $name]} {
2025
# Get caller's namespace;
2026
# append :: if not global namespace.
2027
set ns [uplevel 1 [list namespace current]]
2028
if {"::" != $ns} {
2029
append ns "::"
2030
}
2031
2032
set name "$ns$name"
2033
}
2034
2035
# NEXT, if %AUTO% appears in the name, generate a unique
2036
# command name. Otherwise, ensure that the name isn't in use.
2037
if {[string match "*%AUTO%*" $name]} {
2038
set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2039
} elseif {!$Snit_info(canreplace) && [info commands $name] ne ""} {
2040
error "command \"$name\" already exists"
2041
}
2042
2043
# NEXT, create the instance's namespace.
2044
set selfns \
2045
[::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2046
namespace eval $selfns {}
2047
2048
# NEXT, install the dispatcher
2049
RT.MakeInstanceCommand $type $selfns $name
2050
2051
# Initialize the options to their defaults.
2052
upvar ${selfns}::options options
2053
foreach opt $Snit_optionInfo(local) {
2054
set options($opt) $Snit_optionInfo(default-$opt)
2055
}
2056
2057
# Initialize the instance vars to their defaults.
2058
# selfns must be defined, as it is used implicitly.
2059
${type}::Snit_instanceVars $selfns
2060
2061
# Execute the type's constructor.
2062
set errcode [catch {
2063
RT.ConstructInstance $type $selfns $name $args
2064
} result]
2065
2066
if {$errcode} {
2067
global errorInfo
2068
global errorCode
2069
2070
set theInfo $errorInfo
2071
set theCode $errorCode
2072
::snit::RT.DestroyObject $type $selfns $name
2073
error "Error in constructor: $result" $theInfo $theCode
2074
}
2075
2076
# NEXT, return the object's name.
2077
return $name
2078
}
2079
2080
# Creates a new instance of the snit::widget or snit::widgetadaptor
2081
# given its name and the args.
2082
#
2083
# type The snit::widget or snit::widgetadaptor
2084
# name The instance name
2085
# args Args to pass to the constructor
2086
2087
proc ::snit::RT.widget.typemethod.create {type name args} {
2088
variable ${type}::Snit_info
2089
variable ${type}::Snit_optionInfo
2090
2091
# FIRST, if %AUTO% appears in the name, generate a unique
2092
# command name.
2093
if {[string match "*%AUTO%*" $name]} {
2094
set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2095
}
2096
2097
# NEXT, create the instance's namespace.
2098
set selfns \
2099
[::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2100
namespace eval $selfns { }
2101
2102
# NEXT, Initialize the widget's own options to their defaults.
2103
upvar ${selfns}::options options
2104
foreach opt $Snit_optionInfo(local) {
2105
set options($opt) $Snit_optionInfo(default-$opt)
2106
}
2107
2108
# Initialize the instance vars to their defaults.
2109
${type}::Snit_instanceVars $selfns
2110
2111
# NEXT, if this is a normal widget (not a widget adaptor) then
2112
# create a frame as its hull. We set the frame's -class to
2113
# the user's widgetclass, or, if none, to the basename of
2114
# the $type with an initial upper case letter.
2115
if {!$Snit_info(isWidgetAdaptor)} {
2116
# FIRST, determine the class name
2117
if {"" == $Snit_info(widgetclass)} {
2118
set Snit_info(widgetclass) \
2119
[::snit::Capitalize [namespace tail $type]]
2120
}
2121
2122
# NEXT, create the widget
2123
set self $name
2124
package require Tk
2125
${type}::installhull using \
2126
$Snit_info(hulltype) -class $Snit_info(widgetclass)
2127
2128
# NEXT, let's query the option database for our
2129
# widget, now that we know that it exists.
2130
foreach opt $Snit_optionInfo(local) {
2131
set dbval [RT.OptionDbGet $type $name $opt]
2132
2133
if {"" != $dbval} {
2134
set options($opt) $dbval
2135
}
2136
}
2137
}
2138
2139
# Execute the type's constructor, and verify that it
2140
# has a hull.
2141
set errcode [catch {
2142
RT.ConstructInstance $type $selfns $name $args
2143
2144
::snit::RT.Component $type $selfns hull
2145
2146
# Prepare to call the object's destructor when the
2147
# <Destroy> event is received. Use a Snit-specific bindtag
2148
# so that the widget name's tag is unencumbered.
2149
2150
bind Snit$type$name <Destroy> [::snit::Expand {
2151
::snit::RT.DestroyObject %TYPE% %NS% %W
2152
} %TYPE% $type %NS% $selfns]
2153
2154
# Insert the bindtag into the list of bindtags right
2155
# after the widget name.
2156
set taglist [bindtags $name]
2157
set ndx [lsearch -exact $taglist $name]
2158
incr ndx
2159
bindtags $name [linsert $taglist $ndx Snit$type$name]
2160
} result]
2161
2162
if {$errcode} {
2163
global errorInfo
2164
global errorCode
2165
2166
set theInfo $errorInfo
2167
set theCode $errorCode
2168
::snit::RT.DestroyObject $type $selfns $name
2169
error "Error in constructor: $result" $theInfo $theCode
2170
}
2171
2172
# NEXT, return the object's name.
2173
return $name
2174
}
2175
2176
2177
# RT.MakeInstanceCommand type selfns instance
2178
#
2179
# type The object type
2180
# selfns The instance namespace
2181
# instance The instance name
2182
#
2183
# Creates the instance proc.
2184
2185
proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
2186
variable ${type}::Snit_info
2187
2188
# FIRST, remember the instance name. The Snit_instance variable
2189
# allows the instance to figure out its current name given the
2190
# instance namespace.
2191
upvar ${selfns}::Snit_instance Snit_instance
2192
set Snit_instance $instance
2193
2194
# NEXT, qualify the proc name if it's a widget.
2195
if {$Snit_info(isWidget)} {
2196
set procname ::$instance
2197
} else {
2198
set procname $instance
2199
}
2200
2201
# NEXT, install the new proc
2202
if {!$Snit_info(simpledispatch)} {
2203
set instanceProc $::snit::nominalInstanceProc
2204
} else {
2205
set instanceProc $::snit::simpleInstanceProc
2206
}
2207
2208
proc $procname {method args} \
2209
[string map \
2210
[list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \
2211
$instanceProc]
2212
2213
# NEXT, add the trace.
2214
trace add command $procname {rename delete} \
2215
[list ::snit::RT.InstanceTrace $type $selfns $instance]
2216
}
2217
2218
# This proc is called when the instance command is renamed.
2219
# If op is delete, then new will always be "", so op is redundant.
2220
#
2221
# type The fully-qualified type name
2222
# selfns The instance namespace
2223
# win The original instance/tk window name.
2224
# old old instance command name
2225
# new new instance command name
2226
# op rename or delete
2227
#
2228
# If the op is delete, we need to clean up the object; otherwise,
2229
# we need to track the change.
2230
#
2231
# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
2232
# traces aren't propagated correctly. Instead, they silently
2233
# vanish. Add a catch to output any error message.
2234
2235
proc ::snit::RT.InstanceTrace {type selfns win old new op} {
2236
variable ${type}::Snit_info
2237
2238
# Note to developers ...
2239
# For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
2240
# Therefore we catch them here and create some output to help in
2241
# debugging such problems.
2242
2243
if {[catch {
2244
# FIRST, clean up if necessary
2245
if {"" == $new} {
2246
if {$Snit_info(isWidget)} {
2247
destroy $win
2248
} else {
2249
::snit::RT.DestroyObject $type $selfns $win
2250
}
2251
} else {
2252
# Otherwise, track the change.
2253
variable ${selfns}::Snit_instance
2254
set Snit_instance [uplevel 1 [list namespace which -command $new]]
2255
2256
# Also, clear the instance caches, as many cached commands
2257
# might be invalid.
2258
RT.ClearInstanceCaches $selfns
2259
}
2260
} result]} {
2261
global errorInfo
2262
# Pop up the console on Windows wish, to enable stdout.
2263
# This clobbers errorInfo on unix, so save it so we can print it.
2264
set ei $errorInfo
2265
catch {console show}
2266
puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
2267
puts $ei
2268
}
2269
}
2270
2271
# Calls the instance constructor and handles related housekeeping.
2272
proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
2273
variable ${type}::Snit_optionInfo
2274
variable ${selfns}::Snit_iinfo
2275
2276
# Track whether we are constructed or not.
2277
set Snit_iinfo(constructed) 0
2278
2279
# Call the user's constructor
2280
eval [linsert $arglist 0 \
2281
${type}::Snit_constructor $type $selfns $instance $instance]
2282
2283
set Snit_iinfo(constructed) 1
2284
2285
# Unset the configure cache for all -readonly options.
2286
# This ensures that the next time anyone tries to
2287
# configure it, an error is thrown.
2288
foreach opt $Snit_optionInfo(local) {
2289
if {$Snit_optionInfo(readonly-$opt)} {
2290
unset -nocomplain ${selfns}::Snit_configureCache($opt)
2291
}
2292
}
2293
2294
return
2295
}
2296
2297
# Returns a unique command name.
2298
#
2299
# REQUIRE: type is a fully qualified name.
2300
# REQUIRE: name contains "%AUTO%"
2301
# PROMISE: the returned command name is unused.
2302
proc ::snit::RT.UniqueName {countervar type name} {
2303
upvar $countervar counter
2304
while 1 {
2305
# FIRST, bump the counter and define the %AUTO% instance name;
2306
# then substitute it into the specified name. Wrap around at
2307
# 2^31 - 2 to prevent overflow problems.
2308
incr counter
2309
if {$counter > 2147483646} {
2310
set counter 0
2311
}
2312
set auto "[namespace tail $type]$counter"
2313
set candidate [Expand $name %AUTO% $auto]
2314
if {[info commands $candidate] eq ""} {
2315
return $candidate
2316
}
2317
}
2318
}
2319
2320
# Returns a unique instance namespace, fully qualified.
2321
#
2322
# countervar The name of a counter variable
2323
# type The instance's type
2324
#
2325
# REQUIRE: type is fully qualified
2326
# PROMISE: The returned namespace name is unused.
2327
2328
proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
2329
upvar $countervar counter
2330
while 1 {
2331
# FIRST, bump the counter and define the namespace name.
2332
# Then see if it already exists. Wrap around at
2333
# 2^31 - 2 to prevent overflow problems.
2334
incr counter
2335
if {$counter > 2147483646} {
2336
set counter 0
2337
}
2338
set ins "${type}::Snit_inst${counter}"
2339
if {![namespace exists $ins]} {
2340
return $ins
2341
}
2342
}
2343
}
2344
2345
# Retrieves an option's value from the option database.
2346
# Returns "" if no value is found.
2347
proc ::snit::RT.OptionDbGet {type self opt} {
2348
variable ${type}::Snit_optionInfo
2349
2350
return [option get $self \
2351
$Snit_optionInfo(resource-$opt) \
2352
$Snit_optionInfo(class-$opt)]
2353
}
2354
2355
#-----------------------------------------------------------------------
2356
# Object Destruction
2357
2358
# Implements the standard "destroy" method
2359
#
2360
# type The snit type
2361
# selfns The instance's instance namespace
2362
# win The instance's original name
2363
# self The instance's current name
2364
2365
proc ::snit::RT.method.destroy {type selfns win self} {
2366
# Calls Snit_cleanup, which (among other things) calls the
2367
# user's destructor.
2368
::snit::RT.DestroyObject $type $selfns $win
2369
}
2370
2371
# This is the function that really cleans up; it's automatically
2372
# called when any instance is destroyed, e.g., by "$object destroy"
2373
# for types, and by the <Destroy> event for widgets.
2374
#
2375
# type The fully-qualified type name.
2376
# selfns The instance namespace
2377
# win The original instance command name.
2378
2379
proc ::snit::RT.DestroyObject {type selfns win} {
2380
variable ${type}::Snit_info
2381
2382
# If the variable Snit_instance doesn't exist then there's no
2383
# instance command for this object -- it's most likely a
2384
# widgetadaptor. Consequently, there are some things that
2385
# we don't need to do.
2386
if {[info exists ${selfns}::Snit_instance]} {
2387
upvar ${selfns}::Snit_instance instance
2388
2389
# First, remove the trace on the instance name, so that we
2390
# don't call RT.DestroyObject recursively.
2391
RT.RemoveInstanceTrace $type $selfns $win $instance
2392
2393
# Next, call the user's destructor
2394
${type}::Snit_destructor $type $selfns $win $instance
2395
2396
# Next, if this isn't a widget, delete the instance command.
2397
# If it is a widget, get the hull component's name, and rename
2398
# it back to the widget name
2399
2400
# Next, delete the hull component's instance command,
2401
# if there is one.
2402
if {$Snit_info(isWidget)} {
2403
set hullcmd [::snit::RT.Component $type $selfns hull]
2404
2405
catch {rename $instance ""}
2406
2407
# Clear the bind event
2408
bind Snit$type$win <Destroy> ""
2409
2410
if {[info command $hullcmd] != ""} {
2411
# FIRST, rename the hull back to its original name.
2412
# If the hull is itself a megawidget, it will have its
2413
# own cleanup to do, and it might not do it properly
2414
# if it doesn't have the right name.
2415
rename $hullcmd ::$instance
2416
2417
# NEXT, destroy it.
2418
destroy $instance
2419
}
2420
} else {
2421
catch {rename $instance ""}
2422
}
2423
}
2424
2425
# Next, delete the instance's namespace. This kills any
2426
# instance variables.
2427
namespace delete $selfns
2428
}
2429
2430
# Remove instance trace
2431
#
2432
# type The fully qualified type name
2433
# selfns The instance namespace
2434
# win The original instance name/Tk window name
2435
# instance The current instance name
2436
2437
proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
2438
variable ${type}::Snit_info
2439
2440
if {$Snit_info(isWidget)} {
2441
set procname ::$instance
2442
} else {
2443
set procname $instance
2444
}
2445
2446
# NEXT, remove any trace on this name
2447
catch {
2448
trace remove command $procname {rename delete} \
2449
[list ::snit::RT.InstanceTrace $type $selfns $win]
2450
}
2451
}
2452
2453
#-----------------------------------------------------------------------
2454
# Typecomponent Management and Method Caching
2455
2456
# Typecomponent trace; used for write trace on typecomponent
2457
# variables. Saves the new component object name, provided
2458
# that certain conditions are met. Also clears the typemethod
2459
# cache.
2460
2461
proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
2462
upvar ${type}::Snit_info Snit_info
2463
upvar ${type}::${component} cvar
2464
upvar ${type}::Snit_typecomponents Snit_typecomponents
2465
2466
# Save the new component value.
2467
set Snit_typecomponents($component) $cvar
2468
2469
# Clear the typemethod cache.
2470
# TBD: can we unset just the elements related to
2471
# this component?
2472
unset -nocomplain -- ${type}::Snit_typemethodCache
2473
}
2474
2475
# Generates and caches the command for a typemethod.
2476
#
2477
# type The type
2478
# method The name of the typemethod to call.
2479
#
2480
# The return value is one of the following lists:
2481
#
2482
# {} There's no such method.
2483
# {1} The method has submethods; look again.
2484
# {0 <command>} Here's the command to execute.
2485
2486
proc snit::RT.CacheTypemethodCommand {type method} {
2487
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
2488
upvar ${type}::Snit_typecomponents Snit_typecomponents
2489
upvar ${type}::Snit_typemethodCache Snit_typemethodCache
2490
upvar ${type}::Snit_info Snit_info
2491
2492
# FIRST, get the pattern data and the typecomponent name.
2493
set implicitCreate 0
2494
set instanceName ""
2495
2496
set starredMethod [lreplace $method end end *]
2497
set methodTail [lindex $method end]
2498
2499
if {[info exists Snit_typemethodInfo($method)]} {
2500
set key $method
2501
} elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
2502
if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
2503
set key $starredMethod
2504
} else {
2505
return [list ]
2506
}
2507
} elseif {$Snit_info(hasinstances)} {
2508
# Assume the unknown name is an instance name to create, unless
2509
# this is a widget and the style of the name is wrong, or the
2510
# name mimics a standard typemethod.
2511
2512
if {[set ${type}::Snit_info(isWidget)] &&
2513
![string match ".*" $method]} {
2514
return [list ]
2515
}
2516
2517
# Without this check, the call "$type info" will redefine the
2518
# standard "::info" command, with disastrous results. Since it's
2519
# a likely thing to do if !-typeinfo, put in an explicit check.
2520
if {$method eq "info" || $method eq "destroy"} {
2521
return [list ]
2522
}
2523
2524
set implicitCreate 1
2525
set instanceName $method
2526
set key create
2527
set method create
2528
} else {
2529
return [list ]
2530
}
2531
2532
foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
2533
2534
if {$flag == 1} {
2535
return [list 1]
2536
}
2537
2538
# NEXT, build the substitution list
2539
set subList [list \
2540
%% % \
2541
%t $type \
2542
%M $method \
2543
%m [lindex $method end] \
2544
%j [join $method _]]
2545
2546
if {$compName ne ""} {
2547
if {![info exists Snit_typecomponents($compName)]} {
2548
error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
2549
}
2550
2551
lappend subList %c [list $Snit_typecomponents($compName)]
2552
}
2553
2554
set command {}
2555
2556
foreach subpattern $pattern {
2557
lappend command [string map $subList $subpattern]
2558
}
2559
2560
if {$implicitCreate} {
2561
# In this case, $method is the name of the instance to
2562
# create. Don't cache, as we usually won't do this one
2563
# again.
2564
lappend command $instanceName
2565
} else {
2566
set Snit_typemethodCache($method) [list 0 $command]
2567
}
2568
2569
return [list 0 $command]
2570
}
2571
2572
2573
#-----------------------------------------------------------------------
2574
# Component Management and Method Caching
2575
2576
# Retrieves the object name given the component name.
2577
proc ::snit::RT.Component {type selfns name} {
2578
variable ${selfns}::Snit_components
2579
2580
if {[catch {set Snit_components($name)} result]} {
2581
variable ${selfns}::Snit_instance
2582
2583
error "component \"$name\" is undefined in $type $Snit_instance"
2584
}
2585
2586
return $result
2587
}
2588
2589
# Component trace; used for write trace on component instance
2590
# variables. Saves the new component object name, provided
2591
# that certain conditions are met. Also clears the method
2592
# cache.
2593
2594
proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
2595
upvar ${type}::Snit_info Snit_info
2596
upvar ${selfns}::${component} cvar
2597
upvar ${selfns}::Snit_components Snit_components
2598
2599
# If they try to redefine the hull component after
2600
# it's been defined, that's an error--but only if
2601
# this is a widget or widget adaptor.
2602
if {"hull" == $component &&
2603
$Snit_info(isWidget) &&
2604
[info exists Snit_components($component)]} {
2605
set cvar $Snit_components($component)
2606
error "The hull component cannot be redefined"
2607
}
2608
2609
# Save the new component value.
2610
set Snit_components($component) $cvar
2611
2612
# Clear the instance caches.
2613
# TBD: can we unset just the elements related to
2614
# this component?
2615
RT.ClearInstanceCaches $selfns
2616
}
2617
2618
# Generates and caches the command for a method.
2619
#
2620
# type: The instance's type
2621
# selfns: The instance's private namespace
2622
# win: The instance's original name (a Tk widget name, for
2623
# snit::widgets.
2624
# self: The instance's current name.
2625
# method: The name of the method to call.
2626
#
2627
# The return value is one of the following lists:
2628
#
2629
# {} There's no such method.
2630
# {1} The method has submethods; look again.
2631
# {0 <command>} Here's the command to execute.
2632
2633
proc ::snit::RT.CacheMethodCommand {type selfns win self method} {
2634
variable ${type}::Snit_info
2635
variable ${type}::Snit_methodInfo
2636
variable ${type}::Snit_typecomponents
2637
variable ${selfns}::Snit_components
2638
variable ${selfns}::Snit_methodCache
2639
2640
# FIRST, get the pattern data and the component name.
2641
set starredMethod [lreplace $method end end *]
2642
set methodTail [lindex $method end]
2643
2644
if {[info exists Snit_methodInfo($method)]} {
2645
set key $method
2646
} elseif {[info exists Snit_methodInfo($starredMethod)] &&
2647
[lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
2648
set key $starredMethod
2649
} else {
2650
return [list ]
2651
}
2652
2653
foreach {flag pattern compName} $Snit_methodInfo($key) {}
2654
2655
if {$flag == 1} {
2656
return [list 1]
2657
}
2658
2659
# NEXT, build the substitution list
2660
set subList [list \
2661
%% % \
2662
%t $type \
2663
%M $method \
2664
%m [lindex $method end] \
2665
%j [join $method _] \
2666
%n [list $selfns] \
2667
%w [list $win] \
2668
%s [list $self]]
2669
2670
if {$compName ne ""} {
2671
if {[info exists Snit_components($compName)]} {
2672
set compCmd $Snit_components($compName)
2673
} elseif {[info exists Snit_typecomponents($compName)]} {
2674
set compCmd $Snit_typecomponents($compName)
2675
} else {
2676
error "$type $self delegates method \"$method\" to undefined component \"$compName\""
2677
}
2678
2679
lappend subList %c [list $compCmd]
2680
}
2681
2682
# Note: The cached command will executed faster if it's
2683
# already a list.
2684
set command {}
2685
2686
foreach subpattern $pattern {
2687
lappend command [string map $subList $subpattern]
2688
}
2689
2690
set commandRec [list 0 $command]
2691
2692
set Snit_methodCache($method) $commandRec
2693
2694
return $commandRec
2695
}
2696
2697
2698
# Looks up a method's command.
2699
#
2700
# type: The instance's type
2701
# selfns: The instance's private namespace
2702
# win: The instance's original name (a Tk widget name, for
2703
# snit::widgets.
2704
# self: The instance's current name.
2705
# method: The name of the method to call.
2706
# errPrefix: Prefix for any error method
2707
proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} {
2708
set commandRec [snit::RT.CacheMethodCommand \
2709
$type $selfns $win $self \
2710
$method]
2711
2712
2713
if {[llength $commandRec] == 0} {
2714
return -code error \
2715
"$errPrefix, \"$self $method\" is not defined"
2716
} elseif {[lindex $commandRec 0] == 1} {
2717
return -code error \
2718
"$errPrefix, wrong number args: should be \"$self\" $method method args"
2719
}
2720
2721
return [lindex $commandRec 1]
2722
}
2723
2724
2725
# Clears all instance command caches
2726
proc ::snit::RT.ClearInstanceCaches {selfns} {
2727
unset -nocomplain -- ${selfns}::Snit_methodCache
2728
unset -nocomplain -- ${selfns}::Snit_cgetCache
2729
unset -nocomplain -- ${selfns}::Snit_configureCache
2730
unset -nocomplain -- ${selfns}::Snit_validateCache
2731
}
2732
2733
2734
#-----------------------------------------------------------------------
2735
# Component Installation
2736
2737
# Implements %TYPE%::installhull. The variables self and selfns
2738
# must be defined in the caller's context.
2739
#
2740
# Installs the named widget as the hull of a
2741
# widgetadaptor. Once the widget is hijacked, its new name
2742
# is assigned to the hull component.
2743
2744
proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
2745
variable ${type}::Snit_info
2746
variable ${type}::Snit_optionInfo
2747
upvar self self
2748
upvar selfns selfns
2749
upvar ${selfns}::hull hull
2750
upvar ${selfns}::options options
2751
2752
# FIRST, make sure we can do it.
2753
if {!$Snit_info(isWidget)} {
2754
error "installhull is valid only for snit::widgetadaptors"
2755
}
2756
2757
if {[info exists ${selfns}::Snit_instance]} {
2758
error "hull already installed for $type $self"
2759
}
2760
2761
# NEXT, has it been created yet? If not, create it using
2762
# the specified arguments.
2763
if {"using" == $using} {
2764
# FIRST, create the widget
2765
set cmd [linsert $args 0 $widgetType $self]
2766
set obj [uplevel 1 $cmd]
2767
2768
# NEXT, for each option explicitly delegated to the hull
2769
# that doesn't appear in the usedOpts list, get the
2770
# option database value and apply it--provided that the
2771
# real option name and the target option name are different.
2772
# (If they are the same, then the option database was
2773
# already queried as part of the normal widget creation.)
2774
#
2775
# Also, we don't need to worry about implicitly delegated
2776
# options, as the option and target option names must be
2777
# the same.
2778
if {[info exists Snit_optionInfo(delegated-hull)]} {
2779
2780
# FIRST, extract all option names from args
2781
set usedOpts {}
2782
set ndx [lsearch -glob $args "-*"]
2783
foreach {opt val} [lrange $args $ndx end] {
2784
lappend usedOpts $opt
2785
}
2786
2787
foreach opt $Snit_optionInfo(delegated-hull) {
2788
set target [lindex $Snit_optionInfo(target-$opt) 1]
2789
2790
if {"$target" == $opt} {
2791
continue
2792
}
2793
2794
set result [lsearch -exact $usedOpts $target]
2795
2796
if {$result != -1} {
2797
continue
2798
}
2799
2800
set dbval [RT.OptionDbGet $type $self $opt]
2801
$obj configure $target $dbval
2802
}
2803
}
2804
} else {
2805
set obj $using
2806
2807
if {$obj ne $self} {
2808
error \
2809
"hull name mismatch: \"$obj\" != \"$self\""
2810
}
2811
}
2812
2813
# NEXT, get the local option defaults.
2814
foreach opt $Snit_optionInfo(local) {
2815
set dbval [RT.OptionDbGet $type $self $opt]
2816
2817
if {"" != $dbval} {
2818
set options($opt) $dbval
2819
}
2820
}
2821
2822
2823
# NEXT, do the magic
2824
set i 0
2825
while 1 {
2826
incr i
2827
set newName "::hull${i}$self"
2828
if {"" == [info commands $newName]} {
2829
break
2830
}
2831
}
2832
2833
rename ::$self $newName
2834
RT.MakeInstanceCommand $type $selfns $self
2835
2836
# Note: this relies on RT.ComponentTrace to do the dirty work.
2837
set hull $newName
2838
2839
return
2840
}
2841
2842
# Implements %TYPE%::install.
2843
#
2844
# Creates a widget and installs it as the named component.
2845
# It expects self and selfns to be defined in the caller's context.
2846
2847
proc ::snit::RT.install {type compName "using" widgetType winPath args} {
2848
variable ${type}::Snit_optionInfo
2849
variable ${type}::Snit_info
2850
upvar self self
2851
upvar selfns selfns
2852
upvar ${selfns}::$compName comp
2853
upvar ${selfns}::hull hull
2854
2855
# We do the magic option database stuff only if $self is
2856
# a widget.
2857
if {$Snit_info(isWidget)} {
2858
if {"" == $hull} {
2859
error "tried to install \"$compName\" before the hull exists"
2860
}
2861
2862
# FIRST, query the option database and save the results
2863
# into args. Insert them before the first option in the
2864
# list, in case there are any non-standard parameters.
2865
#
2866
# Note: there might not be any delegated options; if so,
2867
# don't bother.
2868
2869
if {[info exists Snit_optionInfo(delegated-$compName)]} {
2870
set ndx [lsearch -glob $args "-*"]
2871
2872
foreach opt $Snit_optionInfo(delegated-$compName) {
2873
set dbval [RT.OptionDbGet $type $self $opt]
2874
2875
if {"" != $dbval} {
2876
set target [lindex $Snit_optionInfo(target-$opt) 1]
2877
set args [linsert $args $ndx $target $dbval]
2878
}
2879
}
2880
}
2881
}
2882
2883
# NEXT, create the component and save it.
2884
set cmd [concat [list $widgetType $winPath] $args]
2885
set comp [uplevel 1 $cmd]
2886
2887
# NEXT, handle the option database for "delegate option *",
2888
# in widgets only.
2889
if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} {
2890
# FIRST, get the list of option specs from the widget.
2891
# If configure doesn't work, skip it.
2892
if {[catch {$comp configure} specs]} {
2893
return
2894
}
2895
2896
# NEXT, get the set of explicitly used options from args
2897
set usedOpts {}
2898
set ndx [lsearch -glob $args "-*"]
2899
foreach {opt val} [lrange $args $ndx end] {
2900
lappend usedOpts $opt
2901
}
2902
2903
# NEXT, "delegate option *" matches all options defined
2904
# by this widget that aren't defined by the widget as a whole,
2905
# and that aren't excepted. Plus, we skip usedOpts. So build
2906
# a list of the options it can't match.
2907
set skiplist [concat \
2908
$usedOpts \
2909
$Snit_optionInfo(except) \
2910
$Snit_optionInfo(local) \
2911
$Snit_optionInfo(delegated)]
2912
2913
# NEXT, loop over all of the component's options, and set
2914
# any not in the skip list for which there is an option
2915
# database value.
2916
foreach spec $specs {
2917
# Skip aliases
2918
if {[llength $spec] != 5} {
2919
continue
2920
}
2921
2922
set opt [lindex $spec 0]
2923
2924
if {[lsearch -exact $skiplist $opt] != -1} {
2925
continue
2926
}
2927
2928
set res [lindex $spec 1]
2929
set cls [lindex $spec 2]
2930
2931
set dbvalue [option get $self $res $cls]
2932
2933
if {"" != $dbvalue} {
2934
$comp configure $opt $dbvalue
2935
}
2936
}
2937
}
2938
2939
return
2940
}
2941
2942
2943
#-----------------------------------------------------------------------
2944
# Method/Variable Name Qualification
2945
2946
# Implements %TYPE%::variable. Requires selfns.
2947
proc ::snit::RT.variable {varname} {
2948
upvar selfns selfns
2949
2950
if {![string match "::*" $varname]} {
2951
uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
2952
} else {
2953
# varname is fully qualified; let the standard
2954
# "variable" command handle it.
2955
uplevel 1 [list ::variable $varname]
2956
}
2957
}
2958
2959
# Fully qualifies a typevariable name.
2960
#
2961
# This is used to implement the mytypevar command.
2962
2963
proc ::snit::RT.mytypevar {type name} {
2964
return ${type}::$name
2965
}
2966
2967
# Fully qualifies an instance variable name.
2968
#
2969
# This is used to implement the myvar command.
2970
proc ::snit::RT.myvar {name} {
2971
upvar selfns selfns
2972
return ${selfns}::$name
2973
}
2974
2975
# Use this like "list" to convert a proc call into a command
2976
# string to pass to another object (e.g., as a -command).
2977
# Qualifies the proc name properly.
2978
#
2979
# This is used to implement the "myproc" command.
2980
2981
proc ::snit::RT.myproc {type procname args} {
2982
set procname "${type}::$procname"
2983
return [linsert $args 0 $procname]
2984
}
2985
2986
# DEPRECATED
2987
proc ::snit::RT.codename {type name} {
2988
return "${type}::$name"
2989
}
2990
2991
# Use this like "list" to convert a typemethod call into a command
2992
# string to pass to another object (e.g., as a -command).
2993
# Inserts the type command at the beginning.
2994
#
2995
# This is used to implement the "mytypemethod" command.
2996
2997
proc ::snit::RT.mytypemethod {type args} {
2998
return [linsert $args 0 $type]
2999
}
3000
3001
# Use this like "list" to convert a method call into a command
3002
# string to pass to another object (e.g., as a -command).
3003
# Inserts the code at the beginning to call the right object, even if
3004
# the object's name has changed. Requires that selfns be defined
3005
# in the calling context, eg. can only be called in instance
3006
# code.
3007
#
3008
# This is used to implement the "mymethod" command.
3009
3010
proc ::snit::RT.mymethod {args} {
3011
upvar selfns selfns
3012
return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
3013
}
3014
3015
# Calls an instance method for an object given its
3016
# instance namespace and remaining arguments (the first of which
3017
# will be the method name.
3018
#
3019
# selfns The instance namespace
3020
# args The arguments
3021
#
3022
# Uses the selfns to determine $self, and calls the method
3023
# in the normal way.
3024
#
3025
# This is used to implement the "mymethod" command.
3026
3027
proc ::snit::RT.CallInstance {selfns args} {
3028
upvar ${selfns}::Snit_instance self
3029
3030
set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
3031
3032
if {$retval} {
3033
if {$retval == 1} {
3034
global errorInfo
3035
global errorCode
3036
return -code error -errorinfo $errorInfo \
3037
-errorcode $errorCode $result
3038
} else {
3039
return -code $retval $result
3040
}
3041
}
3042
3043
return $result
3044
}
3045
3046
# Looks for the named option in the named variable. If found,
3047
# it and its value are removed from the list, and the value
3048
# is returned. Otherwise, the default value is returned.
3049
# If the option is undelegated, it's own default value will be
3050
# used if none is specified.
3051
#
3052
# Implements the "from" command.
3053
3054
proc ::snit::RT.from {type argvName option {defvalue ""}} {
3055
variable ${type}::Snit_optionInfo
3056
upvar $argvName argv
3057
3058
set ioption [lsearch -exact $argv $option]
3059
3060
if {$ioption == -1} {
3061
if {"" == $defvalue &&
3062
[info exists Snit_optionInfo(default-$option)]} {
3063
return $Snit_optionInfo(default-$option)
3064
} else {
3065
return $defvalue
3066
}
3067
}
3068
3069
set ivalue [expr {$ioption + 1}]
3070
set value [lindex $argv $ivalue]
3071
3072
set argv [lreplace $argv $ioption $ivalue]
3073
3074
return $value
3075
}
3076
3077
#-----------------------------------------------------------------------
3078
# Type Destruction
3079
3080
# Implements the standard "destroy" typemethod:
3081
# Destroys a type completely.
3082
#
3083
# type The snit type
3084
3085
proc ::snit::RT.typemethod.destroy {type} {
3086
variable ${type}::Snit_info
3087
3088
# FIRST, destroy all instances
3089
foreach selfns [namespace children $type] {
3090
if {![namespace exists $selfns]} {
3091
continue
3092
}
3093
upvar ${selfns}::Snit_instance obj
3094
3095
if {$Snit_info(isWidget)} {
3096
destroy $obj
3097
} else {
3098
if {"" != [info commands $obj]} {
3099
$obj destroy
3100
}
3101
}
3102
}
3103
3104
# NEXT, destroy the type's data.
3105
namespace delete $type
3106
3107
# NEXT, get rid of the type command.
3108
rename $type ""
3109
}
3110
3111
3112
3113
#-----------------------------------------------------------------------
3114
# Option Handling
3115
3116
# Implements the standard "cget" method
3117
#
3118
# type The snit type
3119
# selfns The instance's instance namespace
3120
# win The instance's original name
3121
# self The instance's current name
3122
# option The name of the option
3123
3124
proc ::snit::RT.method.cget {type selfns win self option} {
3125
if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
3126
set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
3127
3128
if {[llength $command] == 0} {
3129
return -code error "unknown option \"$option\""
3130
}
3131
}
3132
3133
uplevel 1 $command
3134
}
3135
3136
# Retrieves and caches the command that implements "cget" for the
3137
# specified option.
3138
#
3139
# type The snit type
3140
# selfns The instance's instance namespace
3141
# win The instance's original name
3142
# self The instance's current name
3143
# option The name of the option
3144
3145
proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
3146
variable ${type}::Snit_optionInfo
3147
variable ${selfns}::Snit_cgetCache
3148
3149
if {[info exists Snit_optionInfo(islocal-$option)]} {
3150
# We know the item; it's either local, or explicitly delegated.
3151
if {$Snit_optionInfo(islocal-$option)} {
3152
# It's a local option. If it has a cget method defined,
3153
# use it; otherwise just return the value.
3154
3155
if {$Snit_optionInfo(cget-$option) eq ""} {
3156
set command [list set ${selfns}::options($option)]
3157
} else {
3158
set command [snit::RT.LookupMethodCommand \
3159
$type $selfns $win $self \
3160
$Snit_optionInfo(cget-$option) \
3161
"can't cget $option"]
3162
3163
lappend command $option
3164
}
3165
3166
set Snit_cgetCache($option) $command
3167
return $command
3168
}
3169
3170
# Explicitly delegated option; get target
3171
set comp [lindex $Snit_optionInfo(target-$option) 0]
3172
set target [lindex $Snit_optionInfo(target-$option) 1]
3173
} elseif {$Snit_optionInfo(starcomp) ne "" &&
3174
[lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3175
# Unknown option, but unknowns are delegated; get target.
3176
set comp $Snit_optionInfo(starcomp)
3177
set target $option
3178
} else {
3179
return ""
3180
}
3181
3182
# Get the component's object.
3183
set obj [RT.Component $type $selfns $comp]
3184
3185
set command [list $obj cget $target]
3186
set Snit_cgetCache($option) $command
3187
3188
return $command
3189
}
3190
3191
# Implements the standard "configurelist" method
3192
#
3193
# type The snit type
3194
# selfns The instance's instance namespace
3195
# win The instance's original name
3196
# self The instance's current name
3197
# optionlist A list of options and their values.
3198
3199
proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
3200
variable ${type}::Snit_optionInfo
3201
3202
foreach {option value} $optionlist {
3203
# FIRST, get the configure command, caching it if need be.
3204
if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
3205
set command [snit::RT.CacheConfigureCommand \
3206
$type $selfns $win $self $option]
3207
3208
if {[llength $command] == 0} {
3209
return -code error "unknown option \"$option\""
3210
}
3211
}
3212
3213
# NEXT, the caching the configure command also cached the
3214
# validate command, if any. If we have one, run it.
3215
set valcommand [set ${selfns}::Snit_validateCache($option)]
3216
3217
if {[llength $valcommand]} {
3218
lappend valcommand $value
3219
uplevel 1 $valcommand
3220
}
3221
3222
# NEXT, configure the option with the value.
3223
lappend command $value
3224
uplevel 1 $command
3225
}
3226
3227
return
3228
}
3229
3230
# Retrieves and caches the command that stores the named option.
3231
# Also stores the command that validates the name option if any;
3232
# If none, the validate command is "", so that the cache is always
3233
# populated.
3234
#
3235
# type The snit type
3236
# selfns The instance's instance namespace
3237
# win The instance's original name
3238
# self The instance's current name
3239
# option An option name
3240
3241
proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
3242
variable ${type}::Snit_optionInfo
3243
variable ${selfns}::Snit_configureCache
3244
variable ${selfns}::Snit_validateCache
3245
3246
if {[info exist Snit_optionInfo(islocal-$option)]} {
3247
# We know the item; it's either local, or explicitly delegated.
3248
3249
if {$Snit_optionInfo(islocal-$option)} {
3250
# It's a local option.
3251
3252
# If it's readonly, it throws an error if we're already
3253
# constructed.
3254
if {$Snit_optionInfo(readonly-$option)} {
3255
if {[set ${selfns}::Snit_iinfo(constructed)]} {
3256
error "option $option can only be set at instance creation"
3257
}
3258
}
3259
3260
# If it has a validate method, cache that for later.
3261
if {$Snit_optionInfo(validate-$option) ne ""} {
3262
set command [snit::RT.LookupMethodCommand \
3263
$type $selfns $win $self \
3264
$Snit_optionInfo(validate-$option) \
3265
"can't validate $option"]
3266
3267
lappend command $option
3268
set Snit_validateCache($option) $command
3269
} else {
3270
set Snit_validateCache($option) ""
3271
}
3272
3273
# If it has a configure method defined,
3274
# cache it; otherwise, just set the value.
3275
3276
if {$Snit_optionInfo(configure-$option) eq ""} {
3277
set command [list set ${selfns}::options($option)]
3278
} else {
3279
set command [snit::RT.LookupMethodCommand \
3280
$type $selfns $win $self \
3281
$Snit_optionInfo(configure-$option) \
3282
"can't configure $option"]
3283
3284
lappend command $option
3285
}
3286
3287
set Snit_configureCache($option) $command
3288
return $command
3289
}
3290
3291
# Delegated option: get target.
3292
set comp [lindex $Snit_optionInfo(target-$option) 0]
3293
set target [lindex $Snit_optionInfo(target-$option) 1]
3294
} elseif {$Snit_optionInfo(starcomp) != "" &&
3295
[lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3296
# Unknown option, but unknowns are delegated.
3297
set comp $Snit_optionInfo(starcomp)
3298
set target $option
3299
} else {
3300
return ""
3301
}
3302
3303
# There is no validate command in this case; save an empty string.
3304
set Snit_validateCache($option) ""
3305
3306
# Get the component's object
3307
set obj [RT.Component $type $selfns $comp]
3308
3309
set command [list $obj configure $target]
3310
set Snit_configureCache($option) $command
3311
3312
return $command
3313
}
3314
3315
# Implements the standard "configure" method
3316
#
3317
# type The snit type
3318
# selfns The instance's instance namespace
3319
# win The instance's original name
3320
# self The instance's current name
3321
# args A list of options and their values, possibly empty.
3322
3323
proc ::snit::RT.method.configure {type selfns win self args} {
3324
# If two or more arguments, set values as usual.
3325
if {[llength $args] >= 2} {
3326
::snit::RT.method.configurelist $type $selfns $win $self $args
3327
return
3328
}
3329
3330
# If zero arguments, acquire data for each known option
3331
# and return the list
3332
if {[llength $args] == 0} {
3333
set result {}
3334
foreach opt [RT.method.info.options $type $selfns $win $self] {
3335
# Refactor this, so that we don't need to call via $self.
3336
lappend result [RT.GetOptionDbSpec \
3337
$type $selfns $win $self $opt]
3338
}
3339
3340
return $result
3341
}
3342
3343
# They want it for just one.
3344
set opt [lindex $args 0]
3345
3346
return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
3347
}
3348
3349
3350
# Retrieves the option database spec for a single option.
3351
#
3352
# type The snit type
3353
# selfns The instance's instance namespace
3354
# win The instance's original name
3355
# self The instance's current name
3356
# option The name of an option
3357
#
3358
# TBD: This is a bad name. What it's returning is the
3359
# result of the configure query.
3360
3361
proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
3362
variable ${type}::Snit_optionInfo
3363
3364
upvar ${selfns}::Snit_components Snit_components
3365
upvar ${selfns}::options options
3366
3367
if {[info exists options($opt)]} {
3368
# This is a locally-defined option. Just build the
3369
# list and return it.
3370
set res $Snit_optionInfo(resource-$opt)
3371
set cls $Snit_optionInfo(class-$opt)
3372
set def $Snit_optionInfo(default-$opt)
3373
3374
return [list $opt $res $cls $def \
3375
[RT.method.cget $type $selfns $win $self $opt]]
3376
} elseif {[info exists Snit_optionInfo(target-$opt)]} {
3377
# This is an explicitly delegated option. The only
3378
# thing we don't have is the default.
3379
set res $Snit_optionInfo(resource-$opt)
3380
set cls $Snit_optionInfo(class-$opt)
3381
3382
# Get the default
3383
set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
3384
set comp $Snit_components($logicalName)
3385
set target [lindex $Snit_optionInfo(target-$opt) 1]
3386
3387
if {[catch {$comp configure $target} result]} {
3388
set defValue {}
3389
} else {
3390
set defValue [lindex $result 3]
3391
}
3392
3393
return [list $opt $res $cls $defValue [$self cget $opt]]
3394
} elseif {$Snit_optionInfo(starcomp) ne "" &&
3395
[lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3396
set logicalName $Snit_optionInfo(starcomp)
3397
set target $opt
3398
set comp $Snit_components($logicalName)
3399
3400
if {[catch {set value [$comp cget $target]} result]} {
3401
error "unknown option \"$opt\""
3402
}
3403
3404
if {![catch {$comp configure $target} result]} {
3405
# Replace the delegated option name with the local name.
3406
return [::snit::Expand $result $target $opt]
3407
}
3408
3409
# configure didn't work; return simple form.
3410
return [list $opt "" "" "" $value]
3411
} else {
3412
error "unknown option \"$opt\""
3413
}
3414
}
3415
3416
#-----------------------------------------------------------------------
3417
# Type Introspection
3418
3419
# Implements the standard "info" typemethod.
3420
#
3421
# type The snit type
3422
# command The info subcommand
3423
# args All other arguments.
3424
3425
proc ::snit::RT.typemethod.info {type command args} {
3426
global errorInfo
3427
global errorCode
3428
3429
switch -exact $command {
3430
typevars -
3431
typemethods -
3432
instances {
3433
# TBD: it should be possible to delete this error
3434
# handling.
3435
set errflag [catch {
3436
uplevel 1 [linsert $args 0 \
3437
::snit::RT.typemethod.info.$command $type]
3438
} result]
3439
3440
if {$errflag} {
3441
return -code error -errorinfo $errorInfo \
3442
-errorcode $errorCode $result
3443
} else {
3444
return $result
3445
}
3446
}
3447
default {
3448
error "\"$type info $command\" is not defined"
3449
}
3450
}
3451
}
3452
3453
3454
# Returns a list of the type's typevariables whose names match a
3455
# pattern, excluding Snit internal variables.
3456
#
3457
# type A Snit type
3458
# pattern Optional. The glob pattern to match. Defaults
3459
# to *.
3460
3461
proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
3462
set result {}
3463
foreach name [info vars "${type}::$pattern"] {
3464
set tail [namespace tail $name]
3465
if {![string match "Snit_*" $tail]} {
3466
lappend result $name
3467
}
3468
}
3469
3470
return $result
3471
}
3472
3473
# Returns a list of the type's methods whose names match a
3474
# pattern. If "delegate typemethod *" is used, the list may
3475
# not be complete.
3476
#
3477
# type A Snit type
3478
# pattern Optional. The glob pattern to match. Defaults
3479
# to *.
3480
3481
proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
3482
variable ${type}::Snit_typemethodInfo
3483
variable ${type}::Snit_typemethodCache
3484
3485
# FIRST, get the explicit names, skipping prefixes.
3486
set result {}
3487
3488
foreach name [array names Snit_typemethodInfo -glob $pattern] {
3489
if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
3490
lappend result $name
3491
}
3492
}
3493
3494
# NEXT, add any from the cache that aren't explicit.
3495
if {[info exists Snit_typemethodInfo(*)]} {
3496
# First, remove "*" from the list.
3497
set ndx [lsearch -exact $result "*"]
3498
if {$ndx != -1} {
3499
set result [lreplace $result $ndx $ndx]
3500
}
3501
3502
foreach name [array names Snit_typemethodCache -glob $pattern] {
3503
if {[lsearch -exact $result $name] == -1} {
3504
lappend result $name
3505
}
3506
}
3507
}
3508
3509
return $result
3510
}
3511
3512
# Returns a list of the type's instances whose names match
3513
# a pattern.
3514
#
3515
# type A Snit type
3516
# pattern Optional. The glob pattern to match
3517
# Defaults to *
3518
#
3519
# REQUIRE: type is fully qualified.
3520
3521
proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
3522
set result {}
3523
3524
foreach selfns [namespace children $type] {
3525
upvar ${selfns}::Snit_instance instance
3526
3527
if {[string match $pattern $instance]} {
3528
lappend result $instance
3529
}
3530
}
3531
3532
return $result
3533
}
3534
3535
#-----------------------------------------------------------------------
3536
# Instance Introspection
3537
3538
# Implements the standard "info" method.
3539
#
3540
# type The snit type
3541
# selfns The instance's instance namespace
3542
# win The instance's original name
3543
# self The instance's current name
3544
# command The info subcommand
3545
# args All other arguments.
3546
3547
proc ::snit::RT.method.info {type selfns win self command args} {
3548
switch -exact $command {
3549
type -
3550
vars -
3551
options -
3552
methods -
3553
typevars -
3554
typemethods {
3555
set errflag [catch {
3556
uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
3557
$type $selfns $win $self]
3558
} result]
3559
3560
if {$errflag} {
3561
global errorInfo
3562
return -code error -errorinfo $errorInfo $result
3563
} else {
3564
return $result
3565
}
3566
}
3567
default {
3568
# error "\"$self info $command\" is not defined"
3569
return -code error "\"$self info $command\" is not defined"
3570
}
3571
}
3572
}
3573
3574
# $self info type
3575
#
3576
# Returns the instance's type
3577
proc ::snit::RT.method.info.type {type selfns win self} {
3578
return $type
3579
}
3580
3581
# $self info typevars
3582
#
3583
# Returns the instance's type's typevariables
3584
proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
3585
return [RT.typemethod.info.typevars $type $pattern]
3586
}
3587
3588
# $self info typemethods
3589
#
3590
# Returns the instance's type's typemethods
3591
proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
3592
return [RT.typemethod.info.typemethods $type $pattern]
3593
}
3594
3595
# Returns a list of the instance's methods whose names match a
3596
# pattern. If "delegate method *" is used, the list may
3597
# not be complete.
3598
#
3599
# type A Snit type
3600
# selfns The instance namespace
3601
# win The original instance name
3602
# self The current instance name
3603
# pattern Optional. The glob pattern to match. Defaults
3604
# to *.
3605
3606
proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
3607
variable ${type}::Snit_methodInfo
3608
variable ${selfns}::Snit_methodCache
3609
3610
# FIRST, get the explicit names, skipping prefixes.
3611
set result {}
3612
3613
foreach name [array names Snit_methodInfo -glob $pattern] {
3614
if {[lindex $Snit_methodInfo($name) 0] != 1} {
3615
lappend result $name
3616
}
3617
}
3618
3619
# NEXT, add any from the cache that aren't explicit.
3620
if {[info exists Snit_methodInfo(*)]} {
3621
# First, remove "*" from the list.
3622
set ndx [lsearch -exact $result "*"]
3623
if {$ndx != -1} {
3624
set result [lreplace $result $ndx $ndx]
3625
}
3626
3627
foreach name [array names Snit_methodCache -glob $pattern] {
3628
if {[lsearch -exact $result $name] == -1} {
3629
lappend result $name
3630
}
3631
}
3632
}
3633
3634
return $result
3635
}
3636
3637
# $self info vars
3638
#
3639
# Returns the instance's instance variables
3640
proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
3641
set result {}
3642
foreach name [info vars "${selfns}::$pattern"] {
3643
set tail [namespace tail $name]
3644
if {![string match "Snit_*" $tail]} {
3645
lappend result $name
3646
}
3647
}
3648
3649
return $result
3650
}
3651
3652
# $self info options
3653
#
3654
# Returns a list of the names of the instance's options
3655
proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
3656
variable ${type}::Snit_optionInfo
3657
3658
# First, get the local and explicitly delegated options
3659
set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
3660
3661
# If "configure" works as for Tk widgets, add the resulting
3662
# options to the list. Skip excepted options
3663
if {$Snit_optionInfo(starcomp) ne ""} {
3664
upvar ${selfns}::Snit_components Snit_components
3665
set logicalName $Snit_optionInfo(starcomp)
3666
set comp $Snit_components($logicalName)
3667
3668
if {![catch {$comp configure} records]} {
3669
foreach record $records {
3670
set opt [lindex $record 0]
3671
if {[lsearch -exact $result $opt] == -1 &&
3672
[lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3673
lappend result $opt
3674
}
3675
}
3676
}
3677
}
3678
3679
# Next, apply the pattern
3680
set names {}
3681
3682
foreach name $result {
3683
if {[string match $pattern $name]} {
3684
lappend names $name
3685
}
3686
}
3687
3688
return $names
3689
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1