#
# Sterno classes.
#
# Copyright (c) 1997-1998 Mark Diekhans
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# $Id: class.tcl,v 1.13 1998/01/23 04:47:33 markd Exp $
#

#
# Class objects:
#   o Standard methods:
#     o method - Define a new method.
#     o field - Define a new field that is automatically imported into
#       methods.
#     o new - Create a new instance of this class.
#     o localNew - Create a new instance of this class that is in the
#       caller's namespace.
#  o Standard fields:
#     o self - Class command.
#  o Internal fields:
#    o ___nextObjectNum - Id number of next object in class.
#    o ___classMethodImport - Command to eval to import class-methods.
#    o ___instFields - Hash table of instance field names and initial value.
#    o ___instMethods - Hash table of instance method names and proc definition.
#    o ___localObjs - Hash table of local objects.
#

#
# Initialize class stuff in ::Sterno
#
namespace eval ::Sterno {
    namespace export defClass defLocalClass
    variable nextClassNum 0
}

##
# Define a new class.
#
proc ::Sterno::defClass {name {body {}}} {
    variable nextClassNum

    set classNS ::Sterno::Classes::class$nextClassNum
    incr nextClassNum

    if [catch {
        set classCmd [::Sterno::_doDefClass $classNS $name [expr [info level]-1] $body]
    } errorResult] {
        global errorInfo errorCode
        incr nextClassNum -1
        error $errorResult $errorInfo $errorCode
    }
    return $classCmd
}

##
# Define a new class local to the current namespace of object.
#
proc ::Sterno::defLocalClass {name {body {}}} {
    variable nextClassNum

    set classNS [uplevel 1 namespace current]::Sterno::class$nextClassNum
    incr nextClassNum

    if [catch {
        set classCmd [::Sterno::_doDefClass $classNS $name [expr [info level]-1] $body]
    } errorResult] {
        global errorInfo errorCode
        incr nextClassNum -1
        error $errorResult $errorInfo $errorCode
    }
    return $classCmd
}

#
# Do the work of defining a new class.
#
proc ::Sterno::_doDefClass {classNS alias aliasLevel body} {
    # Set up the class object and eval the body
    if [catch {
        set classCmd [_defineObjectNS $classNS $alias $aliasLevel]
        _initStdClassMembers $classNS
        namespace eval $classNS $body
        _addObjDeleteCmd $classNS [list ::Sterno::_doDelClass $classNS]
    } errorResult] {
        global errorInfo errorCode
        set err [list error $errorResult $errorInfo $errorCode]
        catch {namespace delete $classNS}
        eval $err
    }
    return $classCmd
}

#
# Initialize the standard methods in the object.
#
proc ::Sterno::_initStdClassMembers {classNS} {
    namespace eval $classNS {
        variable ___nextObjectNum 0
        variable ___classMethodImport {namespace import}
        variable ___instFields
        variable ___instMethods
        variable ___localObjs

        # Define a class-method
        proc classMethod {name argList body} {
            eval [list proc $name $argList $body]
            namespace export $name
            variable ___classMethodImport
            variable selfns
            lappend ___classMethodImport ${selfns}::$name
        }

        # Define an instance-method
        proc method {name argLists body} {
            variable ___instMethods
            set ___instMethods($name) [list proc $name $argLists $body]
        }

        # Define an instance-field
        proc field {field args} {
            variable ___instFields
            set ___instFields($field) $args
        }

        # Create a new object
        proc new args {
            variable selfns
            return [::Sterno::_doNew $selfns {} $args]
        }

        # Create a new object in the callers namespaceobject
        proc localNew args {
            variable selfns
            return [::Sterno::_doNew $selfns \
                    [uplevel 1 namespace current]::Sterno::[namespace tail $selfns] $args]
        }
    }
}

#
# Proc called when class object is deleted.
# Cleans up any local objects.
#
proc ::Sterno::_doDelClass classNS {
    foreach obj [set ${classNS}::___localObjs] {
        _deleteObjIfExists $obj
    }
}

