snit.tcl

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

            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(config-%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 {[Contains $option $compile(delegatedoptions)]} {
        error "$errRoot, cannot define \"$option\" locally, it has been delegated"
    }

    if {![Contains $option $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
    }

    # NEXT, see if we have a resource name.  If so, make sure it
    # isn't being redefined differently.
    if {$resourceName ne ""} {
        if {$compile(resource-$option) eq ""} {
            # If it's undefined, just save the value.
            set compile(resource-$option) $resourceName
        } elseif {$resourceName ne $compile(resource-$option)} {
            # It's been redefined differently.
            error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
        }
    }

    # NEXT, see if we have a class name.  If so, make sure it
    # isn't being redefined differently.
    if {$className ne ""} {
        if {$compile(class-$option) eq ""} {
            # If it's undefined, just save the value.
            set compile(class-$option) $className
        } elseif {$className ne $compile(class-$option)} {
            # It's been redefined differently.
            error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
        }
    }

    # NEXT, handle the args; it's not an error to redefine these.
    if {[llength $args] == 1} {
        set compile(-default-$option) [lindex $args 0]
    } else {
        foreach {optopt val} $args {
            switch -exact -- $optopt {
                -default         -
                -validatemethod  -
                -configuremethod -
                -cgetmethod      {
                    set compile($optopt-$option) $val
                }
                -readonly        {
                    if {![string is boolean -strict $val]} {
                        error "$errRoot, -readonly requires a boolean, got \"$val\""
                    }
                    set compile($optopt-$option) $val
                }
                default {
                    error "$errRoot, unknown option definition option \"$optopt\""
                }
            }
        }
    }
}

# 1 if the option name is valid, 0 otherwise.
proc ::snit::Comp.OptionNameIsValid {option} {
    if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
        return 0
    }

    return 1
}

# Defines an option's cget handler
proc ::snit::Comp.statement.oncget {option body} {
    variable compile

    set errRoot "Error in \"oncget $option...\""

    if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
        return -code error "$errRoot, option \"$option\" is delegated"
    }

    if {[lsearch -exact $compile(localoptions) $option] == -1} {
        return -code error "$errRoot, option \"$option\" unknown"
    }

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

    Comp.statement.method _cget$option {_option} $body
    Comp.statement.option $option -cgetmethod _cget$option
}

# Defines an option's configure handler.
proc ::snit::Comp.statement.onconfigure {option arglist body} {
    variable compile

    if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
        return -code error "onconfigure $option: option \"$option\" is delegated"
    }

    if {[lsearch -exact $compile(localoptions) $option] == -1} {
        return -code error "onconfigure $option: option \"$option\" unknown"
    }

    if {[llength $arglist] != 1} {
        error \
       "onconfigure $option handler should have one argument, got \"$arglist\""
    }

    CheckArgs "onconfigure $option" $arglist

    # Next, add a magic reference to the option name
    set arglist [concat _option $arglist]

    Comp.statement.method _configure$option $arglist $body
    Comp.statement.option $option -configuremethod _configure$option
}

# Defines an instance method.
proc ::snit::Comp.statement.method {method arglist body} {
    variable compile
    variable methodInfo

    # FIRST, check the method name against previously defined
    # methods.
    Comp.CheckMethodName $method 0 ::snit::methodInfo \
        "Error in \"method [list $method]...\""

    if {[llength $method] > 1} {
        set compile(hashierarchic) yes
    }

    # Remeber this method
    lappend compile(localmethods) $method

    CheckArgs "method [list $method]" $arglist

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

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

    # Next, save the definition script.
    if {[llength $method] == 1} {
        set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
        Mappend compile(defs) {
            proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
        } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
    } else {
        set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}

        Mappend compile(defs) {
            proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
        } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
            %BODY% [list $body]
    }
}

# Check for name collisions; save prefix information.
#
# method	The name of the method or typemethod.
# delFlag       1 if delegated, 0 otherwise.
# infoVar       The fully qualified name of the array containing
#               information about the defined methods.
# errRoot       The root string for any error messages.

proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
    upvar $infoVar methodInfo

    # FIRST, make sure the method name is a valid Tcl list.
    if {[catch {lindex $method 0}]} {
        error "$errRoot, the name \"$method\" must have list syntax."
    }

    # NEXT, check whether we can define it.
    if {![catch {set methodInfo($method)} data]} {
        # We can't redefine methods with submethods.
        if {[lindex $data 0] == 1} {
            error "$errRoot, \"$method\" has submethods."
        }

        # You can't delegate a method that's defined locally,
        # and you can't define a method locally if it's been delegated.
        if {$delFlag && [lindex $data 2] eq ""} {
            error "$errRoot, \"$method\" has been defined locally."
        } elseif {!$delFlag && [lindex $data 2] ne ""} {
            error "$errRoot, \"$method\" has been delegated"
        }
    }

    # Handle hierarchical case.
    if {[llength $method] > 1} {
        set prefix {}
        set tokens $method
        while {[llength $tokens] > 1} {
            lappend prefix [lindex $tokens 0]
            set tokens [lrange $tokens 1 end]

            if {![catch {set methodInfo($prefix)} result]} {
                # Prefix is known.  If it's not a prefix, throw an
                # error.
                if {[lindex $result 0] == 0} {
                    error "$errRoot, \"$prefix\" has no submethods."
                }
            }

            set methodInfo($prefix) [list 1]
        }
    }
}