snit83.tcl

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

        } elseif {![string equal $target ""]} {
            set pattern "%c $target"
        } else {
            set pattern "%c %m"
        }
    }

    # Make sure the pattern is a valid list.
    if {[catch {lindex $pattern 0} result]} {
        error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
    }

    # NEXT, check the method name against previously defined
    # methods.
    Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot

    set typemethodInfo($method) [list 0 $pattern $component]

    if {[string equal $methodTail "*"]} {
        Mappend compile(defs) {
            set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
        } %EXCEPT% [list $exceptions]
    }
}


# Creates a delegated method delegating it to a particular
# component or command.
#
# method        The name of the method
# arglist       Delegation options.

proc ::snit::Comp.DelegatedMethod {method arglist} {
    variable compile
    variable methodInfo

    set errRoot "Error in \"delegate method [list $method]...\""

    # Next, parse the delegation options.
    set component ""
    set target ""
    set exceptions {}
    set pattern ""
    set methodTail [lindex $method end]

    foreach {opt value} $arglist {
        switch -exact $opt {
            to     { set component $value  }
            as     { set target $value     }
            except { set exceptions $value }
            using  { set pattern $value    }
            default {
                error "$errRoot, unknown delegation option \"$opt\""
            }
        }
    }

    if {[string equal $component ""] && [string equal $pattern ""]} {
        error "$errRoot, missing \"to\""
    }

    if {[string equal $methodTail "*"] && ![string equal $target ""]} {
        error "$errRoot, cannot specify \"as\" with \"*\""
    }

    if {![string equal $methodTail "*"] && ![string equal $exceptions ""]} {
        error "$errRoot, can only specify \"except\" with \"*\""
    }

    if {![string equal $pattern ""] &&![string equal  $target ""]} {
        error "$errRoot, cannot specify both \"as\" and \"using\""
    }

    foreach token [lrange $method 1 end-1] {
        if {[string equal $token "*"]} {
            error "$errRoot, \"*\" must be the last token."
        }
    }

    # NEXT, we delegate some methods
    set compile(delegatesmethods) yes

    # NEXT, define the component.  Allow typecomponents.
    if {![string equal $component ""]} {
        if {[lsearch -exact $compile(typecomponents) $component] == -1} {
            Comp.DefineComponent $component $errRoot
        }
    }

    # NEXT, define the pattern.
    if {[string equal $pattern ""]} {
        if {[string equal $methodTail "*"]} {
            set pattern "%c %m"
        } elseif {![string equal $target ""]} {
            set pattern "%c $target"
        } else {
            set pattern "%c %m"
        }
    }

    # Make sure the pattern is a valid list.
    if {[catch {lindex $pattern 0} result]} {
        error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
    }

    # NEXT, check the method name against previously defined
    # methods.
    Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot

    # NEXT, save the method info.
    set methodInfo($method) [list 0 $pattern $component]

    if {[string equal $methodTail "*"]} {
        Mappend compile(defs) {
            set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
        } %EXCEPT% [list $exceptions]
    }
}

# Creates a delegated option, delegating it to a particular
# component and, optionally, to a particular option of that
# component.
#
# optionDef     The option definition
# args          definition arguments.

proc ::snit::Comp.DelegatedOption {optionDef arglist} {
    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 \"delegate option [list $optionDef]...\""

    # Next, parse the delegation options.
    set component ""
    set target ""
    set exceptions {}

    foreach {opt value} $arglist {
        switch -exact $opt {
            to     { set component $value  }
            as     { set target $value     }
            except { set exceptions $value }
            default {
                error "$errRoot, unknown delegation option \"$opt\""
            }
        }
    }

    if {[string equal $component ""]} {
        error "$errRoot, missing \"to\""
    }

    if {[string equal $option "*"] && ![string equal $target ""]} {
        error "$errRoot, cannot specify \"as\" with \"delegate option *\""
    }

    if {![string equal $option "*"] && ![string equal $exceptions ""]} {
        error "$errRoot, can only specify \"except\" with \"delegate option *\""
    }

    # Next, validate the option name

    if {"*" != $option} {
        if {![Comp.OptionNameIsValid $option]} {
            error "$errRoot, badly named option \"$option\""
        }
    }

    if {[Contains $option $compile(localoptions)]} {
        error "$errRoot, \"$option\" has been defined locally"
    }

    if {[Contains $option $compile(delegatedoptions)]} {
        error "$errRoot, \"$option\" is multiply delegated"
    }

    # NEXT, define the component
    Comp.DefineComponent $component $errRoot

    # Next, define the target option, if not specified.
    if {![string equal $option "*"] &&
        [string equal $target ""]} {
        set target $option
    }

    # NEXT, save the delegation data.
    set compile(hasoptions) yes

    if {![string equal $option "*"]} {
        lappend compile(delegatedoptions) $option

        # Next, compute the resource and class names, if they aren't
        # already defined.

        if {"" == $resourceName} {
            set resourceName [string range $option 1 end]
        }

        if {"" == $className} {
            set className [Capitalize $resourceName]
        }

        Mappend  compile(defs) {
            set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
            set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
            set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
            lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
            set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
            lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
        }   %OPTION% $option \
            %COMP% $component \
            %TARGET% $target \
            %RES% $resourceName \
            %CLASS% $className
    } else {
        Mappend  compile(defs) {
            set %TYPE%::Snit_optionInfo(starcomp) %COMP%
            set %TYPE%::Snit_optionInfo(except) %EXCEPT%
        } %COMP% $component %EXCEPT% [list $exceptions]
    }
}

# Exposes a component, effectively making the component's command an
# instance method.
#
# component     The logical name of the delegate
# "as"          sugar; if not "", must be "as"
# methodname    The desired method name for the component's command, or ""

proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
    variable compile


    # FIRST, define the component
    Comp.DefineComponent $component

    # NEXT, define the method just as though it were in the type
    # definition.
    if {[string equal $methodname ""]} {
        set methodname $component
    }

    Comp.statement.method $methodname args [Expand {
        if {[llength $args] == 0} {
            return $%COMPONENT%
        }

        if {[string equal $%COMPONENT% ""]} {
            error "undefined component \"%COMPONENT%\""
        }


        set cmd [linsert $args 0 $%COMPONENT%]
        return [uplevel 1 $cmd]
    } %COMPONENT% $component]
}



#-----------------------------------------------------------------------
# Public commands

# Compile a type definition, and return the results as a list of two
# items: the fully-qualified type name, and a script that will define
# the type when executed.
#
# which		type, widget, or widgetadaptor
# type          the type name
# body          the type definition
proc ::snit::compile {which type body} {
    return [Comp.Compile $which $type $body]
}

proc ::snit::type {type body} {
    return [Comp.Define [Comp.Compile type $type $body]]
}

proc ::snit::widget {type body} {
    return [Comp.Define [Comp.Compile widget $type $body]]
}

proc ::snit::widgetadaptor {type body} {
    return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
}

proc ::snit::typemethod {type method arglist body} {
    # Make sure the type exists.
    if {![info exists ${type}::Snit_info]} {
        error "no such type: \"$type\""
    }

    upvar ${type}::Snit_info           Snit_info
    upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo

    # FIRST, check the typemethod name against previously defined
    # typemethods.
    Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
        "Cannot define \"$method\""

    # NEXT, check the arguments
    CheckArgs "snit::typemethod $type $method" $arglist

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

    # Next, add typevariable declarations to body:
    set body "$Snit_info(tvardecs)\n$body"

    # Next, define it.
    if {[llength $method] == 1} {
        set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
        uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
    } else {
        set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
        set suffix [join $method _]
        uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
    }
}

proc ::snit::method {type method arglist body} {
    # Make sure the type exists.
    if {![info exists ${type}::Snit_info]} {
        error "no such type: \"$type\""
    }

    upvar ${type}::Snit_methodInfo  Snit_methodInfo
    upvar ${type}::Snit_info        Snit_info

    # FIRST, check the method name against previously defined
    # methods.
    Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
        "Cannot define \"$method\""

    # NEXT, check the arguments
    CheckArgs "snit::method $type $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 "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"

    # Next, define it.
    if {[llength $method] == 1} {
        set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
        uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
    } else {
        set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}

        set suffix [join $method _]
        uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
    }
}

# Defines a proc within the compiler; this proc can call other
# type definition statements, and thus can be used for meta-programming.
proc ::snit::macro {name arglist body} {
    variable compiler
    variable reservedwords

    # FIRST, make sure the compiler is defined.
    Comp.Init

    # NEXT, check the macro name against the reserved words
    if {[lsearch -exact $reservedwords $name] != -1} {
        error "invalid macro name \"$name\""
    }

    # NEXT, see if the name has a namespace; if it does, define the
    # namespace.
    set ns [namespace qualifiers $name]

    if {![string equal $ns ""]} {
        $compiler eval "namespace eval $ns {}"
    }

    # NEXT, define the macro
    $compiler eval [list _proc $name $arglist $body]
}

#-----------------------------------------------------------------------
# Utility Functions
#
# These are utility functions used while compiling Snit types.

# Builds a template from a tagged list of text blocks, then substitutes
# all symbols in the mapTable, returning the expa