crunch_skip begin
DOC "class Base" {
 NAME
	Base	- The basic class inherited by all obTcl objects

 SYNOPSIS
	Base new <obj>
		- Creates an object of the simplest possible class.

 DESCRIPTION
	All classes inherits the Base class automatically.  The Base class
	provides methods that are essential for manipulating obTcl-objects,
	such as `info' and `destroy'.

 METHODS
	Base provides the following generic methods to all objects:

	new		- EXPERIMENTAL! Arranges to create a new object of
			  the class of the invoking object.

	instance	- EXPERIMENTAL! Arranges to create a new object of
			  the class of the invoking object.  This method
			  differs from `new' by NOT automatically invoking
			  the `init' method of the new object.
			  One possible usage:  Create a replacement for the
			  normal class object -a replacement which has no
			  hard-coded methods (this will need careful design
			  though).

	init		- Does nothing.  The init method is automatically
			  invoked whenever an object is created with `new'.

	destroy		- Frees all instance variables of the object, and
			  the object itself.

	class		- Returns the class of the object.

	set name ?value?
			- Sets the instance variable `name' to value.
			  If no value is specified, the current value is
			  returned.  Mainly used for debugging purposes.

	info <cmd>	- Returns information about the object.  See INFO
			  below.

	eval <script>	- Evaluates `script' in the context of the object.
			  Useful for debugging purposes.  Not meant to be
			  used for other purposes (create a method instead).
			  One useful trick (if you use the Tcl-debugger in
			  this package) is to enter:
				obj eval bp
			  to be able to examine `obj's view of the world
			  (breakpoints must be enabled, of course).

	unknown <method> <args>
			- Automatically invoked when unknown methods are
			  invoked.  the Base class defines this method to
			  print an error message, but this can be overridden
			  by derived classes.

	option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
			- Define an option handler.
			  See OPTION HANDLER below for a description.

	conf_verify <args>
	conf_init <args>
			- Set options. <args> are option-value pairs.
			  See OPTION HANDLER below for a description.

	configure <args>
			- Set options. <args> are option-value pairs.
			  See OPTION HANDLER below for a description.

	cget <opt>	- Get option value.
			  See OPTION HANDLER below for a description.

	verify_unknown <args>
	init_unknown <args>
	configure_unknown <args>
	cget_unknown <opt>
			- These methods are automatically invoked when a requested
			  option has not been defined.
			  See OPTION HANDLER below for a description.

 INFO
	The method `info' can be used to inspect an object.  In the list below
	(I) means the command is only applicable to object instances, whereas
	(C) means that the command can be applied either to the class object, or
	to the object instance, if that is more convenient.
	Existing commands:

	instvars	- (I) Returns the names of all existing instance variables.
	iclassvars	- (I) List instance class variables

	classvars	- (C) List class variables.
	objects		- (C) List objects of this class.
	methods		- (C) List methods defined in this class.
	sysmethods	- (C) List system methods defined in this class.
	cached		- (C) List cached methods for this class.
	body <method>	- (C) List the body of a method.
	args <method>	- (C) List formal parameters for a method.

	options		- (I) List the current option values in the format
			  "option-value pairs".
	defaults	- (C) List the current default values in the format
			  "option-value pairs".  These values are the initial
			  values each new object will be given.

 OPTION HANDLER
	The method `option' is used to define options. It should be used on
	the class-object, which serves as a repository for default values
	and for code sections to run to verify and make use of new default values.
	
	option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
		Define an option for this class.
		Defining an option results in an instance variable
		of the same name (with the leading '-' stripped)
		being defined.  This variable will be initiated
		with the value <default>.

		The sections `verify', `init' and `configure' can be defined.

		`verify' is used to verify new parameters without affecting
		the object.  It is typically called by an object's init method
		before all parts of the object have been created.

		`init' is used for rare situations where some action should be taken
		just after the object has been fully created.  I.e when setting
		the option variable via `verify' was not sufficient.

		The `configure' section is invoked when the configure method is
		called to re-configure an object. 

		Example usage:

		    class Graph
		    Graph inherit Widget

		    Graph option {-width} 300 verify {
			if { $width >= 600 } {
				error "width must be less than 600"
			}
		    } configure {
			$self.grf configure -width $width
		    }

		Note 1: The `verify' section should never attempt
		to access structures in the object (i.e widgets), since
		it is supposed to be callable before they exist!
		Use the `configure' section to manipulate the object.

		Note 2: Using "break" or "error" in the verify section results
		in the newly specified option value being rejected.

	conf_verify <args>
		Invoke all "verify" sections for options-value pairs
		specified in <args>.
	conf_init <args>
		Invoke all "init" sections for options-value pairs
		specified in <args>.

		Example usage:

		    Graph method init { args } {
			instvar width

			# Set any option variables from $args
			#
			eval $self conf_verify $args  ;# Set params

			next -width $width	;# Get frame

			CreateRestOfObject	;# Bogus

			# Option handlers that wish to affect the
			# object during init may declare an "init"
			# section.  Run any such sections now:
			#
			eval $self conf_init $args
		    }

		    Graph .graph -width 400	;# Set width initially

	configure <args>
		Invoke all "configure" sections for options-value pairs
		specified in <args>.

		Example usage:

		    # First create object 
		    #
		    Graph .graph -width 300

		    # Use `configure' to configure the object
		    #
		    .graph configure -width 200

	cget <opt>
		Returns the current value of option <opt>.
		Example usage:

			.graph cget -width

	<sect>_unknown <args>
		These methods are called when attempting to invoke sections
		for unknown options.  In this way a class may define methods
		to catch usage of "configure", "cget", etc. for undefined
		options.
		Example:

		    Graph method configure_unknown { opt args } {
			eval {$self-cmd configure $opt} $args
		    }

		See the definitions of the Base and Widget classes for their
		usage of these methods.
}
crunch_skip end

#----------------------------------------------------------------------
# Define the Base class.  This class provides introspection etc.
#
# It also provides "set", which gives access to object
# internal variables, and 'eval' which lets you run arbitrary scripts in
# the objects context.  You may wish to remove those methods if you
# want to disallow this.

class Base

Base method init args {}

Base method destroy args {
	otFreeObj $self
}

Base method class args {
	return $iclass
}

# Note: The `set' method takes on the class of the caller, so
#	instvars will use the callers scope.
#
Base method set args {
	set class $iclass
	# instvar [lindex $args 0]
	set var [lindex $args 0]
	regexp -- {^([^(]*)\(.*\)$} $var m var
	instvar $var
	return [eval set $args]
}

Base method eval l {
	return [eval $l]
}

Base method info { cmd args } {
	switch $cmd {
	"instvars"	{return [eval {otObjInfoVars\
		_oIV_${iclass}V${self}V _oIV_${iclass}V${self}V} $args]}
	"iclassvars"	{otObjInfoVars _oICV_${iclass}V _oICV_${iclass}V $args}
	"classvars"	{otObjInfoVars _oDCV_${iclass}V _oDCV_${iclass}V $args}
	"objects"	{otObjInfoObjects $iclass}
	"methods"	{otClassInfoMethods $iclass}
	"sysmethods"	{otClassInfoSysMethods $iclass}
	"cached"	{otClassInfoCached $iclass}
	"body"		{otClassInfoBody $iclass $args}
	"args"		{otClassInfoArgs $iclass $args}

	"options"	{${iclass}VVcollectOptions values ret
			return [array get ret] }
	"defaults"	{${iclass}VVcollectOptions defaults ret
			return [array get ret] }

	default	{
			return -code error \
			-errorinfo "Undefined command 'info $cmd'" \
			"Undefined command 'info $cmd'"
		}
	}	
}

Base method unknown args {
	return -code error \
		-errorinfo "Undefined method '$method' invoked" \
		"Undefined method '$method' invoked"
}

#------- START EXPERIMENTAL

Base method new { obj args } {
	eval {otNew $iclass $obj} $args
}

Base method instance { obj args } {
	eval {otInstance $iclass $obj} $args
}

Base method sys_method args {
	eval {otMkMethod S $iclass} $args
}

Base method method args {
	eval {otMkMethod N $iclass} $args
}

Base method del_method args {
	eval {otRmMethod $iclass} $args
}

Base method inherit args {
	eval {otInherit $iclass} $args
}

# class AnonInst - inherit from this class to be able to generate
# anonymous objects.  Example:
#
#	class Foo
#	Foo inherit AnonInst
#	set obj [Foo new]
#
# NOTE: EXPERIMENTAL!!!

class AnonInst
AnonInst method anonPrefix p {
	iclassvar _prefix
	set _prefix $p
}
AnonInst method new {{obj {}} args} {
	iclassvar _count _prefix
	if ![info exists _count] {
		set _count 0
	}
	if ![info exists _prefix] {
		set _prefix "$iclass"
	}
	if ![string compare "" $obj] {
        	set obj $_prefix[incr _count]
	}
	eval next {$obj} $args
	return $obj
}
#------- END EXPERIMENTAL

#----------------------------------------------------------------------
# Configure stuff
#----------------------------------------------------------------------
# The configuaration stuff is, for various reasons, probably the most
# change-prone part of obTcl.
#
# After fiddling around with various methods for handling options,
# this is what I came up with.  It uses one method for each class and option,
# plus one dispatch-method for each of "conf_init", "conf_verify", "configure"
# and "cget" per class.  Any extra sections in the `option' handler
# results in another dispatch-method being created.
# Attempts at handling undefined options are redirected to
#
#	<section_name>_unknown
#
# Note:
#	Every new object is initialized by a call to `initialize'.
#	This is done in the proc "new", before `init' is called, to guarantee
#	that initial defaults are set before usage.  `initialize' calls "next", so
#	all inherited classes are given a chance to set their initial defaults.
#
# Sections and their used (by convention):
#
#	verify	- Called at beginning of object initialization to verify
#		  specified options.
#	init	- Called at end of the class' `init' method.
#		  Use for special configuration.
#	configure
#		- This section should use the new value to configure
#		  the object.
#

# MkSectMethod - Define a method which does:
#   For each option specified, call the handler for the specified section
#   and option.  If this fails, call the <section>_unknown handler.
#   If this fails too, return an error.
#   Note that the normal call of the method `unknown' is avoided by
#   telling the unknown handler to avoid this (by means of the global array
#   "_obTcl_unknBarred").
#
proc otMkSectMethod { class name sect } {
	$class sys_method $name args "
		array set Opts \$args
		foreach i \[array names Opts\] {
			global _obTcl_unknBarred
			set _obTcl_unknBarred(\${class}VV${sect}V\$i) 1
			if \[catch {\${class}VV${sect}V\$i \$Opts(\$i)} err\] {
				if \[catch {\${class}VV${sect}_unknown\
					\$i \$Opts(\$i)}\] {
					unset _obTcl_unknBarred(\${class}VV${sect}V\$i)
				  	error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
						\t\$err
					\"
			 	}
			}
			unset _obTcl_unknBarred(\${class}VV${sect}V\$i)
		}
	"
}

# Note: MkOptHandl is really a part of `option' below.
#
proc otMkOptHandl {} {
    uplevel 1 {
	$iclass sys_method "cget" opt "
		classvar classOptions
		if \[catch {${iclass}VVcgetV\$opt} ret\] {
			if \[catch {\${class}VVcget_unknown \$opt} ret\] {
			  	error \"Unable to do 'cget \$opt'\"
			}
		}
		return \$ret
	"
	otMkSectMethod $iclass conf_init init
	$iclass sys_method initialize {} {
		next
		classvar optDefaults
		eval instvar [array names optDefaults]
		foreach i [array names optDefaults] {
			set $i $optDefaults($i)
		}
	}

	# arr - Out-param
	#
	$iclass sys_method collectOptions { mode arr } {
		classvar classOptions optDefaults

		upvar 1 $arr ret
		next $mode ret
		eval instvar [array names optDefaults]
		foreach i [array names optDefaults] {
			if [string compare "defaults" $mode] {
				set ret(-$i) [set $classOptions(-$i)]
			} else {
				set ret(-$i) $optDefaults($i)
			}
		}
	}
	otMkSectMethod $iclass conf_verify verify
	otMkSectMethod $iclass configure configure

	set _optPriv(section,cget) 1
	set _optPriv(section,init) 1
	set _optPriv(section,initialize) 1
	set _optPriv(section,verify) 1
	set _optPriv(section,configure) 1
    }
}

otMkSectMethod Base configure configure

# _optPriv is used for internal option handling house keeping
# Note: checking for existence of a proc is not always a good idea,
# since it may simply be a cached pointer to a inherited method.
#
Base method option { opt dflt args } {

	classvar_of_class $iclass optDefaults classOptions _optPriv

	set var [string range $opt 1 end]
	set optDefaults($var) $dflt
	set classOptions($opt) $var

	array set tmp $args
	if ![info exists _optPriv(initialize)] {
		otMkOptHandl
		set _optPriv(initialize) 1
	}
	foreach i [array names tmp] {
		if ![info exists _optPriv(section,$i)] {
			otMkSectMethod $iclass $i $i
			set _optPriv(section,$i) 1
		}
		$iclass sys_method "$iV$opt" _val "
			instvar $var
			set _old_val \$[set var]
			set $var \$_val
			set ret \[catch {$tmp($i)} res\]
			if {\$ret != 0 && \$ret != 2 } {
				set $var \$_old_val
				return -code \$ret -errorinfo \$res \$res
			}
			return \$res
		"
		set _optPriv($iV$opt) 1
	}
	if ![info exists _optPriv(cgetV$opt)] {
		$iclass sys_method "cgetV$opt" {} "
			instvar $var
			return \$[set var]
		"
		set _optPriv(cgetV$opt) 1
	}
	if ![info exists tmp(verify)] {
		$iclass sys_method "verifyV$opt" _val "
			instvar $var
			set $var \$_val
		"
		set _optPriv(verifyV$opt) 1
	}
	if ![info exists tmp(configure)] {
		$iclass sys_method "configureV$opt" _val "
			instvar $var
			set $var \$_val
		"
		set _optPriv(configureV$opt) 1
	}
	if ![info exists tmp(init)] {
		$iclass sys_method "initV$opt" _val {}
		set _optPriv(initV$opt) 1
	}
}

# Default methods for non-compulsory
# standard sections in an option definition:
#
Base sys_method init_unknown { opt val } {}
Base sys_method verify_unknown { opt val } {}

# Catch initialize for classes which have no option handlers:
#
Base sys_method initialize {} {}

# Catch conf_init in case no option handlers have been defined.
#
Base sys_method conf_init {} {}

crunch_skip begin

#----------------------------------------------------------------------
#
# class Widget
#	Base class for obTcl's Tk-widgets.
#

DOC "class Widget (Tk) base class for widgets" {
 NAME
	Widget	- A base class for mega-widgets

 SYNOPSIS
	Widget new <obj> ?tk_widget_type? ?config options?
	Widget <obj> ?tk_widget_type? ?config options?

 DESCRIPTION
	The widget class provides a base class for Tk-objects.
	This class knows about widget naming conventions, so, for example,
	destroying a Widget object will destroy any descendants of this object.

	The `new' method need not be specified if the object name starts with a
	leading ".".  Thus giving syntactical compatibility with Tk for
	creating widgets.

	If `tk_widget_type' is not specified, the widget will be created as
	a `frame'.  If the type is specified it must be one of the existing
	Tk-widget types, for example: button, radiobutton, text, etc.
	See the Tk documentation for available widget types.

	The normal case is to use a frame as the base for a mega-widget.
	This is also the recommended way, since it results in the Tk class-name
	of the frame being automatically set to the objects class name  -thus
	resulting in "winfo class <obj>" returning the mega-widget's class
	name.

	In order to create mega-widgets, derive new classes from this class.

 METHODS
	The following methods are defined in Widget:

	init ?<args>?	- Creates a frame widget, and configures it if any
			  configuration options are present.  Automatically
			  invoked by the creation process, so there is no
			  need to call it (provided that you use 'next' in
			  the init-method of the derived class).

	destroy		- Destroys the object and associated tk-widget.
			  For Tk-compatibility, the function `destroy' can be
			  used instead, example:

				destroy <obj>

			  Note:  If you plan to mix Tk-widgets transparently
			  with mega-widgets, you should use the _function_
			  `destroy'.
			  Any descendant objects of <obj> will also be
			  destroyed (this goes for both Tk-widgets and
			  mega-widgets).

	set		- Overrides the `set' method of the Base class to
			  allow objects of type `scrollbar' to work correctly.

	unknown		- Overrides the `unknown' method of the Base class.
			  Directs any unknown methods to the main frame of
			  the Widget object.

	unknown_opt	- Overrides the same method from the Base class.
			  Automatically called from the option handling system.
			  Directs any unknown options to the main frame of the
			  Widget object.

	In addition, all non-shadowed methods from the Base class can be used.

	Any method that cannot be resolved is passed on to the associated
	Tk-widget.  This behaviour can be altered for any derived classes
	by defining a new `unknown' method (thus shadowing Widget's own
	`unknown' method).  The same technique can be used to override
	the `unknown_opt' method.

 EXAMPLES
	A simple example of deriving a class MegaButton which consists of
	a button widget initiated with the text "MEGA" (yes, I know, it's
	silly).

		class MegaButton
		MegaButton inherit Widget

		MegaButton method init { args } {
			#
			# Allow the Widget class to create a button for us
			# (we need to specify widget type `button')
			#
			eval next button $args
	
			$self configure -text "MEGA"
		}

		frame .f
		MegaButton .f.b -background red -foreground white
		pack .f .f.b

	This example shows how to specify a Tk-widget type (button), although
	I advice against specifying anything (thus using a frame).
	See DESCRIPTION above for the reasoning behind this.  Also note that
	`eval' is used to split $args into separate arguments for passing to
	the init method of the Widget class.

	A more realistic example:

		class ScrolledText
		ScrolledText inherit Widget

		ScrolledText method init { args } {
			next

			text $self.t -yscrollcommand "$self.sb set"
			scrollbar $self.sb -command "$self.t yview"

			pack $self.sb -side right -fill y
			pack $self.t -side left

			eval $self configure $args
		}

		ScrolledText method unknown { args } {
			eval {$self.t $method} $args
		}

		ScrolledText .st
		.st insert end [exec cat /etc/passwd]
		pack .st

	This creates a new class, ScrolledText, containing a text window
	and a vertical scrollbar.  It arranges for all unknown methods to
	be directed to the text widget; thus allowing `.st insert' to work
	normally (along with any other text methods).

 NOTES
	Widget binds the "destroy" method to the <Destroy> event of
	the holding window, so be careful not to remove this binding
	inadvertently.
}

crunch_skip end

class Widget

# init	Create a tk-widget of specified type (or frame if not specified).
#	If the corresponding Tk-widget already exists, it will be used.
#	Otherwise the Tk-widget will be created.
#	The tk-widget will be named $self if $self has a leading ".",
#	otherwise a "." is prepended to $self to form the wigdet name.
#	The instvar `win' will contain the widgets window name, and
#	the instvar `wincmd' will contain the name of the widget's associated
#	command.

Widget method init args {
	instvar win wincmd

	next

	set first "[lindex $args 0]"
	set c1 "[string index $first 0]"
	if { ![string compare "" "$c1"] || ![string compare "-" "$c1"] } {
		set type frame
		set cl "-class $iclass"
	} else {
		set type $first
		set args [lrange $args 1 end]
		set cl ""
	}
	if [string compare "" [info commands $self-cmd]] {
		set win $self
		set wincmd $self-cmd
	} else {
	  if ![string compare "." [string index $self 0]] {
		rename $self _ooTmp
		eval $type $self $cl $args
		rename $self $self-cmd
		rename _ooTmp $self
		set win $self
		set wincmd $self-cmd
	  } else {
		eval $type .$self $cl $args
		set win .$self
		#set wincmd .$self-cmd
		set wincmd .$self
	  }
	}
	bind $win <Destroy> "\
		if { !\[string compare \"%W\" \"$self\"\] && !\[catch {info args $self}\] } {
			$self destroy -obj_only }"

	return $self
}

# Just for the case when there are no option-handlers defined:
#
Widget sys_method configure args {
	instvar wincmd
	eval {$wincmd configure} $args
}
Widget sys_method cget opt {
	instvar wincmd
	eval {$wincmd cget} $opt
}

Widget sys_method configure_unknown { opt args } {
	instvar wincmd
	eval {$wincmd configure $opt} $args
}

Widget sys_method cget_unknown opt {
	instvar wincmd
	$wincmd cget $opt
}
Widget sys_method init_unknown { opt val } {
	puts "init_unknown: $opt $val (iclass=$iclass class=$class)"
}

Widget sys_method unknown args {
	instvar wincmd
	eval {$wincmd $method} $args
}

# Note: no "next" used!  Does the `Base::destroy' stuff here for performance.
#
Widget method destroy args {
	
	instvar win wincmd

	# Must copy vars since they are destroyed by `otFreeObj'
	set wp $win
	set w $wincmd

	otFreeObj $self
	catch {bind $w <Destroy> {}}
	if [string compare "-obj_only" $args] {
		if [string compare $w $wp] {
			rename $w $wp
		}
		if [string compare "-keepwin" $args] {
			destroy $wp
		}
	}
}

# The method `set' defined here shadows the `set' method from Base.
# This allows wrapper objects around Tk-scrollbars to work correctly.
#
Widget sys_method set args {
	instvar wincmd
	eval {$wincmd set} $args
}

Widget sys_method base_set args {
	eval BaseVVset $args
}