source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/snit/main1.tcl

devel
Last change on this file was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

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