snit2.tcl

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

    # 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]
        }
    }
}

# Defines a typemethod method.
proc ::snit::Comp.statement.typemethod {method arglist body} {
    variable compile
    variable typemethodInfo

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

    CheckArgs "typemethod $method" $arglist

    # First, add magic reference to type.
    set arglist [concat type $arglist]

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

    # Next, save the definition script
    if {[llength $method] == 1} {
        set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}

        Mappend compile(defs) {
            proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
        } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
    } else {
        set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}

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


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

    if {"" != $compile(typeconstructor)} {
        error "too many typeconstructors"
    }

    set compile(typeconstructor) $body
} 

# Defines a static proc in the type's namespace.
proc ::snit::Comp.statement.proc {proc arglist body} {
    variable compile

    # If "ns" is defined, the proc can see instance variables.
    if {[lsearch -exact $arglist selfns] != -1} {
        # Next, add instance variable declarations to body:
        set body "%IVARDECS%\n$body"
    }

    # The proc can always see typevariables.
    set body "%TVARDECS%\n$body"

    append compile(defs) "

        # Proc $proc
        proc [list %TYPE%::$proc $arglist $body]
    "
} 

# Defines a static variable in the type's namespace.
proc ::snit::Comp.statement.typevariable {name args} {
    variable compile

    set errRoot "Error in \"typevariable $name...\""

    set len [llength $args]
    
    if {$len > 2 ||
        ($len == 2 && [lindex $args 0] ne "-array")} {
        error "$errRoot, too many initializers"
    }

    if {[lsearch -exact $compile(varnames) $name] != -1} {
        error "$errRoot, \"$name\" is already an instance variable"
    }

    lappend compile(typevarnames) $name

    if {$len == 1} {
        append compile(typevars) \
		"\n\t    [list ::variable $name [lindex $args 0]]"
    } elseif {$len == 2} {
        append compile(typevars) \
            "\n\t    [list ::variable $name]"
        append compile(typevars) \
            "\n\t    [list array set $name [lindex $args 1]]"
    } else {
        append compile(typevars) \
		"\n\t    [list ::variable $name]"
    }

    append compile(tvprocdec) "\n\t    typevariable ${name}"
} 

# Defines an instance variable; the definition will go in the
# type's create typemethod.
proc ::snit::Comp.statement.variable {name args} {
    variable compile

    set errRoot "Error in \"variable $name...\""

    set len [llength $args]
    
    if {$len > 2 ||
        ($len == 2 && [lindex $args 0] ne "-array")} {
        error "$errRoot, too many initializers"
    }

    if {[lsearch -exact $compile(typevarnames) $name] != -1} {
        error "$errRoot, \"$name\" is already a typevariable"
    }

    lappend compile(varnames) $name

    if {$len == 1} {
        append compile(instancevars) \
            "\nset \${selfns}::$name [list [lindex $args 0]]\n"
    } elseif {$len == 2} {
        append compile(instancevars) \
            "\narray set \${selfns}::$name [list [lindex $args 1]]\n"
    } 

    append  compile(ivprocdec) "\n\t    "
    Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name 
} 

# Defines a typecomponent, and handles component options.
#
# component     The logical name of the delegate
# args          options.

proc ::snit::Comp.statement.typecomponent {component args} {
    variable compile

    set errRoot "Error in \"typecomponent $component...\""

    # FIRST, define the component
    Comp.DefineTypecomponent $component $errRoot

    # NEXT, handle the options.
    set publicMethod ""
    set inheritFlag 0

    foreach {opt val} $args {
        switch -exact -- $opt {
            -public {
                set publicMethod $val
            }
            -inherit {
                set inheritFlag $val
                if {![string is boolean $inheritFlag]} {
    error "typecomponent $component -inherit: expected boolean value, got \"$val\""
                }
            }
            default {
                error "typecomponent $component: Invalid option \"$opt\""
            }
        }
    }

    # NEXT, if -public specified, define the method.  
    if {$publicMethod ne ""} {
        Comp.statement.delegate typemethod [list $publicMethod *] to $component
    }

    # NEXT, if "-inherit 1" is specified, delegate typemethod * to 
    # this component.
    if {$inheritFlag} {
        Comp.statement.delegate typemethod "*" to $component
    }

}


# Defines a name to be a typecomponent
# 
# The name becomes a typevariable; in addition, it gets a 
# write trace so that when it is set, all of the component mechanisms
# get updated.
#
# component     The component name

proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
    variable compile

    if {[lsearch -exact $compile(varnames) $component] != -1} {
        error "$errRoot, \"$component\" is already an instance variable"
    }

    if {[lsearch -exact $compile(typecomponents) $component] == -1} {
        # Remember we've done this.
        lappend compile(typecomponents) $component

        # Make it a type variable with no initial value