#
# 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.20 1998/07/10 04:02:44 markd Exp $
#

#
# Class objects:
#   o Stadard methods in addition to object.tcl:
#     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 Internal fields:
#    o ___nextObjectNum - Id number of next object in class.
#    o ___classFieldsImport - Commands to import all class fields.
#    o ___instInit - Proc and variable commands to define a class.
#    o ___instFields - List of instance field names.
#    o ___instFieldsImport - Commands to import all instance fields.
#    o ___localObjs - Hash table of local objects.
#
# Class methods are imported into an object; class fields are upvared
# into the object.
#

#
# 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::Class$nextClassNum
    incr nextClassNum

    set classCmd [::Sterno::_doDefClass $classNS $body]
    if [string length $name] {
        _defineObjectAlias $classNS $name [expr [info level]-1]
    }
    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]::SternoClass$nextClassNum
    incr nextClassNum

    set classCmd [::Sterno::_doDefClass $classNS $body]
    if [string length $name] {
        _defineObjectAlias $classNS $name [expr [info level]-1]
    }
    return $classCmd
}

#
# Do the work of defining a new class.
#
proc ::Sterno::_doDefClass {classNS body} {
    # Set up the class object and eval the body
    if [catch {
        set classCmd [_defineObjectNS $classNS]
        namespace eval $classNS {
            variable ___nextObjectNum 0
            variable ___classFieldsImport {variable self; variable selfns;}
            variable ___instInit {}
            variable ___instFields {self selfns class}
            variable ___instFieldsImport {variable self; variable selfns; variable class; variable classns; }
            variable ___localObjs {}

            # Code executed to initialize an instance.
            append ___instInit \
                    "variable class $self;" \
                    "variable classns $selfns;" \
                    "namespace import ${selfns}::*;" \
                    {variable ___fields [set ${classns}::___instFields];}


            # Define a class-method
            proc classMethod {name argList body} {
                eval [list proc $name $argList \
                        "eval \[set [namespace current]::___classFieldsImport]; $body"] \;
                namespace export $name
            }
            
            # Define an class-field
            proc classField {field args} {
                variable selfns
                variable ___fields
                variable ___classFieldsImport
                variable ___instInit
                variable ___instFieldsImport

                if [llength $args] {
                    variable $field [lindex $args 0]
                } else {
                    variable $field
                }
                lappend ___fields $field
                append ___classFieldsImport [list variable ${selfns}::$field] \;

                append ___instInit [list upvar #0 ${selfns}::$field $field] \;
                append ___instFieldsImport [list variable $field] \;
            }
            
            # Define an instance-method
            proc method {name argLists body} {
                variable ___instInit
                
                append ___instInit [list proc $name $argLists \
                        "eval \[set [namespace current]::___instFieldsImport]; $body"] \;
            }
            
            # Define an instance-field
            proc field {field args} {
                variable ___instInit
                variable ___instFields
                variable ___instFieldsImport

                if [llength $args] {
                    append ___instInit [list variable $field [lindex $args 0]] \;
                } else {
                    append ___instInit [list variable $field] \;
                }
                lappend ___instFields $field
                append ___instFieldsImport [list variable $field] \;
            }
            
            # Create a new object
            proc new args {
                return [::Sterno::_doNew [namespace current] {} $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]
            }
        }
        namespace eval $classNS $body
        append ${classNS}::___deleteCmds [list ::Sterno::_doDelClass $classNS] \;
    } errorResult] {
        global errorInfo errorCode
        set err [list error $errorResult $errorInfo $errorCode]
        catch {namespace delete $classNS}
        eval $err
    }
    return $classCmd
}


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

