snit83.tcl

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

#-----------------------------------------------------------------------
# TITLE:
#	snit.tcl
#
# AUTHOR:
#	Will Duquette
#
# DESCRIPTION:
#       Snit's Not Incr Tcl, a simple object system in Pure Tcl.
#
#       Copyright (C) 2003-2005 by William H. Duquette
#       This code is licensed as described in license.txt.
#
#-----------------------------------------------------------------------
# Back-port to Tcl8.3 by Kenneth Green (kmg)
# Modified by Andreas Kupries.
# 06 Jun 2005
#
# Local changes marked with "#kmg-tcl83"
#
# Global changes:
#  " eq " => "string equal"
#  " ne " -> "!string equal"
#  " trace add variable " -> "trace variable "
#  " write " -> "w" in all calls to 'trace variable'
#  " unset -nocomplain "  -> "::snit83::unset -nocomplain"
#  " -glob " -> "" in all calls to 'array names'
#-----------------------------------------------------------------------

package provide snit 1.1

#-----------------------------------------------------------------------
# Namespace

namespace eval ::snit:: {
    namespace export \
        compile type widget widgetadaptor typemethod method macro
}

#-----------------------------------------------------------------------
# Some Snit variables

namespace eval ::snit:: {
    variable reservedArgs {type selfns win self}

    # Widget classes which can be hulls (must have -class)
    variable hulltypes {
	toplevel tk::toplevel
	frame tk::frame ttk::frame
	labelframe tk::labelframe ttk::labelframe
    }
}

source [file dirname [info script]]/snit_tcl83_utils.tcl

#-----------------------------------------------------------------------
# Snit Type Implementation template

namespace eval ::snit:: {
    # Template type definition: All internal and user-visible Snit
    # implementation code.
    #
    # The following placeholders will automatically be replaced with
    # the client's code, in two passes:
    #
    # First pass:
    # %COMPILEDDEFS%  The compiled type definition.
    #
    # Second pass:
    # %TYPE%          The fully qualified type name.
    # %IVARDECS%      Instance variable declarations
    # %TVARDECS%      Type variable declarations
    # %TCONSTBODY%    Type constructor body
    # %INSTANCEVARS%  The compiled instance variable initialization code.
    # %TYPEVARS%      The compiled type variable initialization code.

    # This is the overall type template.
    variable typeTemplate

    # This is the normal type proc
    variable nominalTypeProc

    # This is the "-hastypemethods no" type proc
    variable simpleTypeProc
}

set ::snit::typeTemplate {

    #-------------------------------------------------------------------
    # The type's namespace definition and the user's type variables

    namespace eval %TYPE% {%TYPEVARS%
    }

    #----------------------------------------------------------------
    # Commands for use in methods, typemethods, etc.
    #
    # These are implemented as aliases into the Snit runtime library.

    interp alias {} %TYPE%::installhull  {} ::snit::RT.installhull %TYPE%
    interp alias {} %TYPE%::install      {} ::snit::RT.install %TYPE%
    interp alias {} %TYPE%::typevariable {} ::variable
    interp alias {} %TYPE%::variable     {} ::snit::RT.variable
    interp alias {} %TYPE%::mytypevar    {} ::snit::RT.mytypevar %TYPE%
    interp alias {} %TYPE%::typevarname  {} ::snit::RT.mytypevar %TYPE%
    interp alias {} %TYPE%::myvar        {} ::snit::RT.myvar
    interp alias {} %TYPE%::varname      {} ::snit::RT.myvar
    interp alias {} %TYPE%::codename     {} ::snit::RT.codename %TYPE%
    interp alias {} %TYPE%::myproc       {} ::snit::RT.myproc %TYPE%
    interp alias {} %TYPE%::mymethod     {} ::snit::RT.mymethod
    interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
    interp alias {} %TYPE%::from         {} ::snit::RT.from %TYPE%

    #-------------------------------------------------------------------
    # Snit's internal variables

    namespace eval %TYPE% {
        # Array: General Snit Info
        #
        # ns:                The type's namespace
        # hasinstances:      T or F, from pragma -hasinstances.
        # simpledispatch:    T or F, from pragma -hasinstances.
        # canreplace:        T or F, from pragma -canreplace.
        # counter:           Count of instances created so far.
        # widgetclass:       Set by widgetclass statement.
        # hulltype:          Hull type (frame or toplevel) for widgets only.
        # exceptmethods:     Methods explicitly not delegated to *
        # excepttypemethods: Methods explicitly not delegated to *
        # tvardecs:          Type variable declarations--for dynamic methods
        # ivardecs:          Instance variable declarations--for dyn. methods
        typevariable Snit_info
        set Snit_info(ns)      %TYPE%::
        set Snit_info(hasinstances) 1
        set Snit_info(simpledispatch) 0
        set Snit_info(canreplace) 0
        set Snit_info(counter) 0
        set Snit_info(widgetclass) {}
        set Snit_info(hulltype) frame
        set Snit_info(exceptmethods) {}
        set Snit_info(excepttypemethods) {}
        set Snit_info(tvardecs) {%TVARDECS%}
        set Snit_info(ivardecs) {%IVARDECS%}

        # Array: Public methods of this type.
        # The index is the method name, or "*".
        # The value is [list $pattern $componentName], where
        # $componentName is "" for normal methods.
        typevariable Snit_typemethodInfo
        array unset Snit_typemethodInfo

        # Array: Public methods of instances of this type.
        # The index is the method name, or "*".
        # The value is [list $pattern $componentName], where
        # $componentName is "" for normal methods.
        typevariable Snit_methodInfo
        array unset Snit_methodInfo

        # Array: option information.  See dictionary.txt.
        typevariable Snit_optionInfo
        array unset Snit_optionInfo
        set Snit_optionInfo(local)     {}
        set Snit_optionInfo(delegated) {}
        set Snit_optionInfo(starcomp)  {}
        set Snit_optionInfo(except)    {}
    }

    #----------------------------------------------------------------
    # Compiled Procs
    #
    # These commands are created or replaced during compilation:


    # Snit_instanceVars selfns
    #
    # Initializes the instance variables, if any.  Called during
    # instance creation.

    proc %TYPE%::Snit_instanceVars {selfns} {
        %INSTANCEVARS%
    }

    # Type Constructor
    proc %TYPE%::Snit_typeconstructor {type} {
        %TVARDECS%
        %TCONSTBODY%
    }

    #----------------------------------------------------------------
    # Default Procs
    #
    # These commands might be replaced during compilation:

    # Snit_destructor type selfns win self
    #
    # Default destructor for the type.  By default, it does
    # nothing.  It's replaced by any user destructor.
    # For types, it's called by method destroy; for widgettypes,
    # it's called by a destroy event handler.

    proc %TYPE%::Snit_destructor {type selfns win self} { }

    #----------------------------------------------------------
    # Compiled Definitions

    %COMPILEDDEFS%

    #----------------------------------------------------------
    # Finally, call the Type Constructor

    %TYPE%::Snit_typeconstructor %TYPE%
}

#-----------------------------------------------------------------------
# Type procs
#
# These procs expect the fully-qualified type name to be
# substituted in for %TYPE%.

# This is the nominal type proc.  It supports typemethods and
# delegated typemethods.
set ::snit::nominalTypeProc {
    # Type dispatcher function.  Note: This function lives
    # in the parent of the %TYPE% namespace!  All accesses to
    # %TYPE% variables and methods must be qualified!
    proc %TYPE% {{method ""} args} {
        # First, if there's no method, and no args, and there's a create
        # method, and this isn't a widget, then method is "create" and
        # "args" is %AUTO%.
        if {[string equal $method ""] && [llength $args] == 0} {
            ::variable %TYPE%::Snit_info

            if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
                set method create
                lappend args %AUTO%
            } else {
                error "wrong \# args: should be \"%TYPE% method args\""
            }
        }

        # Next, retrieve the command.
	variable %TYPE%::Snit_typemethodCache
        while 1 {
            if {[catch {set Snit_typemethodCache($method)} commandRec]} {
                set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]

                if {[llength $commandRec] == 0} {
                    return -code error  "\"%TYPE% $method\" is not defined"
                }
            }

            # If we've got a real command, break.
            if {[lindex $commandRec 0] == 0} {
                break
            }

            # Otherwise, we need to look up again...if we can.
            if {[llength $args] == 0} {
                return -code error \
                 "wrong number args: should be \"%TYPE% $method method args\""
            }

            lappend method [lindex $args 0]
            set args [lrange $args 1 end]
        }

        set command [lindex $commandRec 1]

        # Pass along the return code unchanged.
        set retval [catch {uplevel 1 $command $args} result]

        if {$retval} {
            if {$retval == 1} {
                global errorInfo
                global errorCode
                return -code error -errorinfo $errorInfo \
                    -errorcode $errorCode $result
            } else {
                return -code $retval $result
            }
        }

        return $result
    }
}

# This is the simplified type proc for when there are no typemethods
# except create.  In this case, it doesn't take a method argument;
# the method is always "create".
set ::snit::simpleTypeProc {
    # Type dispatcher function.  Note: This function lives
    # in the parent of the %TYPE% namespace!  All accesses to
    # %TYPE% variables and methods must be qualified!
    proc %TYPE% {args} {
        ::variable %TYPE%::Snit_info

        # FIRST, if the are no args, the single arg is %AUTO%
        if {[llength $args] == 0} {
            if {$Snit_info(isWidget)} {
                error "wrong \# args: should be \"%TYPE% name args\""
            }

            lappend args %AUTO%
        }

        # NEXT, we're going to call the create method.
        # Pass along the return code unchanged.
        if {$Snit_info(isWidget)} {
            set command [list ::snit::RT.widget.typemethod.create %TYPE%]
        } else {
            set command [list ::snit::RT.type.typemethod.create %TYPE%]
        }

        set retval [catch {uplevel 1 $command $args} result]

        if {$retval} {
            if {$retval == 1} {
                global errorInfo
                global errorCode
                return -code error -errorinfo $errorInfo \
                    -errorcode $errorCode $result
            } else {
                return -code $retval $result
            }
        }

        return $result
    }
}

#-----------------------------------------------------------------------
# Instance procs
#
# The following must be substituted into these proc bodies:
#
# %SELFNS%       The instance namespace
# %WIN%          The original instance name
# %TYPE%         The fully-qualified type name
#

# Nominal instance proc body: supports method caching and delegation.
#
# proc $instanceName {method args} ....
set ::snit::nominalInstanceProc {
    set self [set %SELFNS%::Snit_instance]

    while {1} {
        if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
            set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]

            if {[llength $commandRec] == 0} {
                return -code error \
                    "\"$self $method\" is not defined"
            }
        }

        # If we've got a real command, break.
        if {[lindex $commandRec 0] == 0} {
            break
        }

        # Otherwise, we need to look up again...if we can.
        if {[llength $args] == 0} {
            return -code error \
                "wrong number args: should be \"$self $method method args\""
        }

        lappend method [lindex $args 0]
        set args [lrange $args 1 end]
    }

    set command [lindex $commandRec 1]

    # Pass along the return code unchanged.
    set retval [catch {uplevel 1 $command $args} result]

    if {$retval} {
        if {$retval == 1} {
            global errorInfo
            global errorCode
            return -code error -errorinfo $errorInfo \
                -errorcode $errorCode $result
        } else {
            return -code $retval $result
        }
    }

    return $result
}

# Simplified method proc body: No delegation allowed; no support for
# upvar or exotic return codes or hierarchical methods.  Designed for
# max speed for simple types.
#
# proc $instanceName {method args} ....