Initial revision
This commit is contained in:
cvs
791
tcl/tcl8/base8.tcl
Normal file
791
tcl/tcl8/base8.tcl
Normal 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}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
|
||||
}
|
||||
|
||||
297
tcl/tcl8/inherit8.tcl
Normal file
297
tcl/tcl8/inherit8.tcl
Normal file
@@ -0,0 +1,297 @@
|
||||
#----------------------------------------------------------------------
|
||||
# Method resolution and caching
|
||||
#
|
||||
|
||||
proc otPrInherits {} {
|
||||
global _obTcl_Classes
|
||||
foreach i [array names _obTcl_Classes]\
|
||||
{puts "$i inherits from: [$i inherit]"}
|
||||
}
|
||||
|
||||
proc otInherit { class args } {
|
||||
global _obTcl_Inherits
|
||||
|
||||
if ![string compare "" $args] {
|
||||
return [set _obTcl_Inherits($class)]
|
||||
}
|
||||
if { [string compare "Base" $class] && [lsearch $args "Base"] == -1 } {
|
||||
set args [concat $args "Base"]
|
||||
}
|
||||
if [info exists _obTcl_Inherits($class)] {
|
||||
#
|
||||
# This class is not new, invalidate caches
|
||||
#
|
||||
otInvalidateCaches 0 $class [otClassInfoCached ${class}]
|
||||
} else {
|
||||
set _obTcl_Inherits($class) {}
|
||||
}
|
||||
set _obTcl_Inherits($class) $args
|
||||
}
|
||||
|
||||
proc otInvalidateCaches { level class methods } {
|
||||
global _obTcl_CacheStop
|
||||
|
||||
foreach i $methods {
|
||||
if ![string compare "unknown" $i] { set i "*" }
|
||||
set _obTcl_CacheStop($i) 1
|
||||
}
|
||||
if [array exists _obTcl_CacheStop] { otDoInvalidate }
|
||||
}
|
||||
|
||||
# There is a catch on rename and unset since current build of tmp
|
||||
# does not guarantee that each element is unique.
|
||||
|
||||
proc otDoInvalidate {} {
|
||||
global _obTcl_CacheStop _obTcl_Cached
|
||||
if ![array exists _obTcl_Cached] {
|
||||
unset _obTcl_CacheStop
|
||||
return
|
||||
}
|
||||
if [info exists _obTcl_CacheStop(*)] {
|
||||
set stoplist "*"
|
||||
} else {
|
||||
set stoplist [array names _obTcl_CacheStop]
|
||||
}
|
||||
foreach i $stoplist {
|
||||
set tmp [array names _obTcl_Cached *VV$i]
|
||||
eval lappend tmp [array names _obTcl_Cached *VV${i}_next]
|
||||
foreach k $tmp {
|
||||
catch {
|
||||
rename $k {}
|
||||
unset _obTcl_Cached($k)
|
||||
}
|
||||
}
|
||||
}
|
||||
if ![array size _obTcl_Cached] {
|
||||
unset _obTcl_Cached
|
||||
}
|
||||
unset _obTcl_CacheStop
|
||||
}
|
||||
|
||||
if ![string compare "" [info procs otUnknown]] {
|
||||
rename unknown otUnknown
|
||||
}
|
||||
|
||||
proc otResolve { class func } {
|
||||
return [otGetFunc 0 $class $func]
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# `unknown' and `next' both create cache methods.
|
||||
#
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# unknown -
|
||||
# A missing function was found. See if it can be resolved
|
||||
# from inheritance.
|
||||
#
|
||||
# If function name does not follow the *VV* pattern, call the normal
|
||||
# unknown handler.
|
||||
#
|
||||
# Umethod is for use by the "unknown" method. If the method is named
|
||||
# `unknown' it will have $method set to $Umethod (the invokers method
|
||||
# name).
|
||||
#
|
||||
|
||||
setIfNew _obTcl_unknBarred() ""
|
||||
|
||||
proc unknown args {
|
||||
global _obTcl_unknBarred
|
||||
# Resolve inherited function calls
|
||||
#
|
||||
set name [lindex $args 0]
|
||||
if [string match *VV* $name] {
|
||||
set tmp [split $name V]
|
||||
set class [lindex $tmp 0]
|
||||
set func [join [lrange $tmp 2 end] V]
|
||||
|
||||
set flist [otGetFunc 0 $class $func]
|
||||
if ![string compare "" $flist] {
|
||||
if [info exists _obTcl_unknBarred($name)] { return -code error }
|
||||
set flist [otGetFunc 0 $class "unknown"]
|
||||
}
|
||||
if [string compare "" $flist] {
|
||||
proc $name args "otGetSelf
|
||||
set Umethod $func
|
||||
eval [lindex $flist 0] \$args"
|
||||
} else {
|
||||
proc $name args "
|
||||
return -code error\
|
||||
-errorinfo \"Undefined method '$func' invoked\" \
|
||||
\"Undefined method '$func' invoked\"
|
||||
"
|
||||
}
|
||||
global _obTcl_Cached
|
||||
set _obTcl_Cached(${class}VV$func) $class
|
||||
|
||||
# Code below borrowed from init.tcl (tcl7.4)
|
||||
#
|
||||
global errorCode errorInfo
|
||||
set code [catch {uplevel $args} msg]
|
||||
if { $code == 1 } {
|
||||
#
|
||||
# Strip the last five lines off the error stack (they're
|
||||
# from the "uplevel" command).
|
||||
#
|
||||
set new [split $errorInfo \n]
|
||||
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
|
||||
return -code error -errorcode $errorCode \
|
||||
-errorinfo $new $msg
|
||||
} else {
|
||||
return -code $code $msg
|
||||
}
|
||||
} else {
|
||||
uplevel [concat otUnknown $args]
|
||||
}
|
||||
}
|
||||
|
||||
setIfNew _obTcl_Cnt 0
|
||||
|
||||
# 6/11/95 Added _obTcl_nextRet to allow propagation of return-values
|
||||
# from `next' calls. I.e doing `return [next $args]' will
|
||||
# be meaningful. It is only in simple cases that the return
|
||||
# value is shure to make sense. With multiple inheritance
|
||||
# it may be impossible to rely on!
|
||||
#
|
||||
# NOTE: This support is experimental and likely to be removed!!!
|
||||
#
|
||||
# Improved for lower overhead with big args-lists
|
||||
# NOTE: It is understood that `args' is initialized from the `next'
|
||||
# procedure.
|
||||
#
|
||||
proc otChkCall { cmd } {
|
||||
global _obTcl_Trace _obTcl_Cnt _obTcl_nextRet
|
||||
if ![info exists _obTcl_Trace($cmd)] {
|
||||
set _obTcl_Trace($cmd) 1
|
||||
catch {uplevel 1 "uplevel 1 \"$cmd \$args\""} _obTcl_nextRet
|
||||
}
|
||||
return $_obTcl_nextRet
|
||||
}
|
||||
|
||||
# otNextPrepare is really just a part of proc `next' below.
|
||||
#
|
||||
proc otNextPrepare {} {
|
||||
uplevel 1 {
|
||||
set all [otGetNextFunc $class $method]
|
||||
|
||||
foreach i $all {
|
||||
# Note: args is the literal _name_ of var to use, hence
|
||||
# no $-sign!
|
||||
append tmp "otChkCall $i\n"
|
||||
}
|
||||
|
||||
if [info exists tmp] {
|
||||
proc ${class}VV${method}_next args $tmp
|
||||
} else {
|
||||
proc ${class}VV${method}_next args return
|
||||
}
|
||||
set _obTcl_Cached(${class}VV${method}_next) $class
|
||||
}
|
||||
}
|
||||
|
||||
# next -
|
||||
# Invoke next shadowed method. Protect against multiple invocation.
|
||||
# Multiple invocation would occur when several inherited classes inherit
|
||||
# a common superclass.
|
||||
#
|
||||
# Note: I use `info exists' on _obTcl_Cached, rater than `info procs' on
|
||||
# the corresponding procedure, since checking for a variable seems to be
|
||||
# about three times faster (Tcl7.4).
|
||||
#
|
||||
proc next args {
|
||||
global _obTcl_Cnt _obTcl_Cached _obTcl_nextRet
|
||||
# otGetSelf inlined and modified
|
||||
upvar 1 self self method method class class
|
||||
|
||||
if { $_obTcl_Cnt == 0 } {
|
||||
set _obTcl_nextRet ""
|
||||
}
|
||||
if ![info exists _obTcl_Cached(${class}VV${method}_next)] {
|
||||
otNextPrepare
|
||||
}
|
||||
|
||||
incr _obTcl_Cnt 1
|
||||
set ret [catch {uplevel 1 {${class}VV${method}_next} $args} val]
|
||||
incr _obTcl_Cnt -1
|
||||
|
||||
if { $_obTcl_Cnt == 0 } {
|
||||
global _obTcl_Trace
|
||||
catch {unset _obTcl_Trace}
|
||||
}
|
||||
if { $ret != 0 } {
|
||||
return -code error \
|
||||
-errorinfo "$self: $val" "$self: $val"
|
||||
} else {
|
||||
return $val
|
||||
}
|
||||
}
|
||||
|
||||
# otGetNextFunc -
|
||||
# Get a method by searching inherited classes, skipping the local
|
||||
# class.
|
||||
#
|
||||
proc otGetNextFunc { class func } {
|
||||
global _obTcl_Inherits
|
||||
|
||||
set all ""
|
||||
foreach i [set _obTcl_Inherits($class)] {
|
||||
foreach k [otGetFunc 0 $i $func] {
|
||||
lappendUniq all $k
|
||||
}
|
||||
}
|
||||
return $all
|
||||
}
|
||||
|
||||
# otGetFunc -
|
||||
# Locate a method by searching the inheritance tree.
|
||||
# Cyclic inheritance is discovered and reported. A list of all
|
||||
# found methods is returned, with the closest first in the list.
|
||||
# Cache-methods are skipped, and will hence not figure in the list.
|
||||
#
|
||||
# 16/12/95 Added support for autoloading of classes.
|
||||
#
|
||||
proc otGetFunc { depth class func } {
|
||||
global _obTcl_Inherits _obTcl_Cached _obTcl_NoClasses _obTcl_Classes
|
||||
|
||||
if { $depth > $_obTcl_NoClasses } {
|
||||
otGetFuncErr $depth $class $func
|
||||
return ""
|
||||
}
|
||||
incr depth
|
||||
set all ""
|
||||
|
||||
if ![info exists _obTcl_Classes($class)] {
|
||||
if ![auto_load $class] {
|
||||
otGetFuncMissingClass $depth $class $func
|
||||
return ""
|
||||
}
|
||||
}
|
||||
if { [string compare "" [info procs ${class}VV$func]] &&
|
||||
![info exists _obTcl_Cached(${class}VV$func)] } {
|
||||
return "${class}VV$func"
|
||||
}
|
||||
foreach i [set _obTcl_Inherits($class)] {
|
||||
set ret [otGetFunc $depth $i $func]
|
||||
if [string compare "" $ret] {
|
||||
foreach i $ret {
|
||||
lappendUniq all $i
|
||||
}
|
||||
}
|
||||
}
|
||||
return $all
|
||||
}
|
||||
|
||||
# Note: Real error handling should be added here!
|
||||
# Specifically we need to report which object triggered the error.
|
||||
|
||||
proc otGetFuncErr { depth class func } {
|
||||
puts stderr "GetFunc: depth=$depth, circular dependency!?"
|
||||
puts stderr " class=$class func=$func"
|
||||
}
|
||||
proc otGetFuncMissingClass { depth class func } {
|
||||
puts stderr "GetFunc: Unable to inherit from $class"
|
||||
puts stderr " $class not defined (and auto load failed)"
|
||||
puts stderr " Occurred while looking for ${class}VV$func"
|
||||
}
|
||||
|
||||
617
tcl/tcl8/init8.tcl
Normal file
617
tcl/tcl8/init8.tcl
Normal file
@@ -0,0 +1,617 @@
|
||||
# init.tcl --
|
||||
#
|
||||
# Default system startup file for Tcl-based applications. Defines
|
||||
# "unknown" procedure and auto-load facilities.
|
||||
#
|
||||
# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
#----------------------------------------------------------------------------
|
||||
#
|
||||
# Modified by Mark Koennecke in order to redirect unknown into the Sics
|
||||
# mechanism. Thereby disabling command shortcuts and execution of shell
|
||||
# commands for security reasons.
|
||||
#
|
||||
# February 1997
|
||||
# Hacked for Tcl 8.0 September 1997, bad hack if problems start anew
|
||||
#
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if {[info commands package] == ""} {
|
||||
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
|
||||
}
|
||||
package require -exact Tcl 8.0
|
||||
#if [catch {set auto_path $env(TCLLIBPATH)}] {
|
||||
# set auto_path ""
|
||||
#}
|
||||
if {[lsearch -exact $auto_path [info library]] < 0} {
|
||||
lappend auto_path [info library]
|
||||
}
|
||||
catch {
|
||||
foreach dir $tcl_pkgPath {
|
||||
if {[lsearch -exact $auto_path $dir] < 0} {
|
||||
lappend auto_path $dir
|
||||
}
|
||||
}
|
||||
unset dir
|
||||
}
|
||||
package unknown tclPkgUnknown
|
||||
|
||||
# Some machines, such as the Macintosh, do not have exec. Also, on all
|
||||
# platforms, safe interpreters do not have exec.
|
||||
# exec hereby disabled for Security reasons! MK
|
||||
set auto_noexec 1
|
||||
|
||||
|
||||
set errorCode ""
|
||||
set errorInfo ""
|
||||
|
||||
# unknown --
|
||||
# This procedure is called when a Tcl command is invoked that doesn't
|
||||
# exist in the interpreter. It takes the following steps to make the
|
||||
# command available:
|
||||
#
|
||||
# 1. See if the autoload facility can locate the command in a
|
||||
# Tcl script file. If so, load it and execute it.
|
||||
# 2. If the command was invoked interactively at top-level:
|
||||
# (a) see if the command exists as an executable UNIX program.
|
||||
# If so, "exec" the command.
|
||||
# (b) see if the command requests csh-like history substitution
|
||||
# in one of the common forms !!, !<number>, or ^old^new. If
|
||||
# so, emulate csh's history substitution.
|
||||
# (c) see if the command is a unique abbreviation for another
|
||||
# command. If so, invoke the command.
|
||||
#
|
||||
# Arguments:
|
||||
# args - A list whose elements are the words of the original
|
||||
# command, including the command name.
|
||||
|
||||
proc unknown args {
|
||||
global auto_noexec auto_noload env unknown_pending tcl_interactive
|
||||
global errorCode errorInfo
|
||||
|
||||
# Save the values of errorCode and errorInfo variables, since they
|
||||
# may get modified if caught errors occur below. The variables will
|
||||
# be restored just before re-executing the missing command.
|
||||
|
||||
set savedErrorCode $errorCode
|
||||
set savedErrorInfo $errorInfo
|
||||
set name [lindex $args 0]
|
||||
if ![info exists auto_noload] {
|
||||
#
|
||||
# Make sure we're not trying to load the same proc twice.
|
||||
#
|
||||
if [info exists unknown_pending($name)] {
|
||||
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
|
||||
}
|
||||
set unknown_pending($name) pending;
|
||||
set ret [catch {auto_load $name} msg]
|
||||
unset unknown_pending($name);
|
||||
if {$ret != 0} {
|
||||
return -code $ret -errorcode $errorCode \
|
||||
"error while autoloading \"$name\": $msg"
|
||||
}
|
||||
if ![array size unknown_pending] {
|
||||
unset unknown_pending
|
||||
}
|
||||
if $msg {
|
||||
set errorCode $savedErrorCode
|
||||
set errorInfo $savedErrorInfo
|
||||
set code [catch {uplevel $args} msg]
|
||||
if {$code == 1} {
|
||||
#
|
||||
# Strip the last five lines off the error stack (they're
|
||||
# from the "uplevel" command).
|
||||
#
|
||||
|
||||
set new [split $errorInfo \n]
|
||||
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
|
||||
return -code error -errorcode $errorCode \
|
||||
-errorinfo $new $msg
|
||||
} else {
|
||||
return -code $code $msg
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Try running SICS for a change
|
||||
set ret [catch {uplevel #0 SicsUnknown $args} msg]
|
||||
if {$ret == 1} {
|
||||
return -code error $msg
|
||||
} else {
|
||||
return -code ok $msg
|
||||
}
|
||||
}
|
||||
|
||||
# auto_load --
|
||||
# Checks a collection of library directories to see if a procedure
|
||||
# is defined in one of them. If so, it sources the appropriate
|
||||
# library file to create the procedure. Returns 1 if it successfully
|
||||
# loaded the procedure, 0 otherwise.
|
||||
#
|
||||
# Arguments:
|
||||
# cmd - Name of the command to find and load.
|
||||
|
||||
proc auto_load cmd {
|
||||
global auto_index auto_oldpath auto_path env errorInfo errorCode
|
||||
|
||||
if [info exists auto_index($cmd)] {
|
||||
uplevel #0 $auto_index($cmd)
|
||||
return [expr {[info commands $cmd] != ""}]
|
||||
}
|
||||
if ![info exists auto_path] {
|
||||
return 0
|
||||
}
|
||||
if [info exists auto_oldpath] {
|
||||
if {$auto_oldpath == $auto_path} {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
set auto_oldpath $auto_path
|
||||
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
|
||||
set dir [lindex $auto_path $i]
|
||||
set f ""
|
||||
if [catch {set f [open [file join $dir tclIndex]]}] {
|
||||
continue
|
||||
}
|
||||
set error [catch {
|
||||
set id [gets $f]
|
||||
if {$id == "# Tcl autoload index file, version 2.0"} {
|
||||
eval [read $f]
|
||||
} elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
|
||||
while {[gets $f line] >= 0} {
|
||||
if {([string index $line 0] == "#")
|
||||
|| ([llength $line] != 2)} {
|
||||
continue
|
||||
}
|
||||
set name [lindex $line 0]
|
||||
set auto_index($name) \
|
||||
"source [file join $dir [lindex $line 1]]"
|
||||
}
|
||||
} else {
|
||||
error "[file join $dir tclIndex] isn't a proper Tcl index file"
|
||||
}
|
||||
} msg]
|
||||
if {$f != ""} {
|
||||
close $f
|
||||
}
|
||||
if $error {
|
||||
error $msg $errorInfo $errorCode
|
||||
}
|
||||
}
|
||||
if [info exists auto_index($cmd)] {
|
||||
uplevel #0 $auto_index($cmd)
|
||||
if {[info commands $cmd] != ""} {
|
||||
return 1
|
||||
}
|
||||
}
|
||||
return 0
|
||||
}
|
||||
|
||||
if {[string compare $tcl_platform(platform) windows] == 0} {
|
||||
|
||||
# auto_execok --
|
||||
#
|
||||
# Returns string that indicates name of program to execute if
|
||||
# name corresponds to a shell builtin or an executable in the
|
||||
# Windows search path, or "" otherwise. Builds an associative
|
||||
# array auto_execs that caches information about previous checks,
|
||||
# for speed.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name of a command.
|
||||
|
||||
# Windows version.
|
||||
#
|
||||
# Note that info executable doesn't work under Windows, so we have to
|
||||
# look for files with .exe, .com, or .bat extensions. Also, the path
|
||||
# may be in the Path or PATH environment variables, and path
|
||||
# components are separated with semicolons, not colons as under Unix.
|
||||
#
|
||||
proc auto_execok name {
|
||||
global auto_execs env tcl_platform
|
||||
|
||||
if [info exists auto_execs($name)] {
|
||||
return $auto_execs($name)
|
||||
}
|
||||
set auto_execs($name) ""
|
||||
|
||||
if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename
|
||||
ren rmdir rd time type ver vol} $name] != -1} {
|
||||
if {[info exists env(COMSPEC)]} {
|
||||
set comspec $env(COMSPEC)
|
||||
} elseif {[info exists env(ComSpec)]} {
|
||||
set comspec $env(ComSpec)
|
||||
} elseif {$tcl_platform(os) == "Windows NT"} {
|
||||
set comspec "cmd.exe"
|
||||
} else {
|
||||
set comspec "command.com"
|
||||
}
|
||||
return [set auto_execs($name) [list $comspec /c $name]]
|
||||
}
|
||||
|
||||
if {[llength [file split $name]] != 1} {
|
||||
foreach ext {{} .com .exe .bat} {
|
||||
set file ${name}${ext}
|
||||
if {[file exists $file] && ![file isdirectory $file]} {
|
||||
return [set auto_execs($name) $file]
|
||||
}
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
set path "[file dirname [info nameof]];.;"
|
||||
if {[info exists env(WINDIR)]} {
|
||||
set windir $env(WINDIR)
|
||||
} elseif {[info exists env(windir)]} {
|
||||
set windir $env(windir)
|
||||
}
|
||||
if {[info exists windir]} {
|
||||
if {$tcl_platform(os) == "Windows NT"} {
|
||||
append path "$windir/system32;"
|
||||
}
|
||||
append path "$windir/system;$windir;"
|
||||
}
|
||||
|
||||
if {! [info exists env(PATH)]} {
|
||||
if [info exists env(Path)] {
|
||||
append path $env(Path)
|
||||
} else {
|
||||
return ""
|
||||
}
|
||||
} else {
|
||||
append path $env(PATH)
|
||||
}
|
||||
|
||||
foreach dir [split $path {;}] {
|
||||
if {$dir == ""} {
|
||||
set dir .
|
||||
}
|
||||
foreach ext {{} .com .exe .bat} {
|
||||
set file [file join $dir ${name}${ext}]
|
||||
if {[file exists $file] && ![file isdirectory $file]} {
|
||||
return [set auto_execs($name) $file]
|
||||
}
|
||||
}
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
} else {
|
||||
|
||||
# auto_execok --
|
||||
#
|
||||
# Returns string that indicates name of program to execute if
|
||||
# name corresponds to an executable in the path. Builds an associative
|
||||
# array auto_execs that caches information about previous checks,
|
||||
# for speed.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name of a command.
|
||||
|
||||
# Unix version.
|
||||
#
|
||||
proc auto_execok name {
|
||||
global auto_execs env
|
||||
|
||||
if [info exists auto_execs($name)] {
|
||||
return $auto_execs($name)
|
||||
}
|
||||
set auto_execs($name) ""
|
||||
if {[llength [file split $name]] != 1} {
|
||||
if {[file executable $name] && ![file isdirectory $name]} {
|
||||
set auto_execs($name) $name
|
||||
}
|
||||
return $auto_execs($name)
|
||||
}
|
||||
foreach dir [split $env(PATH) :] {
|
||||
if {$dir == ""} {
|
||||
set dir .
|
||||
}
|
||||
set file [file join $dir $name]
|
||||
if {[file executable $file] && ![file isdirectory $file]} {
|
||||
set auto_execs($name) $file
|
||||
return $file
|
||||
}
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
}
|
||||
# auto_reset --
|
||||
# Destroy all cached information for auto-loading and auto-execution,
|
||||
# so that the information gets recomputed the next time it's needed.
|
||||
# Also delete any procedures that are listed in the auto-load index
|
||||
# except those defined in this file.
|
||||
#
|
||||
# Arguments:
|
||||
# None.
|
||||
|
||||
proc auto_reset {} {
|
||||
global auto_execs auto_index auto_oldpath
|
||||
foreach p [info procs] {
|
||||
if {[info exists auto_index($p)] && ![string match auto_* $p]
|
||||
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
|
||||
tclPkgUnknown} $p] < 0)} {
|
||||
rename $p {}
|
||||
}
|
||||
}
|
||||
catch {unset auto_execs}
|
||||
catch {unset auto_index}
|
||||
catch {unset auto_oldpath}
|
||||
}
|
||||
|
||||
# auto_mkindex --
|
||||
# Regenerate a tclIndex file from Tcl source files. Takes as argument
|
||||
# the name of the directory in which the tclIndex file is to be placed,
|
||||
# followed by any number of glob patterns to use in that directory to
|
||||
# locate all of the relevant files.
|
||||
#
|
||||
# Arguments:
|
||||
# dir - Name of the directory in which to create an index.
|
||||
# args - Any number of additional arguments giving the
|
||||
# names of files within dir. If no additional
|
||||
# are given auto_mkindex will look for *.tcl.
|
||||
|
||||
proc auto_mkindex {dir args} {
|
||||
global errorCode errorInfo
|
||||
set oldDir [pwd]
|
||||
cd $dir
|
||||
set dir [pwd]
|
||||
append index "# Tcl autoload index file, version 2.0\n"
|
||||
append index "# This file is generated by the \"auto_mkindex\" command\n"
|
||||
append index "# and sourced to set up indexing information for one or\n"
|
||||
append index "# more commands. Typically each line is a command that\n"
|
||||
append index "# sets an element in the auto_index array, where the\n"
|
||||
append index "# element name is the name of a command and the value is\n"
|
||||
append index "# a script that loads the command.\n\n"
|
||||
if {$args == ""} {
|
||||
set args *.tcl
|
||||
}
|
||||
foreach file [eval glob $args] {
|
||||
set f ""
|
||||
set error [catch {
|
||||
set f [open $file]
|
||||
while {[gets $f line] >= 0} {
|
||||
if [regexp {^proc[ ]+([^ ]*)} $line match procName] {
|
||||
append index "set [list auto_index($procName)]"
|
||||
append index " \[list source \[file join \$dir [list $file]\]\]\n"
|
||||
}
|
||||
}
|
||||
close $f
|
||||
} msg]
|
||||
if $error {
|
||||
set code $errorCode
|
||||
set info $errorInfo
|
||||
catch {close $f}
|
||||
cd $oldDir
|
||||
error $msg $info $code
|
||||
}
|
||||
}
|
||||
set f ""
|
||||
set error [catch {
|
||||
set f [open tclIndex w]
|
||||
puts $f $index nonewline
|
||||
close $f
|
||||
cd $oldDir
|
||||
} msg]
|
||||
if $error {
|
||||
set code $errorCode
|
||||
set info $errorInfo
|
||||
catch {close $f}
|
||||
cd $oldDir
|
||||
error $msg $info $code
|
||||
}
|
||||
}
|
||||
|
||||
# pkg_mkIndex --
|
||||
# This procedure creates a package index in a given directory. The
|
||||
# package index consists of a "pkgIndex.tcl" file whose contents are
|
||||
# a Tcl script that sets up package information with "package require"
|
||||
# commands. The commands describe all of the packages defined by the
|
||||
# files given as arguments.
|
||||
#
|
||||
# Arguments:
|
||||
# dir - Name of the directory in which to create the index.
|
||||
# args - Any number of additional arguments, each giving
|
||||
# a glob pattern that matches the names of one or
|
||||
# more shared libraries or Tcl script files in
|
||||
# dir.
|
||||
|
||||
proc pkg_mkIndex {dir args} {
|
||||
global errorCode errorInfo
|
||||
append index "# Tcl package index file, version 1.0\n"
|
||||
append index "# This file is generated by the \"pkg_mkIndex\" command\n"
|
||||
append index "# and sourced either when an application starts up or\n"
|
||||
append index "# by a \"package unknown\" script. It invokes the\n"
|
||||
append index "# \"package ifneeded\" command to set up package-related\n"
|
||||
append index "# information so that packages will be loaded automatically\n"
|
||||
append index "# in response to \"package require\" commands. When this\n"
|
||||
append index "# script is sourced, the variable \$dir must contain the\n"
|
||||
append index "# full path name of this file's directory.\n"
|
||||
set oldDir [pwd]
|
||||
cd $dir
|
||||
foreach file [eval glob $args] {
|
||||
# For each file, figure out what commands and packages it provides.
|
||||
# To do this, create a child interpreter, load the file into the
|
||||
# interpreter, and get a list of the new commands and packages
|
||||
# that are defined. Define an empty "package unknown" script so
|
||||
# that there are no recursive package inclusions.
|
||||
|
||||
set c [interp create]
|
||||
|
||||
# If Tk is loaded in the parent interpreter, load it into the
|
||||
# child also, in case the extension depends on it.
|
||||
|
||||
foreach pkg [info loaded] {
|
||||
if {[lindex $pkg 1] == "Tk"} {
|
||||
$c eval {set argv {-geometry +0+0}}
|
||||
load [lindex $pkg 0] Tk $c
|
||||
break
|
||||
}
|
||||
}
|
||||
$c eval [list set file $file]
|
||||
if [catch {
|
||||
$c eval {
|
||||
proc dummy args {}
|
||||
package unknown dummy
|
||||
set origCmds [info commands]
|
||||
set dir "" ;# in case file is pkgIndex.tcl
|
||||
set pkgs ""
|
||||
|
||||
# Try to load the file if it has the shared library extension,
|
||||
# otherwise source it. It's important not to try to load
|
||||
# files that aren't shared libraries, because on some systems
|
||||
# (like SunOS) the loader will abort the whole application
|
||||
# when it gets an error.
|
||||
|
||||
if {[string compare [file extension $file] \
|
||||
[info sharedlibextension]] == 0} {
|
||||
|
||||
# The "file join ." command below is necessary. Without
|
||||
# it, if the file name has no \'s and we're on UNIX, the
|
||||
# load command will invoke the LD_LIBRARY_PATH search
|
||||
# mechanism, which could cause the wrong file to be used.
|
||||
|
||||
load [file join . $file]
|
||||
set type load
|
||||
} else {
|
||||
source $file
|
||||
set type source
|
||||
}
|
||||
foreach i [info commands] {
|
||||
set cmds($i) 1
|
||||
}
|
||||
foreach i $origCmds {
|
||||
catch {unset cmds($i)}
|
||||
}
|
||||
foreach i [package names] {
|
||||
if {([string compare [package provide $i] ""] != 0)
|
||||
&& ([string compare $i Tcl] != 0)
|
||||
&& ([string compare $i Tk] != 0)} {
|
||||
lappend pkgs [list $i [package provide $i]]
|
||||
}
|
||||
}
|
||||
}
|
||||
} msg] {
|
||||
puts "error while loading or sourcing $file: $msg"
|
||||
}
|
||||
foreach pkg [$c eval set pkgs] {
|
||||
lappend files($pkg) [list $file [$c eval set type] \
|
||||
[lsort [$c eval array names cmds]]]
|
||||
}
|
||||
interp delete $c
|
||||
}
|
||||
foreach pkg [lsort [array names files]] {
|
||||
append index "\npackage ifneeded $pkg\
|
||||
\[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
|
||||
[list $files($pkg)]\]"
|
||||
}
|
||||
set f [open pkgIndex.tcl w]
|
||||
puts $f $index
|
||||
close $f
|
||||
cd $oldDir
|
||||
}
|
||||
|
||||
# tclPkgSetup --
|
||||
# This is a utility procedure use by pkgIndex.tcl files. It is invoked
|
||||
# as part of a "package ifneeded" script. It calls "package provide"
|
||||
# to indicate that a package is available, then sets entries in the
|
||||
# auto_index array so that the package's files will be auto-loaded when
|
||||
# the commands are used.
|
||||
#
|
||||
# Arguments:
|
||||
# dir - Directory containing all the files for this package.
|
||||
# pkg - Name of the package (no version number).
|
||||
# version - Version number for the package, such as 2.1.3.
|
||||
# files - List of files that constitute the package. Each
|
||||
# element is a sub-list with three elements. The first
|
||||
# is the name of a file relative to $dir, the second is
|
||||
# "load" or "source", indicating whether the file is a
|
||||
# loadable binary or a script to source, and the third
|
||||
# is a list of commands defined by this file.
|
||||
|
||||
proc tclPkgSetup {dir pkg version files} {
|
||||
global auto_index
|
||||
|
||||
package provide $pkg $version
|
||||
foreach fileInfo $files {
|
||||
set f [lindex $fileInfo 0]
|
||||
set type [lindex $fileInfo 1]
|
||||
foreach cmd [lindex $fileInfo 2] {
|
||||
if {$type == "load"} {
|
||||
set auto_index($cmd) [list load [file join $dir $f] $pkg]
|
||||
} else {
|
||||
set auto_index($cmd) [list source [file join $dir $f]]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# tclMacPkgSearch --
|
||||
# The procedure is used on the Macintosh to search a given directory for files
|
||||
# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the
|
||||
# interpreter to setup the package database.
|
||||
|
||||
proc tclMacPkgSearch {dir} {
|
||||
foreach x [glob -nocomplain [file join $dir *.shlb]] {
|
||||
if [file isfile $x] {
|
||||
set res [resource open $x]
|
||||
foreach y [resource list TEXT $res] {
|
||||
if {$y == "pkgIndex"} {source -rsrc pkgIndex}
|
||||
}
|
||||
resource close $res
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# tclPkgUnknown --
|
||||
# This procedure provides the default for the "package unknown" function.
|
||||
# It is invoked when a package that's needed can't be found. It scans
|
||||
# the auto_path directories and their immediate children looking for
|
||||
# pkgIndex.tcl files and sources any such files that are found to setup
|
||||
# the package database. (On the Macintosh we also search for pkgIndex
|
||||
# TEXT resources in all files.)
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name of desired package. Not used.
|
||||
# version - Version of desired package. Not used.
|
||||
# exact - Either "-exact" or omitted. Not used.
|
||||
|
||||
proc tclPkgUnknown {name version {exact {}}} {
|
||||
global auto_path tcl_platform env
|
||||
|
||||
if ![info exists auto_path] {
|
||||
return
|
||||
}
|
||||
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
|
||||
set dir [lindex $auto_path $i]
|
||||
set file [file join $dir pkgIndex.tcl]
|
||||
if [file readable $file] {
|
||||
source $file
|
||||
}
|
||||
foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
|
||||
if [file readable $file] {
|
||||
set dir [file dirname $file]
|
||||
source $file
|
||||
}
|
||||
}
|
||||
# On the Macintosh we also look in the resource fork
|
||||
# of shared libraries
|
||||
if {$tcl_platform(platform) == "macintosh"} {
|
||||
set dir [lindex $auto_path $i]
|
||||
tclMacPkgSearch $dir
|
||||
foreach x [glob -nocomplain [file join $dir *]] {
|
||||
if [file isdirectory $x] {
|
||||
set dir $x
|
||||
tclMacPkgSearch $dir
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
540
tcl/tcl8/obtcl8.tcl
Normal file
540
tcl/tcl8/obtcl8.tcl
Normal file
@@ -0,0 +1,540 @@
|
||||
#----------------------------------------------------------------------
|
||||
# -- obTcl --
|
||||
#
|
||||
# `obTcl' is a Tcl-only object- and Megawidget-extension.
|
||||
#
|
||||
# The system supports multiple inheritance, three new storage classes,
|
||||
# and fully transparent Tk-megawidgets.
|
||||
#
|
||||
# Efficiency is obtained through method-resolution caching.
|
||||
# obTcl provides real instance variables and class variables
|
||||
# (they may be arrays). Two types of class variables are provided:
|
||||
# definition-class scoped, and instance-class scoped.
|
||||
#
|
||||
# The mega-widget support allows creation of mega-widgets which handle
|
||||
# like ordinary Tk-widgets; i.e can be "packed", "deleted", "placed" etc,
|
||||
# intermixed with ordinary Tk-widgets.
|
||||
# The transparency of the mega-widget extension has been tested by
|
||||
# wrapping all normal Tk-widgets into objects and running the standard
|
||||
# "widget" demo provided with Tk4.0.
|
||||
#
|
||||
# To try out obTcl, just start `wish' (Tk4.0 or later) and do "source demo".
|
||||
# Alternatively run "demo" directly (requires that wish can be located
|
||||
# by demo).
|
||||
#
|
||||
# If you run `wish' interactively and source `obtcl', you will be able to
|
||||
# type "help" to access a simple help system.
|
||||
#
|
||||
# Pronunciation: `obTcl' sounds like "optical".
|
||||
#
|
||||
# See COPYRIGHT for copyright information.
|
||||
#
|
||||
# Please direct comments, ideas, complaints, etc. to:
|
||||
#
|
||||
# patrik@dynas.se
|
||||
#
|
||||
# Patrik Floding
|
||||
# DynaSoft AB
|
||||
#
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
# For convenience you may either append the installation directory of
|
||||
# obTcl to your auto_path variable (the recommended method), or source
|
||||
# `obtcl.tcl' into your script. Either way everything should work.
|
||||
#
|
||||
|
||||
set OBTCL_LIBRARY [file dirname [info script]]
|
||||
if { [lsearch -exact $auto_path $OBTCL_LIBRARY] == -1 } {
|
||||
lappend auto_path $OBTCL_LIBRARY
|
||||
}
|
||||
|
||||
set obtcl_version "0.56"
|
||||
|
||||
crunch_skip begin
|
||||
cmt {
|
||||
Public procs:
|
||||
|
||||
- Std. features
|
||||
classvar
|
||||
iclassvar
|
||||
instvar
|
||||
class
|
||||
obtcl_mkindex
|
||||
next
|
||||
|
||||
- Subj. to changes
|
||||
instvar2global
|
||||
classvar_of_class
|
||||
instvar_of_class
|
||||
import
|
||||
renamed_instvar
|
||||
is_object
|
||||
is_class
|
||||
|
||||
Non public:
|
||||
|
||||
Old name New name (as of 0.54)
|
||||
-------- ----------------------
|
||||
new otNew
|
||||
instance otInstance
|
||||
freeObj otFreeObj
|
||||
classDestroy otClassDestroy
|
||||
getSelf otGetSelf
|
||||
mkMethod otMkMethod
|
||||
rmMethod otRmMethod
|
||||
delAllMethods otDelAllMethods
|
||||
objinfoVars otObjInfoVars
|
||||
objinfoObjects otObjInfoObjects
|
||||
classInfoBody otClassInfoBody
|
||||
classInfoArgs otClassInfoArgs
|
||||
classInfoMethods+Cached otClassInfoMethods+Cached
|
||||
classInfoMethods otClassInfoMethods
|
||||
classInfoSysMethods otClassInfoSysMethods
|
||||
classInfoCached otClassInfoCached
|
||||
inherit otInherit
|
||||
InvalidateCaches otInvalidateCaches
|
||||
chkCall otChkCall
|
||||
GetNextFunc otGetNextFunc
|
||||
GetFunc otGetFunc
|
||||
GetFuncErr otGetFuncErr
|
||||
GetFuncMissingClass otGetFuncMissingClass
|
||||
}
|
||||
crunch_skip end
|
||||
|
||||
proc instvar2global name {
|
||||
upvar 1 class class self self
|
||||
return _oIV_${class}V${self}V$name
|
||||
}
|
||||
|
||||
# Class variables of definition class
|
||||
if ![string compare [info commands classvar] ""] {
|
||||
proc classvar args {
|
||||
uplevel 1 "foreach _obTcl_i [list $args] {
|
||||
upvar #0 _oDCV_\${class}V\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
}
|
||||
|
||||
# Class variables of specified class
|
||||
proc classvar_of_class { class args } {
|
||||
uplevel 1 "foreach _obTcl_i [list $args] {
|
||||
upvar #0 _oDCV_${class}V\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
|
||||
# Class variables of instance class
|
||||
if ![string compare [info commands iclassvar] ""] {
|
||||
proc iclassvar args {
|
||||
uplevel 1 "foreach _obTcl_i [list $args] {
|
||||
upvar #0 _oICV_\${iclass}V\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
}
|
||||
|
||||
# Instance variables. Specific to instances.
|
||||
# Make instvar from `class' available
|
||||
# Use with caution! I might put these variables in a separate category
|
||||
# which must be "exported" vaiables (as opposed to "instvars").
|
||||
#
|
||||
proc instvar_of_class { class args } {
|
||||
uplevel 1 "foreach _obTcl_i [list $args] {
|
||||
upvar #0 _oIV_${class}V\${self}V\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
# Instance variables. Specific to instances.
|
||||
|
||||
if ![string compare [info commands instvar] ""] {
|
||||
proc instvar args {
|
||||
uplevel 1 "foreach _obTcl_i [list $args] {
|
||||
upvar #0 _oIV_\${class}V\${self}V\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
}
|
||||
|
||||
# Renamed Instance variable. Specific to instances.
|
||||
proc renamed_instvar { normal_name new_name } {
|
||||
uplevel 1 "upvar #0 _oIV_\${class}V\${self}V$normal_name $new_name"
|
||||
}
|
||||
|
||||
# Check if an object exists
|
||||
#
|
||||
proc is_object name {
|
||||
global _obTcl_Objects
|
||||
if [info exists _obTcl_Objects($name)] {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
# Check if a class exists
|
||||
#
|
||||
proc is_class name {
|
||||
global _obTcl_Classes
|
||||
if [info exists _obTcl_Classes($name)] {
|
||||
return 1
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# new Creates a new object. Creation involves creating a proc with
|
||||
# the name of the object, initializing some house-keeping data,
|
||||
# call `initialize' to set init any option-variables,
|
||||
# and finally calling the `init' method for the newly created object.
|
||||
#
|
||||
# 951024. Added rename of any existing command to facilitate wrapping
|
||||
# of existing widgets/commands. Only one-level wrapping is supported.
|
||||
|
||||
proc otNew { iclass obj args } {
|
||||
global _obTcl_Objclass _obTcl_Objects
|
||||
set _obTcl_Objclass($iclass,$obj) $obj
|
||||
|
||||
if ![info exists _obTcl_Objects($obj)] {
|
||||
catch {rename $obj ${obj}-cmd}
|
||||
}
|
||||
|
||||
set _obTcl_Objects($obj) 1
|
||||
otProc $iclass $obj
|
||||
|
||||
set self $obj
|
||||
eval {${iclass}VVinitialize}
|
||||
eval {${iclass}VVinit} $args
|
||||
}
|
||||
|
||||
if ![string compare [info commands otProc] ""] {
|
||||
proc otProc { iclass obj } {
|
||||
proc $obj { cmd args } "
|
||||
set self $obj
|
||||
set iclass $iclass
|
||||
|
||||
if \[catch {eval {${iclass}VV\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
|
||||
} else {
|
||||
return \$val
|
||||
}
|
||||
"
|
||||
}
|
||||
}
|
||||
|
||||
# otInstance
|
||||
# Exactly like new, but does not call the 'init' method.
|
||||
# Useful when creating a class-leader object. Class-leader
|
||||
# objects are used instead of class names when it is desirable
|
||||
# to avoid some hard-coded method ins the class proc.
|
||||
#
|
||||
proc otInstance { iclass obj args } {
|
||||
global _obTcl_Objclass _obTcl_Objects
|
||||
set _obTcl_Objclass($iclass,$obj) $obj
|
||||
|
||||
if ![info exists _obTcl_Objects($obj)] {
|
||||
catch {rename $obj ${obj}-cmd}
|
||||
}
|
||||
|
||||
set _obTcl_Objects($obj) 1
|
||||
proc $obj { cmd args } "
|
||||
set self $obj
|
||||
set iclass $iclass
|
||||
|
||||
if \[catch {eval {${iclass}VV\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
|
||||
} else {
|
||||
return \$val
|
||||
}
|
||||
"
|
||||
set self $obj
|
||||
eval {${iclass}VVinitialize}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# otFreeObj
|
||||
# Unset all instance variables.
|
||||
#
|
||||
proc otFreeObj obj {
|
||||
global _obTcl_Objclass _obTcl_Objects
|
||||
otGetSelf
|
||||
catch {uplevel #0 "eval unset _obTcl_Objclass($iclass,$obj) \
|
||||
_obTcl_Objects($obj) \
|
||||
\[info vars _oIV_*V${self}V*\]"}
|
||||
catch {rename $obj {}}
|
||||
}
|
||||
|
||||
setIfNew _obTcl_Classes() ""
|
||||
setIfNew _obTcl_NoClasses 0
|
||||
|
||||
# This new class proc allows overriding of the 'new' method.
|
||||
# The usage of `new' in the resulting class object is about 10% slower
|
||||
# than before though..
|
||||
#
|
||||
proc class class {
|
||||
global _obTcl_NoClasses _obTcl_Classes _obTcl_Inherits
|
||||
|
||||
if [info exists _obTcl_Classes($class)] {
|
||||
set self $class
|
||||
otClassDestroy $class
|
||||
}
|
||||
if [string match *V* $class] {
|
||||
puts stderr "classV Fatal ErrorV"
|
||||
puts stderr " class name `$class'\
|
||||
contains reserved character `V'"
|
||||
return
|
||||
}
|
||||
incr _obTcl_NoClasses 1
|
||||
set _obTcl_Classes($class) 1
|
||||
|
||||
set iclass $class; set obj $class;
|
||||
|
||||
proc $class { cmd args } "
|
||||
set self $obj
|
||||
set iclass $iclass
|
||||
|
||||
switch -glob \$cmd {
|
||||
.* { eval {${class}VVnew \$cmd} \$args }
|
||||
new { eval {${class}VVnew} \$args }
|
||||
method { eval {otMkMethod N $class} \$args}
|
||||
inherit { eval {otInherit $class} \$args}
|
||||
destroy { eval {otClassDestroy $class} \$args }
|
||||
init { return -code error \
|
||||
-errorinfo \"$obj: ErrorV classes may not be init'ed!\" \
|
||||
\"$obj: ErrorV classes may not be init'ed!\"
|
||||
}
|
||||
default {
|
||||
if \[catch {eval {${iclass}VV\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
|
||||
} else {
|
||||
return \$val
|
||||
}
|
||||
}
|
||||
}
|
||||
"
|
||||
|
||||
if [string compare "Base" $class] {
|
||||
$class inherit "Base"
|
||||
} else {
|
||||
set _obTcl_Inherits($class) {}
|
||||
}
|
||||
return $class
|
||||
}
|
||||
|
||||
proc otClassDestroy class {
|
||||
global _obTcl_NoClasses _obTcl_Classes ;# _obTcl_CacheStop
|
||||
otGetSelf
|
||||
|
||||
if ![info exists _obTcl_Classes($class)] { return }
|
||||
otInvalidateCaches 0 $class [otClassInfoMethods $class]
|
||||
otDelAllMethods $class
|
||||
rename $class {}
|
||||
incr _obTcl_NoClasses -1
|
||||
unset _obTcl_Classes($class)
|
||||
|
||||
uplevel #0 "
|
||||
foreach _iii \[info vars _oICV_${class}V*\] {
|
||||
unset \$_iii
|
||||
}
|
||||
foreach _iii \[info vars _oDCV_${class}V*\] {
|
||||
unset \$_iii
|
||||
}
|
||||
catch {unset _iii}
|
||||
"
|
||||
otFreeObj $class
|
||||
}
|
||||
|
||||
# otGetSelf -
|
||||
# Bring caller's ID into scope. For various reasons
|
||||
# an "inlined" (copied) version is used in some places. Theses places
|
||||
# can be located by searching for the word 'otGetSelf', which should occur
|
||||
# in a comment near the "inlining".
|
||||
#
|
||||
|
||||
if ![string compare [info commands otGetSelf] ""] {
|
||||
proc otGetSelf {} {
|
||||
uplevel 1 {upvar 1 self self iclass iclass Umethod method}
|
||||
}
|
||||
}
|
||||
|
||||
proc otMkMethod { mode class name params body } {
|
||||
otInvalidateCaches 0 $class $name
|
||||
|
||||
if [string compare "unknown" "$name"] {
|
||||
set method "set method $name"
|
||||
} else {
|
||||
set method ""
|
||||
}
|
||||
proc ${class}VV$name $params \
|
||||
"otGetSelf
|
||||
set class $class
|
||||
$method
|
||||
$body"
|
||||
if ![string compare "S" $mode] {
|
||||
global _obTcl_SysMethod
|
||||
set _obTcl_SysMethod(${class}VV$name) 1
|
||||
}
|
||||
}
|
||||
|
||||
proc otRmMethod { class name } {
|
||||
global _obTcl_SysMethod
|
||||
|
||||
if [string compare "unknown" "$name"] {
|
||||
otInvalidateCaches 0 $class $name
|
||||
} else {
|
||||
otInvalidateCaches 0 $class *
|
||||
}
|
||||
rename ${class}VV$name {}
|
||||
catch {unset _obTcl_SysMethod(${class}VV$name)}
|
||||
}
|
||||
|
||||
proc otDelAllMethods class {
|
||||
global _obTcl_Cached
|
||||
foreach i [info procs ${class}VV*] {
|
||||
if [info exists _obTcl_SysMethod($i)] {
|
||||
continue
|
||||
}
|
||||
if [info exists _obTcl_Cached($i)] {
|
||||
unset _obTcl_Cached($i)
|
||||
}
|
||||
rename $i {}
|
||||
}
|
||||
}
|
||||
proc otObjInfoVars { glob base { match "" } } {
|
||||
if ![string compare "" $match] { set match * }
|
||||
set l [info globals ${glob}$match]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${base}(.*)" $i {\1} tmp
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otObjInfoObjects class {
|
||||
global _obTcl_Objclass
|
||||
set l [array names _obTcl_Objclass $class,*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class},(.*)" $i {\1} tmp
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otClassInfoBody { class method } {
|
||||
global _obTcl_Objclass _obTcl_Cached
|
||||
if [info exists _obTcl_Cached(${class}VV$method)] { return }
|
||||
if [catch {set b [info body ${class}VV$method]} ret] {
|
||||
return -code error \
|
||||
-errorinfo "info bodyV Method '$method' not defined in class $class" \
|
||||
"info bodyV Method '$method' not defined in class $class"
|
||||
} else {
|
||||
return $b
|
||||
}
|
||||
}
|
||||
proc otClassInfoArgs { class method } {
|
||||
global _obTcl_Objclass _obTcl_Cached
|
||||
if [info exists _obTcl_Cached(${class}VV$method)] { return }
|
||||
if [catch {set b [info args ${class}VV$method]} ret] {
|
||||
return -code error \
|
||||
-errorinfo "info argsV Method '$method' not defined in class $class" \
|
||||
"info argsV Method '$method' not defined in class $class"
|
||||
} else {
|
||||
return $b
|
||||
}
|
||||
}
|
||||
proc otClassInfoMethods+Cached class {
|
||||
global _obTcl_Objclass _obTcl_SysMethod
|
||||
set l [info procs ${class}VV*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class}VV(.*)" $i {\1} tmp
|
||||
if [info exists _obTcl_SysMethod($i)] { continue }
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otClassInfoMethods class {
|
||||
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
|
||||
set l [info procs ${class}VV*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
if [info exists _obTcl_Cached($i)] { continue }
|
||||
if [info exists _obTcl_SysMethod($i)] { continue }
|
||||
regsub "${class}VV(.*)" $i {\1} tmp
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otClassInfoSysMethods class {
|
||||
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
|
||||
set l [info procs ${class}VV*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
if [info exists _obTcl_Cached($i)] { continue }
|
||||
if ![info exists _obTcl_SysMethod($i)] { continue }
|
||||
regsub "${class}VV(.*)" $i {\1} tmp
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otClassInfoCached class {
|
||||
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
|
||||
if ![array exists _obTcl_Cached] {
|
||||
return
|
||||
}
|
||||
set l [array names _obTcl_Cached ${class}VV*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class}VV(.*)" $i {\1} tmp
|
||||
if [info exists _obTcl_SysMethod($i)] { continue }
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
|
||||
# obtcl_mkindex:
|
||||
# Altered version of tcl7.4's auto_mkindex.
|
||||
# This version also indexes class definitions.
|
||||
#
|
||||
# Original comment:
|
||||
# Regenerate a tclIndex file from Tcl source files. Takes as argument
|
||||
# the name of the directory in which the tclIndex file is to be placed,
|
||||
# floowed by any number of glob patterns to use in that directory to
|
||||
# locate all of the relevant files.
|
||||
|
||||
proc obtcl_mkindex {dir args} {
|
||||
global errorCode errorInfo
|
||||
set oldDir [pwd]
|
||||
cd $dir
|
||||
set dir [pwd]
|
||||
append index "# Tcl autoload index file, version 2.0\n"
|
||||
append index "# This file is generated by the \"obtcl_mkindex\" command\n"
|
||||
append index "# and sourced to set up indexing information for one or\n"
|
||||
append index "# more commands/classes. Typically each line is a command/class that\n"
|
||||
append index "# sets an element in the auto_index array, where the\n"
|
||||
append index "# element name is the name of a command/class and the value is\n"
|
||||
append index "# a script that loads the command/class.\n\n"
|
||||
foreach file [eval glob $args] {
|
||||
set f ""
|
||||
set error [catch {
|
||||
set f [open $file]
|
||||
while {[gets $f line] >= 0} {
|
||||
if [regexp {^(proc|class)[ ]+([^ ]*)} $line match dummy entityName] {
|
||||
append index "set [list auto_index($entityName)]"
|
||||
append index " \"source \$dir/$file\"\n"
|
||||
}
|
||||
}
|
||||
close $f
|
||||
} msg]
|
||||
if $error {
|
||||
set code $errorCode
|
||||
set info $errorInfo
|
||||
catch {close $f}
|
||||
cd $oldDir
|
||||
error $msg $info $code
|
||||
}
|
||||
}
|
||||
set f [open tclIndex w]
|
||||
puts $f $index nonewline
|
||||
close $f
|
||||
cd $oldDir
|
||||
}
|
||||
|
||||
112
tcl/tcl8/test.tst
Normal file
112
tcl/tcl8/test.tst
Normal file
@@ -0,0 +1,112 @@
|
||||
# test.tst
|
||||
# I avoided extension tcl so it won't show up in the tclIndex.
|
||||
#
|
||||
# Embryo to the real test-suite.
|
||||
|
||||
class I
|
||||
I method init {} {
|
||||
instvar Level1
|
||||
puts "I init"
|
||||
next
|
||||
set Level1 0
|
||||
}
|
||||
I method Level1 { n } {
|
||||
instvar Level1
|
||||
incr Level1 $n
|
||||
}
|
||||
|
||||
class J
|
||||
J method init {} {
|
||||
instvar Level2
|
||||
puts "J init"
|
||||
next
|
||||
set Level2 0
|
||||
}
|
||||
J method Level2 { n } {
|
||||
instvar Level2
|
||||
incr Level2 $n
|
||||
}
|
||||
|
||||
class W
|
||||
W inherit I J
|
||||
|
||||
W method init {} {
|
||||
instvar Cnt
|
||||
next
|
||||
set Cnt 0
|
||||
}
|
||||
W method add { n } {
|
||||
instvar Cnt
|
||||
incr Cnt $n
|
||||
}
|
||||
W new tst
|
||||
tst Level1 4711
|
||||
tst Level2 4711
|
||||
|
||||
# Now redefine class and see what happens
|
||||
class W
|
||||
|
||||
puts -nonewline stderr "Testing: Redefining class removes methods"
|
||||
set tmp [W info methods]
|
||||
if { "$tmp" != "" } {
|
||||
puts stderr ""
|
||||
puts stderr "Error: Redefining class does not remove methods"
|
||||
puts stderr " `W info methods' gave: $tmp"
|
||||
puts stderr " Should have been empty"
|
||||
} else {
|
||||
puts stderr ": OK"
|
||||
}
|
||||
puts -nonewline stderr "Testing: Redefining class removes cached methods"
|
||||
set tmp [W info cached]
|
||||
if { "$tmp" != "info" } {
|
||||
puts stderr ""
|
||||
puts stderr "Error: Redefining class does not flush cache"
|
||||
puts stderr " `W info cached' gave: $tmp"
|
||||
puts stderr " Should have been: info"
|
||||
} else {
|
||||
puts stderr ": OK"
|
||||
}
|
||||
|
||||
|
||||
W inherit I
|
||||
tst Level1 1
|
||||
W inherit I
|
||||
|
||||
puts -nonewline stderr "Testing: Redefining inheritance removes cached methods"
|
||||
set tmp [W info cached]
|
||||
if { "$tmp" != "info" } {
|
||||
puts stderr ""
|
||||
puts stderr "Error: Redefining inheritance does not flush cache"
|
||||
puts stderr " `W info cached' gave: $tmp"
|
||||
puts stderr " Should have been: info"
|
||||
} else {
|
||||
puts stderr ": OK"
|
||||
}
|
||||
|
||||
|
||||
puts -nonewline stderr "Testing: Using inherited proc creates cache-proc"
|
||||
tst Level1 1
|
||||
set tmp [W info cached]
|
||||
if { "$tmp" != "Level1 info" } {
|
||||
puts stderr ""
|
||||
puts stderr "Error: `W info cached' gave '$tmp'"
|
||||
puts stderr " Should have been 'Level1 info'"
|
||||
} else {
|
||||
puts stderr ": OK"
|
||||
}
|
||||
|
||||
|
||||
class I
|
||||
puts -nonewline stderr "Testing: Redefining inherited class removes cached methods"
|
||||
set tmp [W info cached]
|
||||
if { "$tmp" != "info" } {
|
||||
puts stderr ""
|
||||
puts stderr "Error: `W info cached' gave '$tmp'"
|
||||
puts stderr " Should have been 'info'"
|
||||
} else {
|
||||
puts stderr ": OK"
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
771
tcl/tcl8/topsicom.tcl
Normal file
771
tcl/tcl8/topsicom.tcl
Normal file
@@ -0,0 +1,771 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# Scan command implementation for TOPSI
|
||||
# Test version, Mark Koennecke, February 1997
|
||||
#----------------------------------------------------------------------------
|
||||
set home /data/koenneck/src/sics/tcl/tcl8
|
||||
set datapath /data/koenneck/src/sics/tmp
|
||||
set recoverfil /data/koenneck/src/sics/recover.dat
|
||||
|
||||
|
||||
source $home/utils.tcl
|
||||
source $home/obtcl8.tcl
|
||||
source $home/inherit8.tcl
|
||||
source $home/base8.tcl
|
||||
#-------------------------- some utility functions -------------------------
|
||||
proc MC { t n } {
|
||||
set string $t
|
||||
for { set i 1 } { $i < $n } { incr i } {
|
||||
set string [format "%s%s" $string $t]
|
||||
}
|
||||
return $string
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc GetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
#-------------------------- String list for writing ------------------------
|
||||
class DataSet
|
||||
DataSet method init { } {
|
||||
instvar N
|
||||
instvar Data
|
||||
next
|
||||
set Data(0) " Bla"
|
||||
set N 0
|
||||
}
|
||||
|
||||
DataSet method add { text } {
|
||||
instvar N
|
||||
instvar Data
|
||||
set Data($N) $text
|
||||
incr N
|
||||
}
|
||||
|
||||
DataSet method ins { text i } {
|
||||
instvar Data
|
||||
instvar N
|
||||
if { $i >= $N } {
|
||||
set N [expr $i + 1]
|
||||
} else {
|
||||
unset Data($i)
|
||||
}
|
||||
set Data($i) $text
|
||||
}
|
||||
DataSet method put { file } {
|
||||
instvar Data
|
||||
instvar N
|
||||
|
||||
for { set i 0 } { $i < $N } { incr i } {
|
||||
puts $file $Data($i)
|
||||
}
|
||||
}
|
||||
|
||||
DataSet method clear { } {
|
||||
instvar Data
|
||||
instvar N
|
||||
unset Data
|
||||
set Data(0) "Bla"
|
||||
set N 0
|
||||
}
|
||||
DataSet method GetN { } {
|
||||
instvar N
|
||||
return $N
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
# scan class initialization
|
||||
class ScanCommand
|
||||
|
||||
ScanCommand method init { counter } {
|
||||
instvar ScanData
|
||||
instvar [DataSet new Data]
|
||||
instvar Active
|
||||
instvar Recover
|
||||
next
|
||||
set ScanData(Mode) Timer
|
||||
set ScanData(NP) 1
|
||||
set ScanData(counter) $counter
|
||||
set ScanData(NoVar) 0
|
||||
set ScanData(Preset) 10.
|
||||
set ScanData(File) Default.dat
|
||||
set ScanData(Counts) " "
|
||||
set ScanData(cinterest) " "
|
||||
set ScanData(pinterest) " "
|
||||
set Active 0
|
||||
set Recover 0
|
||||
}
|
||||
#-------------add scan variables---------------------------------------------
|
||||
ScanCommand method var { name start step } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
instvar Active
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
# check parameters
|
||||
set t [SICSType $name]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is not drivable" $name] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
# install the variable
|
||||
set i $ScanData(NoVar)
|
||||
set ScanData(NoVar) [incr ScanData(NoVar)]
|
||||
set ScanVar($i,Var) $name
|
||||
set ScanVar($i,Start) $start
|
||||
set ScanVar($i,Step) $step
|
||||
set ScanVar($i,Value) " "
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
#---------------------- getvars ------------------------------------------
|
||||
ScanCommand method getvars {} {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
set list ""
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
|
||||
lappend list $ScanVar($i,Var)
|
||||
}
|
||||
return [format "scan.Vars = %s -END-" $list]
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
ScanCommand method xaxis {} {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
if { $ScanData(NoVar) <= 0} {
|
||||
#---- default Answer
|
||||
set t [format "%s.xaxis = %f %f" $self 0 1]
|
||||
} else {
|
||||
set t [format "%s.xaxis = %f %f" $self $ScanVar(0,Start) \
|
||||
$ScanVar(0,Step)]
|
||||
}
|
||||
ClientPut $t
|
||||
}
|
||||
#--------------------- modvar --------------------------------------------
|
||||
ScanCommand method modvar {name start step } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
|
||||
if { [string compare $name $ScanVar($i,Var)] == 0} {
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
#-------- do it
|
||||
set ScanVar($i,Start) $start
|
||||
set ScanVar($i,Step) $step
|
||||
return OK
|
||||
}
|
||||
}
|
||||
error [format "Scan Variable %s NOT found" $name]
|
||||
}
|
||||
#----------------- interests ----------------------------------------------
|
||||
ScanCommand method cinterest {} {
|
||||
instvar ScanData
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend ScanData(cinterest) $nam
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method pinterest {} {
|
||||
instvar ScanData
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend ScanData(pinterest) $nam
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method SendInterest { type text } {
|
||||
instvar ScanData
|
||||
#------ check list first
|
||||
set l1 $ScanData($type)
|
||||
set l2 ""
|
||||
foreach e $l1 {
|
||||
set b [string trim $e]
|
||||
set g [string trim $b "{}"]
|
||||
set ret [SICSType $g]
|
||||
if { [string first COM $ret] >= 0 } {
|
||||
lappend l2 $e
|
||||
}
|
||||
}
|
||||
#-------- update scan data and write
|
||||
set ScanData($type) $l2
|
||||
foreach e $l2 {
|
||||
set b [string trim $e]
|
||||
$b put $text
|
||||
}
|
||||
}
|
||||
#---------------- Change Mode ----------------------------------------------
|
||||
ScanCommand method Mode { {NewVal NULL } } {
|
||||
instvar ScanData
|
||||
instvar Active
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%.Mode = %s" $self $ScanData(Mode)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
if { ([string compare $NewVal "Timer"] == 0) || \
|
||||
([string compare $NewVal Monitor] ==0) } {
|
||||
set ScanData(Mode) $NewVal
|
||||
ClientPut OK
|
||||
} else {
|
||||
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
|
||||
}
|
||||
}
|
||||
}
|
||||
#----------------------------- NP -------------------------------------------
|
||||
ScanCommand method NP { { NewVal NULL } } {
|
||||
instvar ScanData
|
||||
instvar Active
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.NP = %d" $self $ScanData(NP)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set ScanData(NP) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
#------------------------------ Preset ------------------------------------
|
||||
ScanCommand method Preset { {NewVal NULL} } {
|
||||
instvar ScanData
|
||||
instvar Active
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Preset = %f" $self $ScanData(Preset)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set ScanData(Preset) $NewVal
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0} {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
#------------------------------ File ------------------------------------
|
||||
ScanCommand method File { {NewVal NULL} } {
|
||||
instvar ScanData
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.File = %s" $self $ScanData(File)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
set ScanData(File) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
#--------------------------- Count ---------------------------------------
|
||||
# These and the commands below are for use in recovery only
|
||||
ScanCommand method RecoCount { val } {
|
||||
instvar Recover
|
||||
instvar ScanData
|
||||
if { ! $Recover } {
|
||||
ClientPut \
|
||||
"ERROR: This command may only be used in Recovery Operations" \
|
||||
error
|
||||
return
|
||||
}
|
||||
set ScanData(Counts) $val
|
||||
}
|
||||
#--------------------------- monitor -------------------------------------
|
||||
ScanCommand method RecoMonitor { val } {
|
||||
instvar Recover
|
||||
instvar ScanData
|
||||
if { ! $Recover } {
|
||||
ClientPut \
|
||||
"ERROR: This command may only be used in Recovery Operations" \
|
||||
error
|
||||
return
|
||||
}
|
||||
set ScanData(Monitor) $val
|
||||
}
|
||||
#--------------------------- var -------------------------------------
|
||||
ScanCommand method RecoVar { var val } {
|
||||
instvar Recover
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
if { ! $Recover } {
|
||||
ClientPut \
|
||||
"ERROR: This command may only be used in Recovery Operations" \
|
||||
error
|
||||
return
|
||||
}
|
||||
set ScanVar($var,Value) $val
|
||||
}
|
||||
#--------------------------- WriteRecover --------------------------------
|
||||
ScanCommand method WriteRecover { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
global recoverfil
|
||||
|
||||
set fd [open $recoverfil w]
|
||||
puts $fd [format "%s Preset %s " $self $ScanData(Preset)]
|
||||
puts $fd [format "%s Mode %s " $self $ScanData(Mode)]
|
||||
puts $fd [format "%s NP %s " $self $ScanData(NP)]
|
||||
puts $fd [format "%s File %s " $self $ScanData(File)]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
|
||||
puts $fd [format "%s var %s %s %s" $self $ScanVar($i,Var) \
|
||||
$ScanVar($i,Start) $ScanVar($i,Step)]
|
||||
puts $fd [format "%s RecoVar %d %s" $self $i [list $ScanVar($i,Value)]]
|
||||
}
|
||||
puts $fd [format "%s RecoCount %s" $self [list $ScanData(Counts)]]
|
||||
puts $fd [format "%s RecoMonitor %s" $self [list $ScanData(Monitor)]]
|
||||
close $fd
|
||||
}
|
||||
#-------------------------- list ------------------------------------------
|
||||
ScanCommand method list { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
ClientPut [format "%s.Preset = %f" $self $ScanData(Preset)]
|
||||
ClientPut [format "%s.Mode = %s" $self $ScanData(Mode)]
|
||||
ClientPut [format "%s.File = %s" $self $ScanData(File)]
|
||||
ClientPut [format "%s.NP = %d" $self $ScanData(NP)]
|
||||
ClientPut "ScanVariables:"
|
||||
for { set i 0 } {$i < $ScanData(NoVar) } { incr i } {
|
||||
ClientPut [format " %s %f %f" $ScanVar($i,Var) $ScanVar($i,Start) \
|
||||
$ScanVar($i,Step)]
|
||||
}
|
||||
}
|
||||
#--------------------------------- clear ---------------------------------
|
||||
ScanCommand method clear { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
instvar Data
|
||||
instvar Active
|
||||
# check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: cannot clear running scan" error
|
||||
return
|
||||
}
|
||||
|
||||
set ScanData(NP) 0
|
||||
set ScanData(NoVar) 0
|
||||
set ScanData(Counts) " "
|
||||
set ScanData(Monitor) " "
|
||||
Data clear
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
#--------------------------- Store Initial data -----------------------------
|
||||
ScanCommand method SaveHeader { } {
|
||||
instvar Data
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
Data clear
|
||||
# administrative header
|
||||
Data add [format "%s TOPSI Data File %s" [MC * 30] \
|
||||
[MC * 30]]
|
||||
Data add [Title]
|
||||
Data add [User]
|
||||
Data add [format "File created: %s" [sicstime]]
|
||||
Data add [MC * 75]
|
||||
Data add [format " %s Setting %s " [MC * 30] [MC * 30]]
|
||||
# settings of instrument variables
|
||||
Data add [format "%s Monochromator %s" [MC - 30] [MC - 30]]
|
||||
Data add [lambda]
|
||||
Data add [MTL position]
|
||||
Data add [MTU position]
|
||||
Data add [MGU position]
|
||||
# diaphragm should go here
|
||||
# sample info
|
||||
Data add [format "%s Sample %s" [MC - 30] [MC - 30]]
|
||||
Data add [STL position]
|
||||
Data add [STU position]
|
||||
Data add [SGL position]
|
||||
Data add [SGU position]
|
||||
Data add [MC * 75]
|
||||
# counter info
|
||||
Data add [format "CountMode = %s" $ScanData(Mode)]
|
||||
Data add [format "Count Preset = %s" $ScanData(Preset)]
|
||||
Data add [MC * 75]
|
||||
Data add [format "%s DATA %s" [MC * 30] [MC * 30]]
|
||||
set val "Variables scanned: "
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append val " " $ScanVar($i,Var)
|
||||
}
|
||||
Data add "$val"
|
||||
append t [LeftAlign NP 5]
|
||||
append t [LeftAlign Counts 12]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append t [LeftAlign $ScanVar($i,Var) 10]
|
||||
}
|
||||
Data add $t
|
||||
set ScanData(Ptr) [Data GetN]
|
||||
}
|
||||
#-----------------------------------------------------------------------------
|
||||
ScanCommand method ConfigureDevices { } {
|
||||
instvar ScanData
|
||||
$ScanData(counter) SetMode $ScanData(Mode)
|
||||
$ScanData(counter) SetPreset $ScanData(Preset)
|
||||
}
|
||||
#----------------------------------------------------------------------------
|
||||
ScanCommand method StoreScanPoint { } {
|
||||
instvar ScanData
|
||||
instvar Data
|
||||
instvar ScanVar
|
||||
lappend ScanData(Counts) [GetNum [$ScanData(counter) GetCounts]]
|
||||
lappend ScanData(Monitor) [GetNum [$ScanData(counter) GetMonitor 1]]
|
||||
#------------ get Scan Var Values
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
|
||||
lappend ScanVar($i,Value) [GetNum [$ScanVar($i,Var) position]]
|
||||
}
|
||||
set iFile $ScanData(Ptr)
|
||||
#------------ write it
|
||||
set length [llength $ScanData(Counts)]
|
||||
for { set i 0 } { $i < $length} { incr i} {
|
||||
set t " "
|
||||
append t [LeftAlign $i 5]
|
||||
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
|
||||
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii} {
|
||||
append t [LeftAlign [lindex $ScanVar($ii,Value) $i] 10]
|
||||
}
|
||||
Data ins $t $iFile
|
||||
incr iFile
|
||||
}
|
||||
set fd [open $ScanData(File) w]
|
||||
Data put $fd
|
||||
close $fd
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method GetCounts { } {
|
||||
instvar ScanData
|
||||
#------- get data available
|
||||
set length [llength $ScanData(Counts)]
|
||||
for { set i 0 } { $i < $length } { incr i} {
|
||||
lappend result [lindex $ScanData(Counts) $i]
|
||||
}
|
||||
#------ put zero in those which are not yet measured
|
||||
if { $length < $ScanData(NP) } {
|
||||
for { set i $length } { $i < $ScanData(NP) } { incr i } {
|
||||
lappend result 0
|
||||
}
|
||||
}
|
||||
return "scan.Counts= $result"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
ScanCommand method EndScan { } {
|
||||
instvar Data
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
Data add [format "%s End of Data %s" [MC * 30] [MC * 30]]
|
||||
set fd [open $ScanData(File) w]
|
||||
Data put $fd
|
||||
close $fd
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method EvalInt { } {
|
||||
set int [GetInt]
|
||||
ClientPut [format "Interrupt %s detected" $int]
|
||||
switch -exact $int {
|
||||
continue {
|
||||
return OK
|
||||
}
|
||||
abortop {
|
||||
SetInt continue
|
||||
return SKIP
|
||||
}
|
||||
abortscan {
|
||||
SetInt continue
|
||||
return ABORT
|
||||
}
|
||||
default {
|
||||
return ABORT
|
||||
}
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method DriveTo { iNP } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
set command "drive "
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
|
||||
set ScanVar($i,NewVal) [expr $ScanVar($i,Start) + $iNP * \
|
||||
$ScanVar($i,Step)]
|
||||
# append ScanVar($i,Value) " " $ScanVar($i,NewVal)
|
||||
append command " " $ScanVar($i,Var) " " $ScanVar($i,NewVal)
|
||||
}
|
||||
set ret [catch {eval $command } msg ]
|
||||
if { $ret != 0 } {
|
||||
ClientPut $msg error
|
||||
return [$self EvalInt]
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
ScanCommand method CheckScanBounds { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
for { set i 0} { $i < $ScanData(NP) } { incr i } {
|
||||
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii } {
|
||||
set NewVal [expr $ScanVar($ii,Start) + $i*$ScanVar($ii,Step)]
|
||||
set iRet [catch {SICSBounds $ScanVar($ii,Var) $NewVal} msg]
|
||||
if { $iRet != 0 } {
|
||||
ClientPut $msg error
|
||||
return 0
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method Count { } {
|
||||
instvar ScanData
|
||||
set command $ScanData(counter)
|
||||
append command " Count "
|
||||
append command $ScanData(Preset)
|
||||
set ret [catch {eval $command } msg ]
|
||||
if { $ret != 0 } {
|
||||
ClientPut $msg error
|
||||
return [$self EvalInt]
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc LeftAlign { text iField } {
|
||||
set item $text
|
||||
append item [MC " " $iField]
|
||||
return [string range $item 0 $iField]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method ScanStatusHeader { } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
append t [LeftAlign NP 5]
|
||||
append t [LeftAlign Counts 12]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append t [LeftAlign $ScanVar($i,Var) 10]
|
||||
}
|
||||
ClientPut $t status
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
ScanCommand method ProgressReport { i } {
|
||||
instvar ScanData
|
||||
instvar ScanVar
|
||||
$self ScanStatusHeader
|
||||
append t [LeftAlign $i 5]
|
||||
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
|
||||
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
|
||||
append t [LeftAlign $ScanVar($i,NewVal) 10]
|
||||
}
|
||||
ClientPut $t status
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
ScanCommand method MakeFile { } {
|
||||
global datapath
|
||||
instvar ScanData
|
||||
SicsDataNumber incr
|
||||
set num1 [SicsDataNumber]
|
||||
set num [GetNum $num1]
|
||||
set fil [ format "%s/topsi%4.4d%2.2d.dat" $datapath $num 97]
|
||||
set ScanData(File) $fil
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method run { } {
|
||||
instvar ScanData
|
||||
instvar Data
|
||||
instvar ScanVar
|
||||
instvar Active
|
||||
# start with error checking
|
||||
if { $ScanData(NP) < 1 } {
|
||||
ClientPut "ERROR: Insufficient Number of ScanPoints"
|
||||
return
|
||||
}
|
||||
if { $ScanData(NoVar) < 1 } {
|
||||
ClientPut "ERROR: No variables to scan given!"
|
||||
return
|
||||
}
|
||||
#------- check for activity
|
||||
if {$Active} {
|
||||
ClientPut "ERROR: Scan already in progress" error
|
||||
return
|
||||
}
|
||||
#------- check Bounds
|
||||
if { [$self CheckScanBounds] != 1 } {
|
||||
return
|
||||
}
|
||||
|
||||
# clean data space from relicts of previous scans
|
||||
Data clear
|
||||
set ScanData(Counts) " "
|
||||
set ScanData(Monitor) " "
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i } {
|
||||
set ScanVar($i,Value) " "
|
||||
}
|
||||
|
||||
# configure and save data header
|
||||
$self ConfigureDevices
|
||||
$self MakeFile
|
||||
$self SaveHeader
|
||||
ClientPut [format "Writing %s" $ScanData(File)]
|
||||
|
||||
|
||||
# the actual scan loop
|
||||
SetStatus Scanning
|
||||
$self SendInterest cinterest NewScan
|
||||
set Active 1
|
||||
for { set i 0 } { $i < $ScanData(NP) } { incr i } {
|
||||
#---- driving
|
||||
set ret [$self DriveTo $i]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted at drive"
|
||||
SetStatus Eager
|
||||
set Active 0
|
||||
error "Abort"
|
||||
}
|
||||
}
|
||||
#---- counting
|
||||
set ret [$self Count]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted at counting"
|
||||
SetStatus Eager
|
||||
set Active 0
|
||||
error "Abort"
|
||||
}
|
||||
}
|
||||
#--- save data
|
||||
$self StoreScanPoint
|
||||
$self WriteRecover
|
||||
#--- invoke interests
|
||||
$self SendInterest cinterest [$self GetCounts]
|
||||
#--- Status Report
|
||||
$self ProgressReport $i
|
||||
}
|
||||
#---- final processing
|
||||
$self EndScan
|
||||
ClientPut "OK"
|
||||
SetStatus Eager
|
||||
set Active 0
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method Recover { } {
|
||||
instvar ScanData
|
||||
instvar Data
|
||||
instvar ScanVar
|
||||
instvar Active
|
||||
instvar Recover
|
||||
global recoverfil
|
||||
|
||||
# ---- read Recover Information
|
||||
set Recover 1
|
||||
$self clear
|
||||
source $recoverfil
|
||||
|
||||
# configure and save data header
|
||||
$self ConfigureDevices
|
||||
$self SaveHeader
|
||||
|
||||
# Write scan start info
|
||||
$self ScanStatusHeader
|
||||
|
||||
# --- figure out where we are
|
||||
set Recover 0
|
||||
set pos [llength $ScanData(Counts)]
|
||||
|
||||
# ----------------------the actual scan loop
|
||||
set OldStat [status]
|
||||
SetStatus Scanning
|
||||
set Active 1
|
||||
for { set i $pos } { $i < $ScanData(NP) } { incr i } {
|
||||
#---- driving
|
||||
set ret [$self DriveTo $i]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted"
|
||||
SetStatus $OldStat
|
||||
set Active 0
|
||||
return
|
||||
}
|
||||
}
|
||||
#---- counting
|
||||
set ret [$self Count]
|
||||
switch -exact $ret {
|
||||
OK { }
|
||||
SKIP { continue }
|
||||
ABORT { ClientPut "\nERROR: Scan Aborted"
|
||||
SetStatus $OldStat
|
||||
set Active 0
|
||||
return
|
||||
}
|
||||
}
|
||||
#--- save data
|
||||
$self StoreScanPoint
|
||||
$self WriteRecover
|
||||
#--- Status Report
|
||||
$self ProgressReport $i
|
||||
}
|
||||
#---- final processing
|
||||
$self EndScan
|
||||
ClientPut "OK"
|
||||
SetStatus $OldStat
|
||||
set Active 0
|
||||
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# finally initialise the scan command
|
||||
ScanCommand new scan counter
|
||||
#---------------------------------------------------------------------------
|
||||
# a new user command which allows status clients to read the counts in a scan
|
||||
# This is just to circumvent the user protection on scan
|
||||
proc ScanCounts { } {
|
||||
set status [ catch {scan GetCounts} result]
|
||||
if { $status == 0 } {
|
||||
return $result
|
||||
} else {
|
||||
return "scan.Counts= 0"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# This is just another utilility function which helps in implementing the
|
||||
# status display client
|
||||
proc TextStatus { } {
|
||||
set text [status]
|
||||
return [format "Status = %s" $text]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# Dumps time in a useful format
|
||||
proc sftime {} {
|
||||
return [format "sicstime = %s" [sicstime]]
|
||||
}
|
||||
398
tcl/tcl8/utils.tcl
Normal file
398
tcl/tcl8/utils.tcl
Normal file
@@ -0,0 +1,398 @@
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Some generic utility functions
|
||||
#
|
||||
|
||||
proc cmt args {}
|
||||
proc Nop {} {}
|
||||
|
||||
proc setIfNew { var val } {
|
||||
global $var
|
||||
if ![info exists $var] {
|
||||
set $var $val
|
||||
}
|
||||
}
|
||||
|
||||
proc crunch_skip args {}
|
||||
|
||||
crunch_skip begin
|
||||
|
||||
cmt {
|
||||
proc o_push { v val } {
|
||||
upvar 1 $v l
|
||||
lappend l $val
|
||||
}
|
||||
proc o_pop v {
|
||||
upvar 1 $v l
|
||||
set tmp [lindex $l end]
|
||||
catch {set l [lreplace $l end end]}
|
||||
return $tmp
|
||||
}
|
||||
proc o_peek v {
|
||||
upvar 1 $v l
|
||||
return [lindex $l end]
|
||||
}
|
||||
}
|
||||
|
||||
crunch_skip end
|
||||
|
||||
proc lappendUniq { v val } {
|
||||
upvar $v var
|
||||
|
||||
if { [lsearch $var $val] != -1 } { return }
|
||||
lappend var $val
|
||||
}
|
||||
proc listMinus { a b } {
|
||||
set ret {}
|
||||
foreach i $a { set ArrA($i) 1 }
|
||||
foreach i $b { set ArrB($i) 1 }
|
||||
foreach i [array names ArrA] {
|
||||
if ![info exists ArrB($i)] {
|
||||
lappend ret $i
|
||||
}
|
||||
}
|
||||
return $ret
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# StrictMotif: Redefine look-and-feel to be more Motif like.
|
||||
# This routine disables scrollbar from being pushed in (sunken),
|
||||
# as well as sets the tk_strictMotif variable.
|
||||
|
||||
# `_otReferenceSBD' is only for string comparison with currently used routine.
|
||||
# DO NOT ALTER IN ANY WAY!
|
||||
#
|
||||
set _otReferenceSBD {
|
||||
global tkPriv
|
||||
set tkPriv(relief) [$w cget -activerelief]
|
||||
$w configure -activerelief sunken
|
||||
set element [$w identify $x $y]
|
||||
if {$element == "slider"} {
|
||||
tkScrollStartDrag $w $x $y
|
||||
} else {
|
||||
tkScrollSelect $w $element initial
|
||||
}
|
||||
}
|
||||
proc otTkScrollButtonDown {w x y} {
|
||||
global tkPriv
|
||||
set tkPriv(relief) [$w cget -activerelief]
|
||||
set element [$w identify $x $y]
|
||||
if [string compare "slider" $element] {
|
||||
$w configure -activerelief sunken
|
||||
tkScrollSelect $w $element initial
|
||||
} else {
|
||||
tkScrollStartDrag $w $x $y
|
||||
}
|
||||
}
|
||||
|
||||
proc StrictMotif {} {
|
||||
global tk_version tk_strictMotif _otReferenceSBD
|
||||
set tk_strictMotif 1
|
||||
if { $tk_version == 4.0 ||
|
||||
![string compare [info body tkScrollButtonDown] \
|
||||
[set _otReferenceSBD]] } {
|
||||
if [string compare "" [info procs otTkScrollButtonDown]] {
|
||||
rename tkScrollButtonDown {}
|
||||
rename otTkScrollButtonDown tkScrollButtonDown
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc dbputs s {}
|
||||
|
||||
# Dummy to allow crunched obtcl processing normal obTcl-scripts
|
||||
proc DOC { name rest } {}
|
||||
proc DOC_get_list {} {}
|
||||
|
||||
crunch_skip begin
|
||||
|
||||
setIfNew db_debug 0
|
||||
proc db_debug {} {
|
||||
global db_debug
|
||||
set db_debug [expr !$db_debug]
|
||||
}
|
||||
proc dbputs s {
|
||||
global db_debug
|
||||
if { $db_debug != 0 } {
|
||||
puts stderr $s
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# DOCS
|
||||
|
||||
setIfNew _uPriv_DOCS() ""
|
||||
|
||||
proc DOC_get_list {} {
|
||||
global _uPriv_DOCS
|
||||
return [array names _uPriv_DOCS]
|
||||
}
|
||||
|
||||
proc DOC { name rest } {
|
||||
global _uPriv_DOCS
|
||||
set _uPriv_DOCS($name) $rest
|
||||
}
|
||||
|
||||
proc PrDOCS {} {
|
||||
global _uPriv_DOCS
|
||||
set names [lsort [array names _uPriv_DOCS]]
|
||||
foreach i $names {
|
||||
puts "$_uPriv_DOCS($i)"
|
||||
puts "----------------------------------------------------------------------"
|
||||
}
|
||||
}
|
||||
proc GetDOCS {} {
|
||||
global _uPriv_DOCS
|
||||
set names [lsort [array names _uPriv_DOCS]]
|
||||
set all ""
|
||||
foreach i $names {
|
||||
append all "$_uPriv_DOCS($i)"
|
||||
append all "----------------------------------------------------------------------"
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc GetDOC name {
|
||||
global _uPriv_DOCS
|
||||
return $_uPriv_DOCS($name)
|
||||
}
|
||||
proc help args {
|
||||
global _uPriv_DOCS
|
||||
set names [lsort [array names _uPriv_DOCS "${args}*"]]
|
||||
|
||||
if { [llength $names] > 1 } {
|
||||
puts "Select one of: "
|
||||
set n 1
|
||||
foreach i $names {
|
||||
puts " ${n}) $i "
|
||||
incr n 1
|
||||
}
|
||||
puts -nonewline ">> "
|
||||
set answ [gets stdin]
|
||||
append tmp [lindex $names [expr $answ-1]]
|
||||
eval help $tmp
|
||||
}
|
||||
if { [llength $names] == 1 } {
|
||||
eval set tmp $names
|
||||
puts $_uPriv_DOCS($tmp)
|
||||
}
|
||||
if { [llength $names] < 1 } {
|
||||
puts "No help on: $args"
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
DOC "Tcl-debugger" {
|
||||
|
||||
NAME
|
||||
Tcldb - A Tcl debugger
|
||||
|
||||
SYNOPSIS
|
||||
bp ?ID?
|
||||
|
||||
DESCRIPTION
|
||||
A simple debugger for Tcl-script. Breakpoints are set by calling
|
||||
`bp' from your Tcl-code. Selecting where to break is done by
|
||||
string-matching.
|
||||
|
||||
USAGE
|
||||
Use by putting calls to `bp' in the Tcl-code. If `ID' is specified,
|
||||
it will be displayed when the breakpoint is reached.
|
||||
|
||||
Example of using two breakpoints with different IDs:
|
||||
|
||||
func say { a } {
|
||||
|
||||
bp say_A
|
||||
|
||||
puts "You said: $a!"
|
||||
|
||||
bp say_B
|
||||
}
|
||||
|
||||
Call `bpOff' to disable all breakpoints, `bpOn' to enable all,
|
||||
`bpOn <funcname>' to enable breakpoints in functions matching
|
||||
<funcname>, and finally `bpID <ID>' to enable breakpoints
|
||||
matching <ID>. Matching is done according to Tcl's `string match'
|
||||
function.
|
||||
|
||||
When in the break-point handler, type "?" for help.
|
||||
|
||||
ACKNOWLEDGEMENTS
|
||||
This simple debugger is based on Stephen Uhler's article
|
||||
"Debugging Tcl Scripts" from the Oct-95 issue of Linux Journal.
|
||||
}
|
||||
|
||||
proc bpGetHelp {} {
|
||||
puts stderr \
|
||||
"------------------------------- Tcldb help ------------------------------------
|
||||
|
||||
Set breakpoints by adding calls to `bp' in your Tcl-code. Example:
|
||||
|
||||
bp Func1 ;# bp followed by the identifier `Func1'
|
||||
|
||||
Commands available when in `bp':
|
||||
|
||||
+ Move down in call-stack
|
||||
- Move up in call stack
|
||||
. Show current proc name and params
|
||||
|
||||
v Show names of variables currently in scope
|
||||
V Show names and values of variables currently in scope
|
||||
l Show names of variables that are local (transient)
|
||||
L Show names and values of variables that are local (transient)
|
||||
g Show names of variables that are declared global
|
||||
G Show names and values of variables that are declared global
|
||||
t Show a call chain trace, terse mode
|
||||
T Show a call chain trace, verbose mode
|
||||
|
||||
b Show body of current proc
|
||||
c Continue execution
|
||||
h,? Print this help
|
||||
|
||||
You can also enter any Tcl command (even multi-line) and it will be
|
||||
executed in the currently selected stack frame.
|
||||
|
||||
Available at any time:
|
||||
|
||||
bpOff Turn off all breakpoints
|
||||
bpOn Turn on all breakpoints
|
||||
bpOn <match>
|
||||
Enable breakpoints in functions with names matching <match>
|
||||
bpID <match>
|
||||
Enable breakpoints whose ID matches <match>
|
||||
"
|
||||
}
|
||||
setIfNew _bp_ON 1
|
||||
setIfNew _bp_ID *
|
||||
|
||||
proc bpOn { {func 1} } { global _bp_ON _bp_ID; set _bp_ID *; set _bp_ON $func }
|
||||
proc bpID id { global _bp_ON _bp_ID; set _bp_ON 1; set _bp_ID $id }
|
||||
proc bpOff {} { global _bp_ON; set _bp_ON 0 }
|
||||
|
||||
proc bp args {
|
||||
global _bp_ON _bp_ID
|
||||
if { $_bp_ON == 0 } { return }
|
||||
set max [expr [info level] - 1]
|
||||
set current $max
|
||||
set fName [lindex [info level $current] 0]
|
||||
if { "$_bp_ON" == "1" || "$fName" == "$_bp_ON" || \
|
||||
("$_bp_ON" == "top" && $current == 0) || \
|
||||
[string match $_bp_ON $fName] } {
|
||||
if ![string match $_bp_ID $args] {
|
||||
return
|
||||
}
|
||||
} else {
|
||||
return
|
||||
}
|
||||
bpShow VERBOSE $current
|
||||
while {1} {
|
||||
if { "$args" != "" } { puts "bp: $args" }
|
||||
puts -nonewline stderr "#${current}:"
|
||||
gets stdin line
|
||||
while {![info complete $line]} {
|
||||
puts -nonewline "> "
|
||||
append line "\n[gets stdin]"
|
||||
}
|
||||
switch -- $line {
|
||||
"+" {if {$current < $max} {bpShow VERBOSE [incr current]}}
|
||||
"-" {if {$current > 0} {bpShow VERBOSE [incr current -1]}}
|
||||
"b" {bpBody $current}
|
||||
"c" {puts stderr "Continuing"; return}
|
||||
"v" {bpVisibleVars NAMES $current}
|
||||
"V" {bpVisibleVars VALUES $current}
|
||||
"l" {bpLocalVars NAMES $current}
|
||||
"L" {bpLocalVars VALUES $current}
|
||||
"g" {bpGlobalVars NAMES $current}
|
||||
"G" {bpGlobalVars VALUES $current}
|
||||
"t" {bpTraceCalls TERSE $current}
|
||||
"T" {bpTraceCalls VERBOSE $current}
|
||||
"." {bpShow VERBOSE $current}
|
||||
"h" -
|
||||
"?" {bpGetHelp}
|
||||
default {
|
||||
catch {uplevel #$current $line } result
|
||||
puts stderr $result
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc bpPrVar { level mode name } {
|
||||
upvar #$level $name var
|
||||
if { $mode == "NAMES" } {
|
||||
puts " $name"
|
||||
return
|
||||
}
|
||||
if { [array exists var] == 1 } {
|
||||
puts " Array ${name} :"
|
||||
foreach i [array names var] {
|
||||
puts " ${name}($i) = [set var($i)]"
|
||||
}
|
||||
} else {
|
||||
if {[info exists var] != 1 } {
|
||||
puts " $name : Declared but uninitialized"
|
||||
} else {
|
||||
puts " $name = $var"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc bpBody current {
|
||||
uplevel #$current {
|
||||
catch {puts [info body [lindex [info level [info level]] 0]]}
|
||||
}
|
||||
}
|
||||
proc bpVisibleVars { mode curr } {
|
||||
puts "#$curr visible vars:"
|
||||
foreach i [uplevel #$curr {lsort [info vars]}] {
|
||||
bpPrVar $curr $mode $i
|
||||
}
|
||||
}
|
||||
proc bpLocalVars { mode curr } {
|
||||
puts "#$curr local vars:"
|
||||
foreach i [uplevel #$curr {lsort [info locals]}] {
|
||||
bpPrVar $curr $mode $i
|
||||
}
|
||||
}
|
||||
proc bpGlobalVars { mode curr } {
|
||||
puts "#$curr global visible vars:"
|
||||
set Vis [uplevel #$curr {info vars}]
|
||||
set Loc [uplevel #$curr {info locals}]
|
||||
foreach i [lsort [listMinus $Vis $Loc]] {
|
||||
bpPrVar 0 $mode $i
|
||||
}
|
||||
|
||||
}
|
||||
proc bpTraceCalls { mode curr } {
|
||||
for {set i 1} {$i <= $curr} {incr i} {
|
||||
bpShow $mode $i
|
||||
}
|
||||
}
|
||||
proc bpShow { mode curr } {
|
||||
if { $curr > 0 } {
|
||||
set info [info level $curr]
|
||||
set proc [lindex $info 0]
|
||||
if {"$mode" == "TERSE"} {
|
||||
puts stderr "$curr: $proc [lrange $info 1 end]"
|
||||
return
|
||||
}
|
||||
puts stderr "$curr: Proc= $proc \
|
||||
{[info args $proc]}"
|
||||
set idx 0
|
||||
foreach arg [info args $proc] {
|
||||
if { "$arg" == "args" } {
|
||||
puts stderr "\t$arg = [lrange $info [incr idx] end]"
|
||||
break;
|
||||
} else {
|
||||
puts stderr "\t$arg = [lindex $info [incr idx]]"
|
||||
}
|
||||
}
|
||||
} else {
|
||||
puts stderr "Top level"
|
||||
}
|
||||
}
|
||||
|
||||
crunch_skip end
|
||||
|
||||
|
||||
Reference in New Issue
Block a user