linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial revision

Browse Source
This commit is contained in:
cvs
2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

791
tcl/base.tcl Normal file
View File

@@ -0,0 +1,791 @@
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}:${self}: _oIV_${iclass}:${self}:} $args]}
"iclassvars" {otObjInfoVars _oICV_${iclass}: _oICV_${iclass}: $args}
"classvars" {otObjInfoVars _oDCV_${iclass}: _oDCV_${iclass}: $args}
"objects" {otObjInfoObjects $iclass}
"methods" {otClassInfoMethods $iclass}
"sysmethods" {otClassInfoSysMethods $iclass}
"cached" {otClassInfoCached $iclass}
"body" {otClassInfoBody $iclass $args}
"args" {otClassInfoArgs $iclass $args}
"options" {$iclass::collectOptions values ret
return [array get ret] }
"defaults" {$iclass::collectOptions 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::${sect}:\$i) 1
if \[catch {\$class::$sect:\$i \$Opts(\$i)} err\] {
if \[catch {\$class::${sect}_unknown\
\$i \$Opts(\$i)}\] {
unset _obTcl_unknBarred(\$class::${sect}:\$i)
error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
\t\$err
\"
}
}
unset _obTcl_unknBarred(\$class::${sect}:\$i)
}
"
}
# Note: MkOptHandl is really a part of `option' below.
#
proc otMkOptHandl {} {
uplevel 1 {
$iclass sys_method "cget" opt "
classvar classOptions
if \[catch {$iclass::cget:\$opt} ret\] {
if \[catch {\$class::cget_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 "$i:$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($i:$opt) 1
}
if ![info exists _optPriv(cget:$opt)] {
$iclass sys_method "cget:$opt" {} "
instvar $var
return \$[set var]
"
set _optPriv(cget:$opt) 1
}
if ![info exists tmp(verify)] {
$iclass sys_method "verify:$opt" _val "
instvar $var
set $var \$_val
"
set _optPriv(verify:$opt) 1
}
if ![info exists tmp(configure)] {
$iclass sys_method "configure:$opt" _val "
instvar $var
set $var \$_val
"
set _optPriv(configure:$opt) 1
}
if ![info exists tmp(init)] {
$iclass sys_method "init:$opt" _val {}
set _optPriv(init:$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 Base::set $args
}