snit2.tcl

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

# "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 {$ns ne ""} {
        $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 expanded template.
proc ::snit::Expand {template args} {
    return [string map $args $template]
}

# Expands a template and appends it to a variable.
proc ::snit::Mappend {varname template args} {
    upvar $varname myvar

    append myvar [string map $args $template]
}

# Checks argument list against reserved args 
proc ::snit::CheckArgs {which arglist} {
    variable reservedArgs
    
    foreach name $reservedArgs {
        if {$name in $arglist} {
            error "$which's arglist may not contain \"$name\" explicitly"
        }
    }
}

# Capitalizes the first letter of a string.
proc ::snit::Capitalize {text} {
    set first [string index $text 0]
    set rest [string range $text 1 end]
    return "[string toupper $first]$rest"
}


#=======================================================================
# Snit Runtime Library
#
# These are procs used by Snit types and widgets at runtime.

#-----------------------------------------------------------------------
# Object Creation

# Creates a new instance of the snit::type given its name and the args.
#
# type		The snit::type
# name		The instance name
# args		Args to pass to the constructor

proc ::snit::RT.type.typemethod.create {type name args} {
    variable ${type}::Snit_info
    variable ${type}::Snit_optionInfo

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

    # NEXT, if %AUTO% appears in the name, generate a unique 
    # command name.  Otherwise, ensure that the name isn't in use.
    if {[string match "*%AUTO%*" $name]} {
        set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
    } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
        error "command \"$name\" already exists"
    }

    # NEXT, create the instance's namespace.
    set selfns \
        [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
    namespace eval $selfns {}

    # NEXT, install the dispatcher
    RT.MakeInstanceCommand $type $selfns $name

    # Initialize the options to their defaults. 
    upvar ${selfns}::options options
    foreach opt $Snit_optionInfo(local) {
        set options($opt) $Snit_optionInfo(default-$opt)
    }
        
    # Initialize the instance vars to their defaults.
    # selfns must be defined, as it is used implicitly.
    ${type}::Snit_instanceVars $selfns

    # Execute the type's constructor.
    set errcode [catch {
        RT.ConstructInstance $type $selfns $name $args
    } result]

    if {$errcode} {
        global errorInfo
        global errorCode
        
        set theInfo $errorInfo
        set theCode $errorCode

        ::snit::RT.DestroyObject $type $selfns $name
        error "Error in constructor: $result" $theInfo $theCode
    }

    # NEXT, return the object's name.
    return $name
}

# Creates a new instance of the snit::widget or snit::widgetadaptor
# given its name and the args.
#
# type		The snit::widget or snit::widgetadaptor
# name		The instance name
# args		Args to pass to the constructor

proc ::snit::RT.widget.typemethod.create {type name args} {
    variable ${type}::Snit_info
    variable ${type}::Snit_optionInfo

    # FIRST, if %AUTO% appears in the name, generate a unique 
    # command name.
    if {[string match "*%AUTO%*" $name]} {
        set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
    }
            
    # NEXT, create the instance's namespace.
    set selfns \
        [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
    namespace eval $selfns { }
            
    # NEXT, Initialize the widget's own options to their defaults.
    upvar ${selfns}::options options
    foreach opt $Snit_optionInfo(local) {
        set options($opt) $Snit_optionInfo(default-$opt)
    }

    # Initialize the instance vars to their defaults.
    ${type}::Snit_instanceVars $selfns

    # NEXT, if this is a normal widget (not a widget adaptor) then 
    # create a frame as its hull.  We set the frame's -class to
    # the user's widgetclass, or, if none, to the basename of
    # the $type with an initial upper case letter.
    if {!$Snit_info(isWidgetAdaptor)} {
        # FIRST, determine the class name
        if {"" == $Snit_info(widgetclass)} {
            set Snit_info(widgetclass) \
                [::snit::Capitalize [namespace tail $type]]
        }

        # NEXT, create the widget
        set self $name
        package require Tk
        ${type}::installhull using \
            $Snit_info(hulltype) -class $Snit_info(widgetclass)

        # NEXT, let's query the option database for our
        # widget, now that we know that it exists.
        foreach opt $Snit_optionInfo(local) {
            set dbval [RT.OptionDbGet $type $name $opt]

            if {"" != $dbval} {
                set options($opt) $dbval
            }
        }
    }

    # Execute the type's constructor, and verify that it
    # has a hull.
    set errcode [catch {
        RT.ConstructInstance $type $selfns $name $args

        ::snit::RT.Component $type $selfns hull

        # Prepare to call the object's destructor when the
        # <Destroy> event is received.  Use a Snit-specific bindtag
        # so that the widget name's tag is unencumbered.

        bind Snit$type$name <Destroy> [::snit::Expand {
            ::snit::RT.DestroyObject %TYPE% %NS% %W
        } %TYPE% $type %NS% $selfns]

        # Insert the bindtag into the list of bindtags right
        # after the widget name.
        set taglist [bindtags $name]
        set ndx [lsearch -exact $taglist $name]
        incr ndx
        bindtags $name [linsert $taglist $ndx Snit$type$name]
    } result]

    if {$errcode} {
        global errorInfo
        global errorCode

        set theInfo $errorInfo
        set theCode $errorCode
        ::snit::RT.DestroyObject $type $selfns $name
        error "Error in constructor: $result" $theInfo $theCode
    }

    # NEXT, return the object's name.
    return $name
}


# RT.MakeInstanceCommand type selfns instance
#
# type        The object type
# selfns      The instance namespace
# instance    The instance name
#
# Creates the instance proc.

proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
    variable ${type}::Snit_info
        
    # FIRST, remember the instance name.  The Snit_instance variable
    # allows the instance to figure out its current name given the
    # instance namespace.
    upvar ${selfns}::Snit_instance Snit_instance
    set Snit_instance $instance

    # NEXT, qualify the proc name if it's a widget.
    if {$Snit_info(isWidget)} {
        set procname ::$instance
    } else {
        set procname $instance
    }

    # NEXT, install the new proc
    # WHD: Snit 2.0 code

    set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""]
    set createCmd [list namespace ensemble create \
                       -command $procname \
                       -unknown $unknownCmd \
                       -prefixes 0]

    namespace eval $selfns $createCmd

    # NEXT, add the trace.
    trace add command $procname {ren