snit2.tcl

来自「Linux下的MSN聊天程序源码」· TCL 代码 · 共 2,009 行 · 第 1/5 页

    # FIRST, qualify the name.
    if {![string match "::*" $type]} {
        # Get caller's namespace; 
        # append :: if not global namespace.
        set ns [uplevel 2 [list namespace current]]
        if {"::" != $ns} {
            append ns "::"
        }
        
        set type "$ns$type"
    }

    # NEXT, create and initialize the compiler, if needed.
    Comp.Init

    # NEXT, initialize the class data
    array unset methodInfo
    array unset typemethodInfo

    array unset compile
    set compile(type) $type
    set compile(defs) {}
    set compile(which) $which
    set compile(hasoptions) no
    set compile(localoptions) {}
    set compile(instancevars) {}
    set compile(typevars) {}
    set compile(delegatedoptions) {}
    set compile(ivprocdec) {}
    set compile(tvprocdec) {}
    set compile(typeconstructor) {}
    set compile(widgetclass) {}
    set compile(hulltype) {}
    set compile(localmethods) {}
    set compile(delegatesmethods) no
    set compile(hashierarchic) no
    set compile(components) {}
    set compile(typecomponents) {}
    set compile(varnames) {}
    set compile(typevarnames) {}
    set compile(hasconstructor) no
    set compile(-hastypedestroy) yes
    set compile(-hastypeinfo) yes
    set compile(-hastypemethods) yes
    set compile(-hasinfo) yes
    set compile(-hasinstances) yes
    set compile(-canreplace) no

    set isWidget [string match widget* $which]
    set isWidgetAdaptor [string match widgetadaptor $which]

    # NEXT, Evaluate the type's definition in the class interpreter.
    $compiler eval $body

    # NEXT, Add the standard definitions
    append compile(defs) \
        "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"

    append compile(defs) \
        "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"

    # Indicate whether the type can create instances that replace
    # existing commands.
    append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"


    # Check pragmas for conflict.
    
    if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
        error "$which $type has neither typemethods nor instances"
    }

    # If there are typemethods, define the standard typemethods and
    # the nominal type proc.  Otherwise define the simple type proc.
    if {$compile(-hastypemethods)} {
        # Add the info typemethod unless the pragma forbids it.
        if {$compile(-hastypeinfo)} {
            Comp.statement.delegate typemethod info \
                using {::snit::RT.typemethod.info %t}
        }

        # Add the destroy typemethod unless the pragma forbids it.
        if {$compile(-hastypedestroy)} {
            Comp.statement.delegate typemethod destroy \
                using {::snit::RT.typemethod.destroy %t}
        }

        # Add the nominal type proc.
        append compile(defs) $nominalTypeProc
    } else {
        # Add the simple type proc.
        append compile(defs) $simpleTypeProc
    }

    # Add standard methods/typemethods that only make sense if the
    # type has instances.
    if {$compile(-hasinstances)} {
        # Add the info method unless the pragma forbids it.
        if {$compile(-hasinfo)} {
            Comp.statement.delegate method info \
                using {::snit::RT.method.info %t %n %w %s}
        }
        
        # Add the option handling stuff if there are any options.
        if {$compile(hasoptions)} {
            Comp.statement.variable options

            Comp.statement.delegate method cget \
                using {::snit::RT.method.cget %t %n %w %s}
            Comp.statement.delegate method configurelist \
                using {::snit::RT.method.configurelist %t %n %w %s}
            Comp.statement.delegate method configure \
                using {::snit::RT.method.configure %t %n %w %s}
        }

        # Add a default constructor, if they haven't already defined one.
        # If there are options, it will configure args; otherwise it
        # will do nothing.
        if {!$compile(hasconstructor)} {
            if {$compile(hasoptions)} {
                Comp.statement.constructor {args} {
                    $self configurelist $args
                }
            } else {
                Comp.statement.constructor {} {}
            }
        }
        
        if {!$isWidget} {
            Comp.statement.delegate method destroy \
                using {::snit::RT.method.destroy %t %n %w %s}

            Comp.statement.delegate typemethod create \
                using {::snit::RT.type.typemethod.create %t}
        } else {
            Comp.statement.delegate typemethod create \
                using {::snit::RT.widget.typemethod.create %t}
        }

        # Save the method info. 
        append compile(defs) \
            "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
    } else {
        append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
    }

    # NEXT, compiling the type definition built up a set of information
    # about the type's locally defined options; add this information to
    # the compiled definition.
    Comp.SaveOptionInfo

    # NEXT, compiling the type definition built up a set of information
    # about the typemethods; save the typemethod info.
    append compile(defs) \
        "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"

    # NEXT, if this is a widget define the hull component if it isn't
    # already defined.
    if {$isWidget} {
        Comp.DefineComponent hull
    }

    # NEXT, substitute the compiled definition into the type template
    # to get the type definition script.
    set defscript [Expand $typeTemplate \
                       %COMPILEDDEFS% $compile(defs)]

    # NEXT, substitute the defined macros into the type definition script.
    # This is done as a separate step so that the compile(defs) can 
    # contain the macros defined below.

    set defscript [Expand $defscript \
                       %TYPE%         $type \
                       %IVARDECS%     $compile(ivprocdec) \
                       %TVARDECS%     $compile(tvprocdec) \
                       %TCONSTBODY%   $compile(typeconstructor) \
                       %INSTANCEVARS% $compile(instancevars) \
                       %TYPEVARS%     $compile(typevars) \
		       ]

    array unset compile

    return [list $type $defscript]
}

# Information about locally-defined options is accumulated during
# compilation, but not added to the compiled definition--the option
# statement can appear multiple times, so it's easier this way.
# This proc fills in Snit_optionInfo with the accumulated information.
#
# It also computes the option's resource and class names if needed.
#
# Note that the information for delegated options was put in 
# Snit_optionInfo during compilation.

proc ::snit::Comp.SaveOptionInfo {} {
    variable compile

    foreach option $compile(localoptions) {
        if {$compile(resource-$option) eq ""} {
            set compile(resource-$option) [string range $option 1 end]
        }

        if {$compile(class-$option) eq ""} {
            set compile(class-$option) [Capitalize $compile(resource-$option)]
        }

        # NOTE: Don't verify that the validate, configure, and cget 
        # values name real methods; the methods might be defined outside 
        # the typedefinition using snit::method.
        
        Mappend compile(defs) {
            # Option %OPTION%
            lappend %TYPE%::Snit_optionInfo(local) %OPTION%

            set %TYPE%::Snit_optionInfo(islocal-%OPTION%)   1
            set %TYPE%::Snit_optionInfo(resource-%OPTION%)  %RESOURCE%
            set %TYPE%::Snit_optionInfo(class-%OPTION%)     %CLASS%
            set %TYPE%::Snit_optionInfo(default-%OPTION%)   %DEFAULT%
            set %TYPE%::Snit_optionInfo(validate-%OPTION%)  %VALIDATE%
            set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
            set %TYPE%::Snit_optionInfo(cget-%OPTION%)      %CGET%
            set %TYPE%::Snit_optionInfo(readonly-%OPTION%)  %READONLY%
        }   %OPTION%    $option \
            %RESOURCE%  $compile(resource-$option) \
            %CLASS%     $compile(class-$option) \
            %DEFAULT%   [list $compile(-default-$option)] \
            %VALIDATE%  [list $compile(-validatemethod-$option)] \
            %CONFIGURE% [list $compile(-configuremethod-$option)] \
            %CGET%      [list $compile(-cgetmethod-$option)] \
            %READONLY%  $compile(-readonly-$option)
    }
}


# Evaluates a compiled type definition, thus making the type available.
proc ::snit::Comp.Define {compResult} {
    # The compilation result is a list containing the fully qualified
    # type name and a script to evaluate to define the type.
    set type [lindex $compResult 0]
    set defscript [lindex $compResult 1]

    # Execute the type definition script.
    # Consider using namespace eval %TYPE%.  See if it's faster.
    if {[catch {eval $defscript} result]} {
        namespace delete $type
        catch {rename $type ""}
        error $result
    }

    return $type
}

# Sets pragma options which control how the type is defined.
proc ::snit::Comp.statement.pragma {args} {
    variable compile

    set errRoot "Error in \"pragma...\""

    foreach {opt val} $args {
        switch -exact -- $opt {
            -hastypeinfo    -
            -hastypedestroy -
            -hastypemethods -
            -hasinstances   -
            -simpledispatch -
            -hasinfo        -
            -canreplace     {
                if {![string is boolean -strict $val]} {
                    error "$errRoot, \"$opt\" requires a boolean value"
                }
                set compile($opt) $val
            }
            default {
                error "$errRoot, unknown pragma"
            }
        }
    }
}

# Defines a widget's option class name.  
# This statement is only available for snit::widgets,
# not for snit::types or snit::widgetadaptors.
proc ::snit::Comp.statement.widgetclass {name} {
    variable compile

    # First, widgetclass can only be set for true widgets
    if {"widget" != $compile(which)} {
        error "widgetclass cannot be set for snit::$compile(which)s"
    }

    # Next, validate the option name.  We'll require that it begin
    # with an uppercase letter.
    set initial [string index $name 0]
    if {![string is upper $initial]} {
        error "widgetclass \"$name\" does not begin with an uppercase letter"
    }

    if {"" != $compile(widgetclass)} {
        error "too many widgetclass statements"
    }

    # Next, save it.
    Mappend compile(defs) {
        set  %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
    } %WIDGETCLASS% [list $name]

    set compile(widgetclass) $name
}

# Defines a widget's hull type.
# This statement is only available for snit::widgets,
# not for snit::types or snit::widgetadaptors.
proc ::snit::Comp.statement.hulltype {name} {
    variable compile
    variable hulltypes

    # First, hulltype can only be set for true widgets
    if {"widget" != $compile(which)} {
        error "hulltype cannot be set for snit::$compile(which)s"
    }

    # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
    if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
        error "invalid hulltype \"$name\", should be one of\
		[join $hulltypes {, }]"
    }

    if {"" != $compile(hulltype)} {
        error "too many hulltype statements"
    }

    # Next, save it.
    Mappend compile(defs) {
        set  %TYPE%::Snit_info(hulltype) %HULLTYPE%
    } %HULLTYPE% $name

    set compile(hulltype) $name
}

# Defines a constructor.
proc ::snit::Comp.statement.constructor {arglist body} {
    variable compile

    CheckArgs "constructor" $arglist

    # Next, add a magic reference to self.
    set arglist [concat type selfns win self $arglist]

    # Next, add variable declarations to body:
    set body "%TVARDECS%%IVARDECS%\n$body"

    set compile(hasconstructor) yes
    append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
} 

# Defines a destructor.
proc ::snit::Comp.statement.destructor {body} {
    variable compile

    # Next, add variable declarations to body:
    set body "%TVARDECS%%IVARDECS%\n$body"

    append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
} 

# Defines a type option.  The option value can be a triple, specifying
# the option's -name, resource name, and class name. 
proc ::snit::Comp.statement.option {optionDef args} {
    variable compile

    # First, get the three option names.
    set option [lindex $optionDef 0]
    set resourceName [lindex $optionDef 1]
    set className [lindex $optionDef 2]

    set errRoot "Error in \"option [list $optionDef]...\""

    # Next, validate the option name.
    if {![Comp.OptionNameIsValid $option]} {
        error "$errRoot, badly named option \"$option\""
    }

    if {$option in $compile(delegatedoptions)} {
        error "$errRoot, cannot define \"$option\" locally, it has been delegated"
    }

    if {!($option in $compile(localoptions))} {
        # Remember that we've seen this one.
        set compile(hasoptions) yes
        lappend compile(localoptions) $option
        
        # Initialize compilation info for this option.
        set compile(resource-$option)         ""
        set compile(class-$option)            ""
        set compile(-default-$option)         ""
        set compile(-validatemethod-$option)  ""
        set compile(-configuremethod-$option) ""
        set compile(-cgetmethod-$option)      ""
        set compile(-readonly-$option)        0
    }