#
# $Id: object.tcl,v 1.1 2000/02/25 16:21:41 cvs Exp $
#
# This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University nor the names of its contributors may be used to endorse
# or promote products derived from this software without specific prior
# written permission.
# 
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#

set object_priv(currentClass) {}
set object_priv(objectCounter) 0

#----------------------------------------------------------------------
proc object_class {name spec} {
    global object_priv
    set object_priv(currentClass) $name
    lappend object_priv(objects) $name
    upvar #0 ${name}_priv class
    set class(__members) {}
    set class(__methods) {}
    set class(__params) {}
    set class(__class_vars) {}
    set class(__class_methods) {}
    uplevel $spec
    proc $name:config args "uplevel \[concat object_config \$args]"
    proc $name:configure args "uplevel \[concat object_config \$args]"
    proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
}
#---------------------------------------------------------------------
proc method {name args body} {
    global object_priv
    set className $object_priv(currentClass)
    upvar #0 ${className}_priv class
    if {[lsearch $class(__methods) $name] < 0} {
	lappend class(__methods) $name
    }
    set methodArgs self
    append methodArgs " " $args
    proc $className:$name $methodArgs "upvar #0 \$self slot ${className}_priv class_var\n$body"
}
#------------------------------------------------------------------
proc object_method {name {defaultValue {}}} [info body method]
#------------------------------------------------------------------
proc member {name {defaultValue {}}} {
    global object_priv
    set className $object_priv(currentClass)
    upvar #0 ${className}_priv class
    lappend class(__members) [list $name $defaultValue]
}
#----------------------------------------------------------------------
proc object_member {name {defaultValue {}}} [info body member]
#---------------------------------------------------------------------
proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
    global object_priv
    set className $object_priv(currentClass)
    upvar #0 ${className}_priv class
    if {$resourceClass == ""} {
	set resourceClass \
	    [string toupper [string index $name 0]][string range $name 1 end]
    }
    if ![info exists class(__param_info/$name)] {
	lappend class(__params) $name
    }
    set class(__param_info/$name) [list $defaultValue $resourceClass]
    if {$configCode != {}} {
	proc $className:config:$name self $configCode
    }
}
#-------------------------------------------------------------------------
proc object_param {name {defaultValue {}} {resourceClass {}} {configCode {}}} \
    [info body param]

#--------------------------------------------------------------------------
proc object_class_var {name {initialValue ""}} {
    global object_priv
    set className $object_priv(currentClass)
    upvar #0 ${className}_priv class
    set class($name) $initialValue
    set class(__initial_value.$name) $initialValue
    lappend class(__class_vars) $name
}
#---------------------------------------------------------------------------
proc object_class_method {name args body} {
    global object_priv
    set className $object_priv(currentClass)
    upvar #0 ${className}_priv class
    if {[lsearch $class(__class_methods) $name] < 0} {
	lappend class(__class_methods) $name
    }
    proc $className:$name $args "upvar #0 ${className}_priv class_var\n$body"
}
#---------------------------------------------------------------------------
proc object_include {super_class_name} {
    global object_priv
    set className $object_priv(currentClass)
    upvar #0 ${className}_priv class
    upvar #0 ${super_class_name}_priv super_class
    foreach p $super_class(__params) {
	lappend class(__params) $p
	set class(__param_info/$p) $super_class(__param_info/$p)
    }
    set class(__members) [concat $super_class(__members) $class(__members)]
    set class(__class_vars) \
	[concat $super_class(__class_vars) $class(__class_vars)]
    foreach v $super_class(__class_vars) {
	set class($v) \
	    [set class(__initial_value.$v) $super_class(__initial_value.$v)]
    }
    set class(__class_methods) \
	[concat $super_class(__class_methods) $class(__class_methods)]
    set class(__methods) \
	[concat $super_class(__methods) $class(__methods)]
    foreach m $super_class(__methods) {
	set proc $super_class_name:$m
	proc $className:$m [object_get_formals $proc] [info body $proc]
    }
    foreach m $super_class(__class_methods) {
	set proc $super_class_name:$m
	regexp "^\[^\n\]+\n(.*)" [info body $proc] dummy body
	proc $className:$m [object_get_formals $proc] \
	    "upvar #0 ${className}_priv class_var\n$body"
    }
}
#---------------------------------------------------------------------------
proc object_new {className {name {}}} {
    if {$name == {}} {
	global object_priv
	set name O_[incr object_priv(objectCounter)]
    }
    upvar #0 $name object
    upvar #0 ${className}_priv class
    set object(__class) $className
    foreach var $class(__params) {
	set info $class(__param_info/$var)
	set resourceClass [lindex $info 1]
	if ![catch {set val [option get $name $var $resourceClass]}] {
	    if {$val == ""} {
		set val [lindex $info 0]
	    }
	} else {
	    set val [lindex $info 0]
	}
	set object($var) $val
    }
    foreach var $class(__members) {
	set object([lindex $var 0]) [lindex $var 1]
    }
    proc $name {method args} [format {
	upvar #0 %s object
	uplevel [concat $object(__class):$method %s $args]
    } $name $name]
    return $name
}
#---------------------------------------------------------------
proc object_define_creator {windowType name spec} {
    object_class $name $spec
    if {[info procs $name:create] == {}} {
	error "widget \"$name\" must define a create method"
    }
    if {[info procs $name:reconfig] == {}} {
	error "widget \"$name\" must define a reconfig method"
    }
    proc $name {window args} [format {
	%s $window -class %s
	rename $window object_window_of$window
	upvar #0 $window object
	set object(__window) $window
	object_new %s $window
	proc %s:frame {self args} \
	    "uplevel \[concat object_window_of$window \$args]"
	uplevel [concat $window config $args]
	$window create
	set object(__created) 1
	bind $window <Destroy> \
	    "if !\[string compare %%W $window\] { object_delete $window }"
	$window reconfig
	return $window
    } $windowType \
	  [string toupper [string index $name 0]][string range $name 1 end] \
	  $name $name]
}
#------------------------------------------------------------------
proc object_config {self args} {
    upvar #0 $self object
    set len [llength $args]
    if {$len == 0} {
	upvar #0 $object(__class)_priv class
	set result {}
	foreach param $class(__params) {
	    set info $class(__param_info/$param)
	    lappend result \
		[list -$param $param [lindex $info 1] [lindex $info 0] \
		 $object($param)]
	}
	if [info exists object(__window)] {
	    set result [concat $result [object_window_of$object(__window) config]]
	}
	return $result
    }
    if {$len == 1} {
	upvar #0 $object(__class)_priv class
	if {[string index $args 0] != "-"} {
	    error "param '$args' didn't start with dash"
	}
	set param [string range $args 1 end]
	if {[set ndx [lsearch -exact $class(__params) $param]] == -1} {
	    if [info exists object(__window)] {
		return [object_window_of$object(__window) config -$param]
	    }
	    error "no param '$args'"
	}
	set info $class(__param_info/$param)
	return [list -$param $param [lindex $info 1] [lindex $info 0] \
		$object($param)]
    }
    # accumulate commands and eval them later so that no changes will take
    # place if we find an error
    set cmds ""
    while {$args != ""} {
	set fieldId [lindex $args 0]
        if {[string index $fieldId 0] != "-"} {
            error "param '$fieldId' didn't start with dash"
        }
        set fieldId [string range $fieldId 1 end]
        if ![info exists object($fieldId)] {
	    if {[info exists object(__window)]} {
		if [catch [list object_window_of$object(__window) config -$fieldId]] {
		    error "tried to set param '$fieldId' which did not exist."
		} else {
		    lappend cmds \
			[list object_window_of$object(__window) config -$fieldId [lindex $args 1]]
		    set args [lrange $args 2 end]
		    continue
		}
	    }

        }
	if {[llength $args] == 1} {
	    return $object($fieldId)
	} else {
	    lappend cmds [list set object($fieldId) [lindex $args 1]]
	    if {[info procs $object(__class):config:$fieldId] != {}} {
		lappend cmds [list $self config:$fieldId]
	    }
	    set args [lrange $args 2 end]
	}
    }
    foreach cmd $cmds {
	eval $cmd
    }
    if {[info exists object(__created)] && [info procs $object(__class):reconfig] != {}} {
	$self reconfig
    }
}

proc object_cget {self var} {
    upvar #0 $self object
    return [lindex [object_config $self $var] 4]
}
#---------------------------------------------------------------------------
proc object_delete self {
    upvar #0 $self object
    if {[info exists object(__class)] && [info commands $object(__class):destroy] != ""} {
	$object(__class):destroy $self
    }
    if [info exists object(__window)] {
	if [string length [info commands object_window_of$self]] {
	    catch {rename $self {}}
	    rename object_window_of$self $self
	}
	destroy $self
    }
    catch {unset object}
}
#--------------------------------------------------------------------------
proc object_slotname slot {
    upvar self self
    return [set self]($slot)
}
#--------------------------------------------------------------------------
proc object_get_formals {proc} {
    set formals {}
    foreach arg [info args $proc] {
	if [info default $proc $arg def] {
	    lappend formals [list $arg $def]
	} else {
	    lappend formals $arg
	}
    }
    return $formals
}