#
# Sterno core object support.  All objects, including classes are base on a
# namespace created with this code.
#
# 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: object.tcl,v 1.15 1998/02/17 03:35:37 markd Exp $
#

##
# Core objects:
#  o Standard methods:
#    o delete - Delete the object.
#    o fget - Get a field of the object.  This is any namespace
#      variable, not just ones defined by the class field method.
#    o fset - Set a field of the object.
#    o fref - Get a fully qualified field reference.
#  o Standard fields:
#    o self - Object command.
#    o selfns - Object's namespace.
#  o Internal methods:
#    o ___call - Call a method.
#  o Internal fields:
#    o ___aliasCmd - Alias command if one is assoiciate with the object,
#      otherwise empty.
#    o ___deleteCmds - List of commands to eval when object is deleted.
#

#
# Make sure namespace exists.
#
namespace eval ::Sterno {}

#
# Define an object namespace.  Not used externally.  This sets up a namespace
# with a few standard methods.
#
# A object command in the namespace is returned.  An alias command may also be
# created to allow for a fixed name that the object will be known by.  If
# alias is not empty, a command is created at call level that is aliased to
# the actual object command.  If the object already exists, it is destroyed.
#
#
proc ::Sterno::_defineObjectNS {objNS {alias {}} {aliasLevel -1}} {
    # Start with a fresh namespace.
    catch {namespace delete $objNS}
    namespace eval $objNS {}
     
    # Define object command and optional alias command.
    set objCmd ${objNS}::___call

    proc $objCmd {method args} {
        uplevel 1 [concat [namespace current]::$method $args]
    }

    if [llength $alias] {
        # Create alias command and then get back its full path.
        # If command is not fully qualified, qualify it.
        if {![string match ::* $alias] && $aliasLevel > 0} {
            set aliasCmd [uplevel #$aliasLevel [list namespace current]]::$alias
        } else {
            set aliasCmd $alias
        }
        uplevel #$aliasLevel [list interp alias {} $aliasCmd {} $objCmd]
    } else {
        set aliasCmd {}
    }
    
    # Internal fields.
    variable ${objNS}::___aliasCmd $aliasCmd
    variable ${objNS}::___deleteCmds {}

    # Standard fields.
    variable ${objNS}::self $objCmd
    variable ${objNS}::selfns $objNS

    # Standard methods.
    namespace eval $objNS {
        proc delete {} {
            ::Sterno::_deleteObj [namespace current]
        }
        # fget/set generate full name so that arrays work.
        proc fget field {
            variable selfns
            return [set ${selfns}::${field}]
        }
        proc fset {field value} {
            variable selfns
            return [set ${selfns}::${field} $value]
        }
        proc fref field {
            variable selfns
            return ${selfns}::${field}
        }
        proc fields {} {
            variable ___fields
            return $___fields
        }
    }
    return $objCmd
}

#
# Arrange for code to be executed when the object is deleted.
#
proc ::Sterno::_addObjDeleteCmd {objNS cmd} {
    lappend ${objNS}::___deleteCmds $cmd
}

#
# Do the work of deleting an object.  Also deletes the alias comand.
#
proc ::Sterno::_deleteObj objNS {
    variable ${objNS}::___aliasCmd
    if [llength $___aliasCmd] {
        rename $___aliasCmd {}
    }

    # Any additional cleanup?
    variable ${objNS}::___deleteCmds
    foreach cmd $___deleteCmds {
        catch {eval $cmd}
    }
    namespace delete $objNS
}

#
# Delete an object if it exists.
#
proc ::Sterno::_deleteObjIfExists objCmd {
    if [llength [info command $objCmd]] {
        $objCmd delete
    }
}
