1.) Modified macro system as to use only Sicsunknown for resolving unknown
Tcl commands. Removed the broken obTcl object system and replaced it by
the object.tcl system from sntl. Redid the scan command with this. The
end of this is that SICS is now independent of the tcl version and
works with tcl 8.0 thus giving a factor of up to 10 in script execution
speed.
2.) Added driving an angle through a translation table (object lin2ang)
This commit is contained in:
cvs
7
Makefile
7
Makefile
@ -11,9 +11,6 @@ BINTARGET=$(HOME)/bin/sics
|
||||
#FORTIFYOBJ = fortify.o strdup.o
|
||||
FORTIFYOBJ =
|
||||
|
||||
TCLOBJ=initcl.o
|
||||
#TCLOBJ=init8.o
|
||||
|
||||
#----- comment and uncomment according if a difrac version is required
|
||||
#DIFOBJ=
|
||||
#DIFIL=
|
||||
@ -28,7 +25,7 @@ SOBJ = network.o ifile.o conman.o SCinter.o splitter.o passwd.o \
|
||||
sicsexit.o costa.o task.o $(FORTIFYOBJ)\
|
||||
macro.o ofac.o obpar.o obdes.o drive.o status.o intserv.o \
|
||||
devexec.o mumo.o mumoconf.o selector.o selvar.o fupa.o lld.o \
|
||||
lld_blob.o buffer.o strrepl.o ruli.o $(TCLOBJ) \
|
||||
lld_blob.o buffer.o strrepl.o ruli.o lin2ang.o \
|
||||
script.o o2t.o alias.o napi.o nxdata.o stringdict.o sdynar.o\
|
||||
histmem.o histdriv.o histsim.o sinqhmdriv.o interface.o callback.o \
|
||||
event.o emon.o evcontroller.o evdriver.o simev.o perfmon.o \
|
||||
@ -55,7 +52,7 @@ CC=cc
|
||||
EXTRA=
|
||||
CFLAGS = -I$(HDFROOT)/include -Ihardsup -std1 -g -warnprotos -c
|
||||
#CFLAGS = -I$(HDFROOT)/include -DFORTIFY -Ihardsup -g -std1 -warnprotos -c
|
||||
LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -ltcl7.6 -lfor -lmfhdf -ldf \
|
||||
LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -ltcl8.0 -lfor -lmfhdf -ldf \
|
||||
$(HDFROOT)/lib/libjpeg.a -lz -lm -ll -lc
|
||||
|
||||
#------- for cygnus
|
||||
|
||||
791
base.tcl
791
base.tcl
@ -1,791 +0,0 @@
|
||||
crunch_skip begin
|
||||
DOC "class Base" {
|
||||
NAME
|
||||
Base - The basic class inherited by all obTcl objects
|
||||
|
||||
SYNOPSIS
|
||||
Base new <obj>
|
||||
- Creates an object of the simplest possible class.
|
||||
|
||||
DESCRIPTION
|
||||
All classes inherits the Base class automatically. The Base class
|
||||
provides methods that are essential for manipulating obTcl-objects,
|
||||
such as `info' and `destroy'.
|
||||
|
||||
METHODS
|
||||
Base provides the following generic methods to all objects:
|
||||
|
||||
new - EXPERIMENTAL! Arranges to create a new object of
|
||||
the class of the invoking object.
|
||||
|
||||
instance - EXPERIMENTAL! Arranges to create a new object of
|
||||
the class of the invoking object. This method
|
||||
differs from `new' by NOT automatically invoking
|
||||
the `init' method of the new object.
|
||||
One possible usage: Create a replacement for the
|
||||
normal class object -a replacement which has no
|
||||
hard-coded methods (this will need careful design
|
||||
though).
|
||||
|
||||
init - Does nothing. The init method is automatically
|
||||
invoked whenever an object is created with `new'.
|
||||
|
||||
destroy - Frees all instance variables of the object, and
|
||||
the object itself.
|
||||
|
||||
class - Returns the class of the object.
|
||||
|
||||
set name ?value?
|
||||
- Sets the instance variable `name' to value.
|
||||
If no value is specified, the current value is
|
||||
returned. Mainly used for debugging purposes.
|
||||
|
||||
info <cmd> - Returns information about the object. See INFO
|
||||
below.
|
||||
|
||||
eval <script> - Evaluates `script' in the context of the object.
|
||||
Useful for debugging purposes. Not meant to be
|
||||
used for other purposes (create a method instead).
|
||||
One useful trick (if you use the Tcl-debugger in
|
||||
this package) is to enter:
|
||||
obj eval bp
|
||||
to be able to examine `obj's view of the world
|
||||
(breakpoints must be enabled, of course).
|
||||
|
||||
unknown <method> <args>
|
||||
- Automatically invoked when unknown methods are
|
||||
invoked. the Base class defines this method to
|
||||
print an error message, but this can be overridden
|
||||
by derived classes.
|
||||
|
||||
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
|
||||
- Define an option handler.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
conf_verify <args>
|
||||
conf_init <args>
|
||||
- Set options. <args> are option-value pairs.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
configure <args>
|
||||
- Set options. <args> are option-value pairs.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
cget <opt> - Get option value.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
verify_unknown <args>
|
||||
init_unknown <args>
|
||||
configure_unknown <args>
|
||||
cget_unknown <opt>
|
||||
- These methods are automatically invoked when a requested
|
||||
option has not been defined.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
INFO
|
||||
The method `info' can be used to inspect an object. In the list below
|
||||
(I) means the command is only applicable to object instances, whereas
|
||||
(C) means that the command can be applied either to the class object, or
|
||||
to the object instance, if that is more convenient.
|
||||
Existing commands:
|
||||
|
||||
instvars - (I) Returns the names of all existing instance variables.
|
||||
iclassvars - (I) List instance class variables
|
||||
|
||||
classvars - (C) List class variables.
|
||||
objects - (C) List objects of this class.
|
||||
methods - (C) List methods defined in this class.
|
||||
sysmethods - (C) List system methods defined in this class.
|
||||
cached - (C) List cached methods for this class.
|
||||
body <method> - (C) List the body of a method.
|
||||
args <method> - (C) List formal parameters for a method.
|
||||
|
||||
options - (I) List the current option values in the format
|
||||
"option-value pairs".
|
||||
defaults - (C) List the current default values in the format
|
||||
"option-value pairs". These values are the initial
|
||||
values each new object will be given.
|
||||
|
||||
OPTION HANDLER
|
||||
The method `option' is used to define options. It should be used on
|
||||
the class-object, which serves as a repository for default values
|
||||
and for code sections to run to verify and make use of new default values.
|
||||
|
||||
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
|
||||
Define an option for this class.
|
||||
Defining an option results in an instance variable
|
||||
of the same name (with the leading '-' stripped)
|
||||
being defined. This variable will be initiated
|
||||
with the value <default>.
|
||||
|
||||
The sections `verify', `init' and `configure' can be defined.
|
||||
|
||||
`verify' is used to verify new parameters without affecting
|
||||
the object. It is typically called by an object's init method
|
||||
before all parts of the object have been created.
|
||||
|
||||
`init' is used for rare situations where some action should be taken
|
||||
just after the object has been fully created. I.e when setting
|
||||
the option variable via `verify' was not sufficient.
|
||||
|
||||
The `configure' section is invoked when the configure method is
|
||||
called to re-configure an object.
|
||||
|
||||
Example usage:
|
||||
|
||||
class Graph
|
||||
Graph inherit Widget
|
||||
|
||||
Graph option {-width} 300 verify {
|
||||
if { $width >= 600 } {
|
||||
error "width must be less than 600"
|
||||
}
|
||||
} configure {
|
||||
$self.grf configure -width $width
|
||||
}
|
||||
|
||||
Note 1: The `verify' section should never attempt
|
||||
to access structures in the object (i.e widgets), since
|
||||
it is supposed to be callable before they exist!
|
||||
Use the `configure' section to manipulate the object.
|
||||
|
||||
Note 2: Using "break" or "error" in the verify section results
|
||||
in the newly specified option value being rejected.
|
||||
|
||||
conf_verify <args>
|
||||
Invoke all "verify" sections for options-value pairs
|
||||
specified in <args>.
|
||||
conf_init <args>
|
||||
Invoke all "init" sections for options-value pairs
|
||||
specified in <args>.
|
||||
|
||||
Example usage:
|
||||
|
||||
Graph method init { args } {
|
||||
instvar width
|
||||
|
||||
# Set any option variables from $args
|
||||
#
|
||||
eval $self conf_verify $args ;# Set params
|
||||
|
||||
next -width $width ;# Get frame
|
||||
|
||||
CreateRestOfObject ;# Bogus
|
||||
|
||||
# Option handlers that wish to affect the
|
||||
# object during init may declare an "init"
|
||||
# section. Run any such sections now:
|
||||
#
|
||||
eval $self conf_init $args
|
||||
}
|
||||
|
||||
Graph .graph -width 400 ;# Set width initially
|
||||
|
||||
configure <args>
|
||||
Invoke all "configure" sections for options-value pairs
|
||||
specified in <args>.
|
||||
|
||||
Example usage:
|
||||
|
||||
# First create object
|
||||
#
|
||||
Graph .graph -width 300
|
||||
|
||||
# Use `configure' to configure the object
|
||||
#
|
||||
.graph configure -width 200
|
||||
|
||||
cget <opt>
|
||||
Returns the current value of option <opt>.
|
||||
Example usage:
|
||||
|
||||
.graph cget -width
|
||||
|
||||
<sect>_unknown <args>
|
||||
These methods are called when attempting to invoke sections
|
||||
for unknown options. In this way a class may define methods
|
||||
to catch usage of "configure", "cget", etc. for undefined
|
||||
options.
|
||||
Example:
|
||||
|
||||
Graph method configure_unknown { opt args } {
|
||||
eval {$self-cmd configure $opt} $args
|
||||
}
|
||||
|
||||
See the definitions of the Base and Widget classes for their
|
||||
usage of these methods.
|
||||
}
|
||||
crunch_skip end
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Define the Base class. This class provides introspection etc.
|
||||
#
|
||||
# It also provides "set", which gives access to object
|
||||
# internal variables, and 'eval' which lets you run arbitrary scripts in
|
||||
# the objects context. You may wish to remove those methods if you
|
||||
# want to disallow this.
|
||||
|
||||
class Base
|
||||
|
||||
Base method init args {}
|
||||
|
||||
Base method destroy args {
|
||||
otFreeObj $self
|
||||
}
|
||||
|
||||
Base method class args {
|
||||
return $iclass
|
||||
}
|
||||
|
||||
# Note: The `set' method takes on the class of the caller, so
|
||||
# instvars will use the callers scope.
|
||||
#
|
||||
Base method set args {
|
||||
set class $iclass
|
||||
# instvar [lindex $args 0]
|
||||
set var [lindex $args 0]
|
||||
regexp -- {^([^(]*)\(.*\)$} $var m var
|
||||
instvar $var
|
||||
return [eval set $args]
|
||||
}
|
||||
|
||||
Base method eval l {
|
||||
return [eval $l]
|
||||
}
|
||||
|
||||
Base method info { cmd args } {
|
||||
switch $cmd {
|
||||
"instvars" {return [eval {otObjInfoVars\
|
||||
_oIV_${iclass}:${self}: _oIV_${iclass}:${self}:} $args]}
|
||||
"iclassvars" {otObjInfoVars _oICV_${iclass}: _oICV_${iclass}: $args}
|
||||
"classvars" {otObjInfoVars _oDCV_${iclass}: _oDCV_${iclass}: $args}
|
||||
"objects" {otObjInfoObjects $iclass}
|
||||
"methods" {otClassInfoMethods $iclass}
|
||||
"sysmethods" {otClassInfoSysMethods $iclass}
|
||||
"cached" {otClassInfoCached $iclass}
|
||||
"body" {otClassInfoBody $iclass $args}
|
||||
"args" {otClassInfoArgs $iclass $args}
|
||||
|
||||
"options" {$iclass::collectOptions values ret
|
||||
return [array get ret] }
|
||||
"defaults" {$iclass::collectOptions defaults ret
|
||||
return [array get ret] }
|
||||
|
||||
default {
|
||||
return -code error \
|
||||
-errorinfo "Undefined command 'info $cmd'" \
|
||||
"Undefined command 'info $cmd'"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
Base method unknown args {
|
||||
return -code error \
|
||||
-errorinfo "Undefined method '$method' invoked" \
|
||||
"Undefined method '$method' invoked"
|
||||
}
|
||||
|
||||
#------- START EXPERIMENTAL
|
||||
|
||||
Base method new { obj args } {
|
||||
eval {otNew $iclass $obj} $args
|
||||
}
|
||||
|
||||
Base method instance { obj args } {
|
||||
eval {otInstance $iclass $obj} $args
|
||||
}
|
||||
|
||||
Base method sys_method args {
|
||||
eval {otMkMethod S $iclass} $args
|
||||
}
|
||||
|
||||
Base method method args {
|
||||
eval {otMkMethod N $iclass} $args
|
||||
}
|
||||
|
||||
Base method del_method args {
|
||||
eval {otRmMethod $iclass} $args
|
||||
}
|
||||
|
||||
Base method inherit args {
|
||||
eval {otInherit $iclass} $args
|
||||
}
|
||||
|
||||
# class AnonInst - inherit from this class to be able to generate
|
||||
# anonymous objects. Example:
|
||||
#
|
||||
# class Foo
|
||||
# Foo inherit AnonInst
|
||||
# set obj [Foo new]
|
||||
#
|
||||
# NOTE: EXPERIMENTAL!!!
|
||||
|
||||
class AnonInst
|
||||
AnonInst method anonPrefix p {
|
||||
iclassvar _prefix
|
||||
set _prefix $p
|
||||
}
|
||||
AnonInst method new {{obj {}} args} {
|
||||
iclassvar _count _prefix
|
||||
if ![info exists _count] {
|
||||
set _count 0
|
||||
}
|
||||
if ![info exists _prefix] {
|
||||
set _prefix "$iclass"
|
||||
}
|
||||
if ![string compare "" $obj] {
|
||||
set obj $_prefix[incr _count]
|
||||
}
|
||||
eval next {$obj} $args
|
||||
return $obj
|
||||
}
|
||||
#------- END EXPERIMENTAL
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Configure stuff
|
||||
#----------------------------------------------------------------------
|
||||
# The configuaration stuff is, for various reasons, probably the most
|
||||
# change-prone part of obTcl.
|
||||
#
|
||||
# After fiddling around with various methods for handling options,
|
||||
# this is what I came up with. It uses one method for each class and option,
|
||||
# plus one dispatch-method for each of "conf_init", "conf_verify", "configure"
|
||||
# and "cget" per class. Any extra sections in the `option' handler
|
||||
# results in another dispatch-method being created.
|
||||
# Attempts at handling undefined options are redirected to
|
||||
#
|
||||
# <section_name>_unknown
|
||||
#
|
||||
# Note:
|
||||
# Every new object is initialized by a call to `initialize'.
|
||||
# This is done in the proc "new", before `init' is called, to guarantee
|
||||
# that initial defaults are set before usage. `initialize' calls "next", so
|
||||
# all inherited classes are given a chance to set their initial defaults.
|
||||
#
|
||||
# Sections and their used (by convention):
|
||||
#
|
||||
# verify - Called at beginning of object initialization to verify
|
||||
# specified options.
|
||||
# init - Called at end of the class' `init' method.
|
||||
# Use for special configuration.
|
||||
# configure
|
||||
# - This section should use the new value to configure
|
||||
# the object.
|
||||
#
|
||||
|
||||
# MkSectMethod - Define a method which does:
|
||||
# For each option specified, call the handler for the specified section
|
||||
# and option. If this fails, call the <section>_unknown handler.
|
||||
# If this fails too, return an error.
|
||||
# Note that the normal call of the method `unknown' is avoided by
|
||||
# telling the unknown handler to avoid this (by means of the global array
|
||||
# "_obTcl_unknBarred").
|
||||
#
|
||||
proc otMkSectMethod { class name sect } {
|
||||
$class sys_method $name args "
|
||||
array set Opts \$args
|
||||
foreach i \[array names Opts\] {
|
||||
global _obTcl_unknBarred
|
||||
set _obTcl_unknBarred(\$class::${sect}:\$i) 1
|
||||
if \[catch {\$class::$sect:\$i \$Opts(\$i)} err\] {
|
||||
if \[catch {\$class::${sect}_unknown\
|
||||
\$i \$Opts(\$i)}\] {
|
||||
unset _obTcl_unknBarred(\$class::${sect}:\$i)
|
||||
error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
|
||||
\t\$err
|
||||
\"
|
||||
}
|
||||
}
|
||||
unset _obTcl_unknBarred(\$class::${sect}:\$i)
|
||||
}
|
||||
"
|
||||
}
|
||||
|
||||
# Note: MkOptHandl is really a part of `option' below.
|
||||
#
|
||||
proc otMkOptHandl {} {
|
||||
uplevel 1 {
|
||||
$iclass sys_method "cget" opt "
|
||||
classvar classOptions
|
||||
if \[catch {$iclass::cget:\$opt} ret\] {
|
||||
if \[catch {\$class::cget_unknown \$opt} ret\] {
|
||||
error \"Unable to do 'cget \$opt'\"
|
||||
}
|
||||
}
|
||||
return \$ret
|
||||
"
|
||||
otMkSectMethod $iclass conf_init init
|
||||
$iclass sys_method initialize {} {
|
||||
next
|
||||
classvar optDefaults
|
||||
eval instvar [array names optDefaults]
|
||||
foreach i [array names optDefaults] {
|
||||
set $i $optDefaults($i)
|
||||
}
|
||||
}
|
||||
|
||||
# arr - Out-param
|
||||
#
|
||||
$iclass sys_method collectOptions { mode arr } {
|
||||
classvar classOptions optDefaults
|
||||
|
||||
upvar 1 $arr ret
|
||||
next $mode ret
|
||||
eval instvar [array names optDefaults]
|
||||
foreach i [array names optDefaults] {
|
||||
if [string compare "defaults" $mode] {
|
||||
set ret(-$i) [set $classOptions(-$i)]
|
||||
} else {
|
||||
set ret(-$i) $optDefaults($i)
|
||||
}
|
||||
}
|
||||
}
|
||||
otMkSectMethod $iclass conf_verify verify
|
||||
otMkSectMethod $iclass configure configure
|
||||
|
||||
set _optPriv(section,cget) 1
|
||||
set _optPriv(section,init) 1
|
||||
set _optPriv(section,initialize) 1
|
||||
set _optPriv(section,verify) 1
|
||||
set _optPriv(section,configure) 1
|
||||
}
|
||||
}
|
||||
|
||||
otMkSectMethod Base configure configure
|
||||
|
||||
# _optPriv is used for internal option handling house keeping
|
||||
# Note: checking for existence of a proc is not always a good idea,
|
||||
# since it may simply be a cached pointer to a inherited method.
|
||||
#
|
||||
Base method option { opt dflt args } {
|
||||
|
||||
classvar_of_class $iclass optDefaults classOptions _optPriv
|
||||
|
||||
set var [string range $opt 1 end]
|
||||
set optDefaults($var) $dflt
|
||||
set classOptions($opt) $var
|
||||
|
||||
array set tmp $args
|
||||
if ![info exists _optPriv(initialize)] {
|
||||
otMkOptHandl
|
||||
set _optPriv(initialize) 1
|
||||
}
|
||||
foreach i [array names tmp] {
|
||||
if ![info exists _optPriv(section,$i)] {
|
||||
otMkSectMethod $iclass $i $i
|
||||
set _optPriv(section,$i) 1
|
||||
}
|
||||
$iclass sys_method "$i:$opt" _val "
|
||||
instvar $var
|
||||
set _old_val \$[set var]
|
||||
set $var \$_val
|
||||
set ret \[catch {$tmp($i)} res\]
|
||||
if {\$ret != 0 && \$ret != 2 } {
|
||||
set $var \$_old_val
|
||||
return -code \$ret -errorinfo \$res \$res
|
||||
}
|
||||
return \$res
|
||||
"
|
||||
set _optPriv($i:$opt) 1
|
||||
}
|
||||
if ![info exists _optPriv(cget:$opt)] {
|
||||
$iclass sys_method "cget:$opt" {} "
|
||||
instvar $var
|
||||
return \$[set var]
|
||||
"
|
||||
set _optPriv(cget:$opt) 1
|
||||
}
|
||||
if ![info exists tmp(verify)] {
|
||||
$iclass sys_method "verify:$opt" _val "
|
||||
instvar $var
|
||||
set $var \$_val
|
||||
"
|
||||
set _optPriv(verify:$opt) 1
|
||||
}
|
||||
if ![info exists tmp(configure)] {
|
||||
$iclass sys_method "configure:$opt" _val "
|
||||
instvar $var
|
||||
set $var \$_val
|
||||
"
|
||||
set _optPriv(configure:$opt) 1
|
||||
}
|
||||
if ![info exists tmp(init)] {
|
||||
$iclass sys_method "init:$opt" _val {}
|
||||
set _optPriv(init:$opt) 1
|
||||
}
|
||||
}
|
||||
|
||||
# Default methods for non-compulsory
|
||||
# standard sections in an option definition:
|
||||
#
|
||||
Base sys_method init_unknown { opt val } {}
|
||||
Base sys_method verify_unknown { opt val } {}
|
||||
|
||||
# Catch initialize for classes which have no option handlers:
|
||||
#
|
||||
Base sys_method initialize {} {}
|
||||
|
||||
# Catch conf_init in case no option handlers have been defined.
|
||||
#
|
||||
Base sys_method conf_init {} {}
|
||||
|
||||
crunch_skip begin
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# class Widget
|
||||
# Base class for obTcl's Tk-widgets.
|
||||
#
|
||||
|
||||
DOC "class Widget (Tk) base class for widgets" {
|
||||
NAME
|
||||
Widget - A base class for mega-widgets
|
||||
|
||||
SYNOPSIS
|
||||
Widget new <obj> ?tk_widget_type? ?config options?
|
||||
Widget <obj> ?tk_widget_type? ?config options?
|
||||
|
||||
DESCRIPTION
|
||||
The widget class provides a base class for Tk-objects.
|
||||
This class knows about widget naming conventions, so, for example,
|
||||
destroying a Widget object will destroy any descendants of this object.
|
||||
|
||||
The `new' method need not be specified if the object name starts with a
|
||||
leading ".". Thus giving syntactical compatibility with Tk for
|
||||
creating widgets.
|
||||
|
||||
If `tk_widget_type' is not specified, the widget will be created as
|
||||
a `frame'. If the type is specified it must be one of the existing
|
||||
Tk-widget types, for example: button, radiobutton, text, etc.
|
||||
See the Tk documentation for available widget types.
|
||||
|
||||
The normal case is to use a frame as the base for a mega-widget.
|
||||
This is also the recommended way, since it results in the Tk class-name
|
||||
of the frame being automatically set to the objects class name -thus
|
||||
resulting in "winfo class <obj>" returning the mega-widget's class
|
||||
name.
|
||||
|
||||
In order to create mega-widgets, derive new classes from this class.
|
||||
|
||||
METHODS
|
||||
The following methods are defined in Widget:
|
||||
|
||||
init ?<args>? - Creates a frame widget, and configures it if any
|
||||
configuration options are present. Automatically
|
||||
invoked by the creation process, so there is no
|
||||
need to call it (provided that you use 'next' in
|
||||
the init-method of the derived class).
|
||||
|
||||
destroy - Destroys the object and associated tk-widget.
|
||||
For Tk-compatibility, the function `destroy' can be
|
||||
used instead, example:
|
||||
|
||||
destroy <obj>
|
||||
|
||||
Note: If you plan to mix Tk-widgets transparently
|
||||
with mega-widgets, you should use the _function_
|
||||
`destroy'.
|
||||
Any descendant objects of <obj> will also be
|
||||
destroyed (this goes for both Tk-widgets and
|
||||
mega-widgets).
|
||||
|
||||
set - Overrides the `set' method of the Base class to
|
||||
allow objects of type `scrollbar' to work correctly.
|
||||
|
||||
unknown - Overrides the `unknown' method of the Base class.
|
||||
Directs any unknown methods to the main frame of
|
||||
the Widget object.
|
||||
|
||||
unknown_opt - Overrides the same method from the Base class.
|
||||
Automatically called from the option handling system.
|
||||
Directs any unknown options to the main frame of the
|
||||
Widget object.
|
||||
|
||||
In addition, all non-shadowed methods from the Base class can be used.
|
||||
|
||||
Any method that cannot be resolved is passed on to the associated
|
||||
Tk-widget. This behaviour can be altered for any derived classes
|
||||
by defining a new `unknown' method (thus shadowing Widget's own
|
||||
`unknown' method). The same technique can be used to override
|
||||
the `unknown_opt' method.
|
||||
|
||||
EXAMPLES
|
||||
A simple example of deriving a class MegaButton which consists of
|
||||
a button widget initiated with the text "MEGA" (yes, I know, it's
|
||||
silly).
|
||||
|
||||
class MegaButton
|
||||
MegaButton inherit Widget
|
||||
|
||||
MegaButton method init { args } {
|
||||
#
|
||||
# Allow the Widget class to create a button for us
|
||||
# (we need to specify widget type `button')
|
||||
#
|
||||
eval next button $args
|
||||
|
||||
$self configure -text "MEGA"
|
||||
}
|
||||
|
||||
frame .f
|
||||
MegaButton .f.b -background red -foreground white
|
||||
pack .f .f.b
|
||||
|
||||
This example shows how to specify a Tk-widget type (button), although
|
||||
I advice against specifying anything (thus using a frame).
|
||||
See DESCRIPTION above for the reasoning behind this. Also note that
|
||||
`eval' is used to split $args into separate arguments for passing to
|
||||
the init method of the Widget class.
|
||||
|
||||
A more realistic example:
|
||||
|
||||
class ScrolledText
|
||||
ScrolledText inherit Widget
|
||||
|
||||
ScrolledText method init { args } {
|
||||
next
|
||||
|
||||
text $self.t -yscrollcommand "$self.sb set"
|
||||
scrollbar $self.sb -command "$self.t yview"
|
||||
|
||||
pack $self.sb -side right -fill y
|
||||
pack $self.t -side left
|
||||
|
||||
eval $self configure $args
|
||||
}
|
||||
|
||||
ScrolledText method unknown { args } {
|
||||
eval {$self.t $method} $args
|
||||
}
|
||||
|
||||
ScrolledText .st
|
||||
.st insert end [exec cat /etc/passwd]
|
||||
pack .st
|
||||
|
||||
This creates a new class, ScrolledText, containing a text window
|
||||
and a vertical scrollbar. It arranges for all unknown methods to
|
||||
be directed to the text widget; thus allowing `.st insert' to work
|
||||
normally (along with any other text methods).
|
||||
|
||||
NOTES
|
||||
Widget binds the "destroy" method to the <Destroy> event of
|
||||
the holding window, so be careful not to remove this binding
|
||||
inadvertently.
|
||||
}
|
||||
|
||||
crunch_skip end
|
||||
|
||||
class Widget
|
||||
|
||||
# init Create a tk-widget of specified type (or frame if not specified).
|
||||
# If the corresponding Tk-widget already exists, it will be used.
|
||||
# Otherwise the Tk-widget will be created.
|
||||
# The tk-widget will be named $self if $self has a leading ".",
|
||||
# otherwise a "." is prepended to $self to form the wigdet name.
|
||||
# The instvar `win' will contain the widgets window name, and
|
||||
# the instvar `wincmd' will contain the name of the widget's associated
|
||||
# command.
|
||||
|
||||
Widget method init args {
|
||||
instvar win wincmd
|
||||
|
||||
next
|
||||
|
||||
set first "[lindex $args 0]"
|
||||
set c1 "[string index $first 0]"
|
||||
if { ![string compare "" "$c1"] || ![string compare "-" "$c1"] } {
|
||||
set type frame
|
||||
set cl "-class $iclass"
|
||||
} else {
|
||||
set type $first
|
||||
set args [lrange $args 1 end]
|
||||
set cl ""
|
||||
}
|
||||
if [string compare "" [info commands $self-cmd]] {
|
||||
set win $self
|
||||
set wincmd $self-cmd
|
||||
} else {
|
||||
if ![string compare "." [string index $self 0]] {
|
||||
rename $self _ooTmp
|
||||
eval $type $self $cl $args
|
||||
rename $self $self-cmd
|
||||
rename _ooTmp $self
|
||||
set win $self
|
||||
set wincmd $self-cmd
|
||||
} else {
|
||||
eval $type .$self $cl $args
|
||||
set win .$self
|
||||
#set wincmd .$self-cmd
|
||||
set wincmd .$self
|
||||
}
|
||||
}
|
||||
bind $win <Destroy> "\
|
||||
if { !\[string compare \"%W\" \"$self\"\] && !\[catch {info args $self}\] } {
|
||||
$self destroy -obj_only }"
|
||||
|
||||
return $self
|
||||
}
|
||||
|
||||
# Just for the case when there are no option-handlers defined:
|
||||
#
|
||||
Widget sys_method configure args {
|
||||
instvar wincmd
|
||||
eval {$wincmd configure} $args
|
||||
}
|
||||
Widget sys_method cget opt {
|
||||
instvar wincmd
|
||||
eval {$wincmd cget} $opt
|
||||
}
|
||||
|
||||
Widget sys_method configure_unknown { opt args } {
|
||||
instvar wincmd
|
||||
eval {$wincmd configure $opt} $args
|
||||
}
|
||||
|
||||
Widget sys_method cget_unknown opt {
|
||||
instvar wincmd
|
||||
$wincmd cget $opt
|
||||
}
|
||||
Widget sys_method init_unknown { opt val } {
|
||||
puts "init_unknown: $opt $val (iclass=$iclass class=$class)"
|
||||
}
|
||||
|
||||
Widget sys_method unknown args {
|
||||
instvar wincmd
|
||||
eval {$wincmd $method} $args
|
||||
}
|
||||
|
||||
# Note: no "next" used! Does the `Base::destroy' stuff here for performance.
|
||||
#
|
||||
Widget method destroy args {
|
||||
|
||||
instvar win wincmd
|
||||
|
||||
# Must copy vars since they are destroyed by `otFreeObj'
|
||||
set wp $win
|
||||
set w $wincmd
|
||||
|
||||
otFreeObj $self
|
||||
catch {bind $w <Destroy> {}}
|
||||
if [string compare "-obj_only" $args] {
|
||||
if [string compare $w $wp] {
|
||||
rename $w $wp
|
||||
}
|
||||
if [string compare "-keepwin" $args] {
|
||||
destroy $wp
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# The method `set' defined here shadows the `set' method from Base.
|
||||
# This allows wrapper objects around Tk-scrollbars to work correctly.
|
||||
#
|
||||
Widget sys_method set args {
|
||||
instvar wincmd
|
||||
eval {$wincmd set} $args
|
||||
}
|
||||
|
||||
Widget sys_method base_set args {
|
||||
eval Base::set $args
|
||||
}
|
||||
|
||||
2
danu.dat
2
danu.dat
@ -1,3 +1,3 @@
|
||||
537199956
|
||||
537199972
|
||||
NEVER, EVER modify or delete this file
|
||||
You'll risk eternal damnation and a reincarnation as a cockroach!|n
|
||||
297
inherit.tcl
297
inherit.tcl
@ -1,297 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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 *::$i]
|
||||
eval lappend tmp [array names _obTcl_Cached *::${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 *::* 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 *::* $name] {
|
||||
set tmp [split $name :]
|
||||
set class [lindex $tmp 0]
|
||||
set func [join [lrange $tmp 2 end] :]
|
||||
|
||||
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}::$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::${method}_next args $tmp
|
||||
} else {
|
||||
proc $class::${method}_next args return
|
||||
}
|
||||
set _obTcl_Cached(${class}::${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}::${method}_next)] {
|
||||
otNextPrepare
|
||||
}
|
||||
|
||||
incr _obTcl_Cnt 1
|
||||
set ret [catch {uplevel 1 {${class}::${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::$func]] &&
|
||||
![info exists _obTcl_Cached(${class}::$func)] } {
|
||||
return "$class::$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::$func"
|
||||
}
|
||||
|
||||
273
lin2ang.c
Normal file
273
lin2ang.c
Normal file
@ -0,0 +1,273 @@
|
||||
/*--------------------------------------------------------------------------
|
||||
|
||||
L I N 2 A N G
|
||||
|
||||
A virtual motor device for driving an angle through a translation table.
|
||||
As of now special for TOPSI.
|
||||
|
||||
copyright: see copyright.h
|
||||
|
||||
Mark Koennecke, February 2000
|
||||
---------------------------------------------------------------------------*/
|
||||
#include <stdlib.h>
|
||||
#include <math.h>
|
||||
#include <assert.h>
|
||||
#include <tcl.h>
|
||||
#include "fortify.h"
|
||||
#include "sics.h"
|
||||
#include "lin2ang.h"
|
||||
|
||||
static const float RD = 57.2957795, pi = 3.1415926;
|
||||
|
||||
/* --------- our very own private data structure ------------------------*/
|
||||
typedef struct __LIN2ANG {
|
||||
pObjectDescriptor pDes;
|
||||
pIDrivable pDriv;
|
||||
pMotor lin;
|
||||
float length;
|
||||
}Lin2Ang, *pLin2Ang;
|
||||
|
||||
/*-------------------------- conversion routines -------------------------*/
|
||||
static float ang2x(pLin2Ang self, float fAngle)
|
||||
{
|
||||
return self->length*sin(fAngle/RD);
|
||||
}
|
||||
/*-----------------------------------------------------------------------*/
|
||||
static float x2ang(pLin2Ang self, float fX)
|
||||
{
|
||||
double dt;
|
||||
|
||||
assert(self->length > 0.);
|
||||
|
||||
dt = fX/self->length;
|
||||
return RD*asin(dt);
|
||||
}
|
||||
/*============== functions in the interface ============================*/
|
||||
static void *Lin2AngGetInterface(void *pData, int iID)
|
||||
{
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
if(iID == DRIVEID)
|
||||
{
|
||||
return self->pDriv;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
/*-----------------------------------------------------------------------*/
|
||||
static int L2AHalt(void *pData)
|
||||
{
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
|
||||
return self->lin->pDrivInt->Halt(self->lin);
|
||||
}
|
||||
/*------------------------------------------------------------------------*/
|
||||
static int L2ALimits(void *pData, float fVal, char *error, int iErrlen)
|
||||
{
|
||||
float fX;
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
|
||||
fX = ang2x(self,fVal);
|
||||
return self->lin->pDrivInt->CheckLimits(self->lin,fX,error,iErrlen);
|
||||
}
|
||||
/*-----------------------------------------------------------------------*/
|
||||
static float L2AGetValue(void *pData, SConnection *pCon)
|
||||
{
|
||||
float fX;
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
fX = self->lin->pDrivInt->GetValue(self->lin,pCon);
|
||||
return x2ang(self,fX);
|
||||
}
|
||||
/*------------------------------------------------------------------------*/
|
||||
static int L2AStatus(void *pData, SConnection *pCon)
|
||||
{
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
return self->lin->pDrivInt->CheckStatus(self->lin,pCon);
|
||||
}
|
||||
/*------------------------------------------------------------------------*/
|
||||
static long L2ASetValue(void *pData, SConnection *pCon, float fValue)
|
||||
{
|
||||
float fX;
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
|
||||
fX = ang2x(self,fValue);
|
||||
return self->lin->pDrivInt->SetValue(self->lin,pCon,fX);
|
||||
}
|
||||
/*--------------------------------------------------------------------*/
|
||||
static void KillL2A(void *pData)
|
||||
{
|
||||
pLin2Ang self = NULL;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
if(!self)
|
||||
return;
|
||||
|
||||
if(self->pDes)
|
||||
{
|
||||
DeleteDescriptor(self->pDes);
|
||||
}
|
||||
if(self->pDriv)
|
||||
{
|
||||
free(self->pDriv);
|
||||
}
|
||||
free(self);
|
||||
}
|
||||
/*-------------------------------------------------------------------
|
||||
Syntax: MakeLin2Ang name motor
|
||||
*/
|
||||
int MakeLin2Ang(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[])
|
||||
{
|
||||
pLin2Ang pNew = NULL;
|
||||
char pBueffel[255];
|
||||
int iRet;
|
||||
|
||||
/* check number of arguments */
|
||||
if(argc < 3)
|
||||
{
|
||||
SCWrite(pCon,"ERROR: Insufficient arguments to Lin2Arg",eError);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* allocate memory */
|
||||
pNew = (pLin2Ang)malloc(sizeof(Lin2Ang));
|
||||
if(!pNew)
|
||||
{
|
||||
SCWrite(pCon,"ERROR: out of memory in MakeLin2Ang",eError);
|
||||
return 0;
|
||||
}
|
||||
memset(pNew,0,sizeof(Lin2Ang));
|
||||
pNew->pDes = CreateDescriptor("Lin2Ang");
|
||||
if(!pNew->pDes)
|
||||
{
|
||||
SCWrite(pCon,"ERROR: out of memory in MakeLin2Ang",eError);
|
||||
free(pNew);
|
||||
return 0;
|
||||
}
|
||||
pNew->pDriv = CreateDrivableInterface();
|
||||
if(!pNew->pDriv)
|
||||
{
|
||||
SCWrite(pCon,"ERROR: out of memory in MakeLin2Ang",eError);
|
||||
KillL2A(pNew);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* check if we got a motor */
|
||||
pNew->lin = FindMotor(pSics,argv[2]);
|
||||
if(!pNew->lin)
|
||||
{
|
||||
sprintf(pBueffel,"ERROR: %s is no motor!",argv[2]);
|
||||
SCWrite(pCon,pBueffel,eError);
|
||||
KillL2A(pNew);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* initialize the data structure */
|
||||
pNew->pDes->GetInterface = Lin2AngGetInterface;
|
||||
pNew->pDriv->Halt = L2AHalt;
|
||||
pNew->pDriv->CheckLimits = L2ALimits;
|
||||
pNew->pDriv->SetValue = L2ASetValue;
|
||||
pNew->pDriv->CheckStatus = L2AStatus;
|
||||
pNew->pDriv->GetValue = L2AGetValue;
|
||||
pNew->length = 80.;
|
||||
|
||||
/* install command */
|
||||
iRet = AddCommand(pSics, argv[1],Lin2AngAction,KillL2A,pNew);
|
||||
if(!iRet)
|
||||
{
|
||||
sprintf(pBueffel,
|
||||
"ERROR: duplicate Lin2Ang command %s NOT created",
|
||||
argv[1]);
|
||||
SCWrite(pCon,pBueffel,eError);
|
||||
KillL2A(pNew);
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
/*--------------------------------------------------------------------*/
|
||||
int Lin2AngAction(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[])
|
||||
{
|
||||
pLin2Ang self = NULL;
|
||||
char pBueffel[255];
|
||||
float fVal, fLow, fHigh;
|
||||
double dVal;
|
||||
int iRet;
|
||||
|
||||
self = (pLin2Ang)pData;
|
||||
assert(self);
|
||||
assert(pCon);
|
||||
|
||||
/* without parameter: give value */
|
||||
if(argc < 2)
|
||||
{
|
||||
fVal = L2AGetValue(self,pCon);
|
||||
sprintf(pBueffel,"%s = %f",argv[0],fVal);
|
||||
SCWrite(pCon,pBueffel,eError);
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* interpret commands */
|
||||
strtolower(argv[1]);
|
||||
if(strcmp(argv[1],"length") == 0)
|
||||
{
|
||||
if(argc >= 3)
|
||||
{
|
||||
iRet = Tcl_GetDouble(pSics->pTcl,argv[2],&dVal);
|
||||
if(iRet != TCL_OK)
|
||||
{
|
||||
SCWrite(pCon,"ERROR: length parameter not recognised as number",
|
||||
eError);
|
||||
return 0;
|
||||
}
|
||||
if(!SCMatchRights(pCon,usUser))
|
||||
{
|
||||
SCWrite(pCon,"ERROR: Insufficient privilege to change length",
|
||||
eError);
|
||||
return 0;
|
||||
}
|
||||
self->length = dVal;
|
||||
SCSendOK(pCon);
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
sprintf(pBueffel,"%s.length = %f",argv[0],self->length);
|
||||
SCWrite(pCon,pBueffel,eValue);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
/* limits */
|
||||
if(strstr(argv[1],"lim") != NULL)
|
||||
{
|
||||
MotorGetPar(self->lin,"softupperlim",&fHigh);
|
||||
MotorGetPar(self->lin,"softlowerlim",&fLow);
|
||||
fHigh = x2ang(self,fHigh);
|
||||
fLow = x2ang(self,fLow);
|
||||
sprintf(pBueffel,"%s.limits: %f %f\n change through motor limits ",
|
||||
argv[0],fLow,fHigh);
|
||||
SCWrite(pCon,pBueffel,eValue);
|
||||
return 1;
|
||||
}
|
||||
sprintf(pBueffel,"ERROR: method %s not found!",argv[1]);
|
||||
SCWrite(pCon, pBueffel,eError);
|
||||
return 0;
|
||||
}
|
||||
|
||||
23
lin2ang.h
Normal file
23
lin2ang.h
Normal file
@ -0,0 +1,23 @@
|
||||
|
||||
/*-------------------------------------------------------------------------
|
||||
L I N 2 A N G
|
||||
|
||||
Drive an angle through a translation table. As of now only for
|
||||
TOPSI.
|
||||
|
||||
copyright: see copyright.h
|
||||
|
||||
Mark Koennecke, February 2000
|
||||
--------------------------------------------------------------------------*/
|
||||
#ifndef LIN2ANG
|
||||
#define LIN2ANG
|
||||
#include "motor.h"
|
||||
|
||||
int MakeLin2Ang(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[]);
|
||||
int Lin2AngAction(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[]);
|
||||
|
||||
|
||||
#endif
|
||||
|
||||
57
lin2ang.w
Normal file
57
lin2ang.w
Normal file
@ -0,0 +1,57 @@
|
||||
\subsection{lin2ang}
|
||||
lin2ang is a virtual motor object which allows to drive an angle
|
||||
through a translation table. In ist first incarnation this is meant
|
||||
for TOPSI but this may be useful in other places as well. The
|
||||
displacement x is calculated from the formula: $ x = L sin 2\theta $
|
||||
with L being the length of the arm around which the angle
|
||||
pivots. This must be a configurable parameter.
|
||||
|
||||
lin2ang's datastructure is quite simple:
|
||||
\begin{verbatim}
|
||||
typedef struct __LIN2ANG {
|
||||
pObjectDescriptor pDes;
|
||||
pIDrivable pDriv;
|
||||
pMotor lin;
|
||||
float length;
|
||||
}Lin2Ang;
|
||||
\end{verbatim}
|
||||
The fields are:
|
||||
\begin{description}
|
||||
\item[pDes] The standard SICS object descriptor.
|
||||
\item[pDriv] The drivable interface which hides most of the
|
||||
functionality of this object.
|
||||
\item[lin] The translation table motor to use for driving the angle.
|
||||
\item[length] The length of the arm around which the angle pivots.
|
||||
\end{description}
|
||||
|
||||
The interface to this is quite simple, most of the functionality is
|
||||
hidden in the drivable interface. Basically there are only the
|
||||
interpreter interface functions.
|
||||
|
||||
@d lin2angint @{
|
||||
int MakeLin2Ang(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[]);
|
||||
int Lin2AngAction(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[]);
|
||||
|
||||
@}
|
||||
|
||||
@o lin2ang.h @{
|
||||
/*-------------------------------------------------------------------------
|
||||
L I N 2 A N G
|
||||
|
||||
Drive an angle through a translation table. As of now only for
|
||||
TOPSI.
|
||||
|
||||
copyright: see copyright.h
|
||||
|
||||
Mark Koennecke, February 2000
|
||||
--------------------------------------------------------------------------*/
|
||||
#ifndef LIN2ANG
|
||||
#define LIN2ANG
|
||||
#include "motor.h"
|
||||
@<lin2angint@>
|
||||
#endif
|
||||
|
||||
@}
|
||||
|
||||
39
macro.c
39
macro.c
@ -90,6 +90,7 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
|
||||
struct __SicsUnknown {
|
||||
SConnection *pCon[MAXSTACK];
|
||||
char *lastUnknown[MAXSTACK];
|
||||
int iStack;
|
||||
SicsInterp *pInter;
|
||||
};
|
||||
@ -129,6 +130,7 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
SicsInterp *pSinter = NULL;
|
||||
SConnection *pCon = NULL;
|
||||
CommandList *pCommand = NULL;
|
||||
char *lastCommand = NULL, comBuffer[132];
|
||||
int iRet,i;
|
||||
int iMacro;
|
||||
|
||||
@ -137,6 +139,8 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
assert(pSics);
|
||||
pSinter = pSics->pInter;
|
||||
pCon = pSics->pCon[pSics->iStack];
|
||||
lastCommand = pSics->lastUnknown[pSics->iStack];
|
||||
|
||||
assert(pSinter);
|
||||
assert(pCon);
|
||||
|
||||
@ -157,13 +161,32 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
Tcl_AppendResult(pInter,"Object ",myarg[0]," not found",NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
|
||||
/* check for endless loop */
|
||||
Arg2Text(margc, myarg, comBuffer,131);
|
||||
if(lastCommand != NULL)
|
||||
{
|
||||
if(strcmp(lastCommand,comBuffer) == 0)
|
||||
{
|
||||
Tcl_AppendResult(pInter,"ERROR: Never ending loop in unknown\n",
|
||||
"Offending command: ",comBuffer,
|
||||
"Probably Tcl command not found",NULL);
|
||||
SCSetInterrupt(pCon,eAbortBatch);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
}
|
||||
pSics->lastUnknown[pSics->iStack] = strdup(comBuffer);
|
||||
|
||||
/* invoke */
|
||||
iMacro = SCinMacro(pCon);
|
||||
SCsetMacro(pCon,1);
|
||||
iRet = pCommand->OFunc(pCon,pSinter,pCommand->pData,margc, myarg);
|
||||
SCsetMacro(pCon,iMacro);
|
||||
|
||||
free(pSics->lastUnknown[pSics->iStack]);
|
||||
pSics->lastUnknown[pSics->iStack] = NULL;
|
||||
|
||||
|
||||
/* finish */
|
||||
if(iRet)
|
||||
{
|
||||
@ -192,7 +215,6 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
initialises a Tcl-Interpreter, installs SICS unknown mechanism and kills
|
||||
a few dangerous commands from the normal Tcl command set
|
||||
*/
|
||||
extern int initcl_Init(Tcl_Interp *pInter);
|
||||
|
||||
Tcl_Interp *MacroInit(SicsInterp *pSics)
|
||||
{
|
||||
@ -220,7 +242,8 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
pUnknown->iStack = 0;
|
||||
pUnknown->pInter = pSics;
|
||||
pUnbekannt = pUnknown;
|
||||
Tcl_CreateCommand(pInter,"SicsUnknown",SicsUnknownProc,pUnknown, UnknownKill);
|
||||
Tcl_CreateCommand(pInter,"unknown",SicsUnknownProc,
|
||||
pUnknown, UnknownKill);
|
||||
|
||||
/* delete dangers */
|
||||
Tcl_DeleteCommand(pInter,"exit");
|
||||
@ -228,13 +251,6 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
Tcl_DeleteCommand(pInter,"vwait");
|
||||
Tcl_DeleteCommand(pInter,"exec");
|
||||
|
||||
/* default initialisation */
|
||||
Tcl_SetVar(pInter,"auto_path"," ",TCL_GLOBAL_ONLY);
|
||||
initcl_Init(pInter);
|
||||
|
||||
/* initialise Don Libber Tcl-debugger */
|
||||
/* Dbg_Init(pInter); */
|
||||
|
||||
return pInter;
|
||||
}
|
||||
/*--------------------------------------------------------------------------*/
|
||||
@ -812,6 +828,9 @@ extern Tcl_Interp *InterpGetTcl(SicsInterp *pSics);
|
||||
at the end. This is to permit clients to search for this string in
|
||||
order to find out when a command has finished.
|
||||
*/
|
||||
|
||||
|
||||
|
||||
int TransactAction(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[])
|
||||
{
|
||||
|
||||
305
object.tcl
Executable file
305
object.tcl
Executable file
@ -0,0 +1,305 @@
|
||||
#
|
||||
# $Id: object.tcl,v 1.1 2000/02/25 16:21:41 cvs Exp $
|
||||
#
|
||||
# This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that: (1) source code distributions
|
||||
# retain the above copyright notice and this paragraph in its entirety, (2)
|
||||
# distributions including binary code include the above copyright notice and
|
||||
# this paragraph in its entirety in the documentation or other materials
|
||||
# provided with the distribution, and (3) all advertising materials mentioning
|
||||
# features or use of this software display the following acknowledgement:
|
||||
# ``This product includes software developed by the University of California,
|
||||
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
|
||||
# the University nor the names of its contributors may be used to endorse
|
||||
# or promote products derived from this software without specific prior
|
||||
# written permission.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
#
|
||||
|
||||
set object_priv(currentClass) {}
|
||||
set object_priv(objectCounter) 0
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
proc object_class {name spec} {
|
||||
global object_priv
|
||||
set object_priv(currentClass) $name
|
||||
lappend object_priv(objects) $name
|
||||
upvar #0 ${name}_priv class
|
||||
set class(__members) {}
|
||||
set class(__methods) {}
|
||||
set class(__params) {}
|
||||
set class(__class_vars) {}
|
||||
set class(__class_methods) {}
|
||||
uplevel $spec
|
||||
proc $name:config args "uplevel \[concat object_config \$args]"
|
||||
proc $name:configure args "uplevel \[concat object_config \$args]"
|
||||
proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc method {name args body} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
if {[lsearch $class(__methods) $name] < 0} {
|
||||
lappend class(__methods) $name
|
||||
}
|
||||
set methodArgs self
|
||||
append methodArgs " " $args
|
||||
proc $className:$name $methodArgs "upvar #0 \$self slot ${className}_priv class_var\n$body"
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc object_method {name {defaultValue {}}} [info body method]
|
||||
#------------------------------------------------------------------
|
||||
proc member {name {defaultValue {}}} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
lappend class(__members) [list $name $defaultValue]
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc object_member {name {defaultValue {}}} [info body member]
|
||||
#---------------------------------------------------------------------
|
||||
proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
if {$resourceClass == ""} {
|
||||
set resourceClass \
|
||||
[string toupper [string index $name 0]][string range $name 1 end]
|
||||
}
|
||||
if ![info exists class(__param_info/$name)] {
|
||||
lappend class(__params) $name
|
||||
}
|
||||
set class(__param_info/$name) [list $defaultValue $resourceClass]
|
||||
if {$configCode != {}} {
|
||||
proc $className:config:$name self $configCode
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc object_param {name {defaultValue {}} {resourceClass {}} {configCode {}}} \
|
||||
[info body param]
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
proc object_class_var {name {initialValue ""}} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
set class($name) $initialValue
|
||||
set class(__initial_value.$name) $initialValue
|
||||
lappend class(__class_vars) $name
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_class_method {name args body} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
if {[lsearch $class(__class_methods) $name] < 0} {
|
||||
lappend class(__class_methods) $name
|
||||
}
|
||||
proc $className:$name $args "upvar #0 ${className}_priv class_var\n$body"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_include {super_class_name} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
upvar #0 ${super_class_name}_priv super_class
|
||||
foreach p $super_class(__params) {
|
||||
lappend class(__params) $p
|
||||
set class(__param_info/$p) $super_class(__param_info/$p)
|
||||
}
|
||||
set class(__members) [concat $super_class(__members) $class(__members)]
|
||||
set class(__class_vars) \
|
||||
[concat $super_class(__class_vars) $class(__class_vars)]
|
||||
foreach v $super_class(__class_vars) {
|
||||
set class($v) \
|
||||
[set class(__initial_value.$v) $super_class(__initial_value.$v)]
|
||||
}
|
||||
set class(__class_methods) \
|
||||
[concat $super_class(__class_methods) $class(__class_methods)]
|
||||
set class(__methods) \
|
||||
[concat $super_class(__methods) $class(__methods)]
|
||||
foreach m $super_class(__methods) {
|
||||
set proc $super_class_name:$m
|
||||
proc $className:$m [object_get_formals $proc] [info body $proc]
|
||||
}
|
||||
foreach m $super_class(__class_methods) {
|
||||
set proc $super_class_name:$m
|
||||
regexp "^\[^\n\]+\n(.*)" [info body $proc] dummy body
|
||||
proc $className:$m [object_get_formals $proc] \
|
||||
"upvar #0 ${className}_priv class_var\n$body"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_new {className {name {}}} {
|
||||
if {$name == {}} {
|
||||
global object_priv
|
||||
set name O_[incr object_priv(objectCounter)]
|
||||
}
|
||||
upvar #0 $name object
|
||||
upvar #0 ${className}_priv class
|
||||
set object(__class) $className
|
||||
foreach var $class(__params) {
|
||||
set info $class(__param_info/$var)
|
||||
set resourceClass [lindex $info 1]
|
||||
if ![catch {set val [option get $name $var $resourceClass]}] {
|
||||
if {$val == ""} {
|
||||
set val [lindex $info 0]
|
||||
}
|
||||
} else {
|
||||
set val [lindex $info 0]
|
||||
}
|
||||
set object($var) $val
|
||||
}
|
||||
foreach var $class(__members) {
|
||||
set object([lindex $var 0]) [lindex $var 1]
|
||||
}
|
||||
proc $name {method args} [format {
|
||||
upvar #0 %s object
|
||||
uplevel [concat $object(__class):$method %s $args]
|
||||
} $name $name]
|
||||
return $name
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc object_define_creator {windowType name spec} {
|
||||
object_class $name $spec
|
||||
if {[info procs $name:create] == {}} {
|
||||
error "widget \"$name\" must define a create method"
|
||||
}
|
||||
if {[info procs $name:reconfig] == {}} {
|
||||
error "widget \"$name\" must define a reconfig method"
|
||||
}
|
||||
proc $name {window args} [format {
|
||||
%s $window -class %s
|
||||
rename $window object_window_of$window
|
||||
upvar #0 $window object
|
||||
set object(__window) $window
|
||||
object_new %s $window
|
||||
proc %s:frame {self args} \
|
||||
"uplevel \[concat object_window_of$window \$args]"
|
||||
uplevel [concat $window config $args]
|
||||
$window create
|
||||
set object(__created) 1
|
||||
bind $window <Destroy> \
|
||||
"if !\[string compare %%W $window\] { object_delete $window }"
|
||||
$window reconfig
|
||||
return $window
|
||||
} $windowType \
|
||||
[string toupper [string index $name 0]][string range $name 1 end] \
|
||||
$name $name]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc object_config {self args} {
|
||||
upvar #0 $self object
|
||||
set len [llength $args]
|
||||
if {$len == 0} {
|
||||
upvar #0 $object(__class)_priv class
|
||||
set result {}
|
||||
foreach param $class(__params) {
|
||||
set info $class(__param_info/$param)
|
||||
lappend result \
|
||||
[list -$param $param [lindex $info 1] [lindex $info 0] \
|
||||
$object($param)]
|
||||
}
|
||||
if [info exists object(__window)] {
|
||||
set result [concat $result [object_window_of$object(__window) config]]
|
||||
}
|
||||
return $result
|
||||
}
|
||||
if {$len == 1} {
|
||||
upvar #0 $object(__class)_priv class
|
||||
if {[string index $args 0] != "-"} {
|
||||
error "param '$args' didn't start with dash"
|
||||
}
|
||||
set param [string range $args 1 end]
|
||||
if {[set ndx [lsearch -exact $class(__params) $param]] == -1} {
|
||||
if [info exists object(__window)] {
|
||||
return [object_window_of$object(__window) config -$param]
|
||||
}
|
||||
error "no param '$args'"
|
||||
}
|
||||
set info $class(__param_info/$param)
|
||||
return [list -$param $param [lindex $info 1] [lindex $info 0] \
|
||||
$object($param)]
|
||||
}
|
||||
# accumulate commands and eval them later so that no changes will take
|
||||
# place if we find an error
|
||||
set cmds ""
|
||||
while {$args != ""} {
|
||||
set fieldId [lindex $args 0]
|
||||
if {[string index $fieldId 0] != "-"} {
|
||||
error "param '$fieldId' didn't start with dash"
|
||||
}
|
||||
set fieldId [string range $fieldId 1 end]
|
||||
if ![info exists object($fieldId)] {
|
||||
if {[info exists object(__window)]} {
|
||||
if [catch [list object_window_of$object(__window) config -$fieldId]] {
|
||||
error "tried to set param '$fieldId' which did not exist."
|
||||
} else {
|
||||
lappend cmds \
|
||||
[list object_window_of$object(__window) config -$fieldId [lindex $args 1]]
|
||||
set args [lrange $args 2 end]
|
||||
continue
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
if {[llength $args] == 1} {
|
||||
return $object($fieldId)
|
||||
} else {
|
||||
lappend cmds [list set object($fieldId) [lindex $args 1]]
|
||||
if {[info procs $object(__class):config:$fieldId] != {}} {
|
||||
lappend cmds [list $self config:$fieldId]
|
||||
}
|
||||
set args [lrange $args 2 end]
|
||||
}
|
||||
}
|
||||
foreach cmd $cmds {
|
||||
eval $cmd
|
||||
}
|
||||
if {[info exists object(__created)] && [info procs $object(__class):reconfig] != {}} {
|
||||
$self reconfig
|
||||
}
|
||||
}
|
||||
|
||||
proc object_cget {self var} {
|
||||
upvar #0 $self object
|
||||
return [lindex [object_config $self $var] 4]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_delete self {
|
||||
upvar #0 $self object
|
||||
if {[info exists object(__class)] && [info commands $object(__class):destroy] != ""} {
|
||||
$object(__class):destroy $self
|
||||
}
|
||||
if [info exists object(__window)] {
|
||||
if [string length [info commands object_window_of$self]] {
|
||||
catch {rename $self {}}
|
||||
rename object_window_of$self $self
|
||||
}
|
||||
destroy $self
|
||||
}
|
||||
catch {unset object}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc object_slotname slot {
|
||||
upvar self self
|
||||
return [set self]($slot)
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc object_get_formals {proc} {
|
||||
set formals {}
|
||||
foreach arg [info args $proc] {
|
||||
if [info default $proc $arg def] {
|
||||
lappend formals [list $arg $def]
|
||||
} else {
|
||||
lappend formals $arg
|
||||
}
|
||||
}
|
||||
return $formals
|
||||
}
|
||||
540
obtcl.tcl
540
obtcl.tcl
@ -1,540 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# -- 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}:${self}:$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}:\$_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}:\$_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}:\$_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}:\${self}:\$_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}:\${self}:\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
}
|
||||
|
||||
# Renamed Instance variable. Specific to instances.
|
||||
proc renamed_instvar { normal_name new_name } {
|
||||
uplevel 1 "upvar #0 _oIV_\${class}:\${self}:$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::initialize}
|
||||
eval {$iclass::init} $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::\$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::\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
|
||||
} else {
|
||||
return \$val
|
||||
}
|
||||
"
|
||||
set self $obj
|
||||
eval {$iclass::initialize}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# 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_*:${self}:*\]"}
|
||||
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 *:* $class] {
|
||||
puts stderr "class: Fatal Error:"
|
||||
puts stderr " class name `$class'\
|
||||
contains reserved character `:'"
|
||||
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::new \$cmd} \$args }
|
||||
new { eval {$class::new} \$args }
|
||||
method { eval {otMkMethod N $class} \$args}
|
||||
inherit { eval {otInherit $class} \$args}
|
||||
destroy { eval {otClassDestroy $class} \$args }
|
||||
init { return -code error \
|
||||
-errorinfo \"$obj: Error: classes may not be init'ed!\" \
|
||||
\"$obj: Error: classes may not be init'ed!\"
|
||||
}
|
||||
default {
|
||||
if \[catch {eval {$iclass::\$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}:*\] {
|
||||
unset \$_iii
|
||||
}
|
||||
foreach _iii \[info vars _oDCV_${class}:*\] {
|
||||
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::$name $params \
|
||||
"otGetSelf
|
||||
set class $class
|
||||
$method
|
||||
$body"
|
||||
if ![string compare "S" $mode] {
|
||||
global _obTcl_SysMethod
|
||||
set _obTcl_SysMethod($class::$name) 1
|
||||
}
|
||||
}
|
||||
|
||||
proc otRmMethod { class name } {
|
||||
global _obTcl_SysMethod
|
||||
|
||||
if [string compare "unknown" "$name"] {
|
||||
otInvalidateCaches 0 $class $name
|
||||
} else {
|
||||
otInvalidateCaches 0 $class *
|
||||
}
|
||||
rename $class::$name {}
|
||||
catch {unset _obTcl_SysMethod($class::$name)}
|
||||
}
|
||||
|
||||
proc otDelAllMethods class {
|
||||
global _obTcl_Cached
|
||||
foreach i [info procs $class::*] {
|
||||
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}::$method)] { return }
|
||||
if [catch {set b [info body ${class}::$method]} ret] {
|
||||
return -code error \
|
||||
-errorinfo "info body: Method '$method' not defined in class $class" \
|
||||
"info body: 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}::$method)] { return }
|
||||
if [catch {set b [info args ${class}::$method]} ret] {
|
||||
return -code error \
|
||||
-errorinfo "info args: Method '$method' not defined in class $class" \
|
||||
"info args: Method '$method' not defined in class $class"
|
||||
} else {
|
||||
return $b
|
||||
}
|
||||
}
|
||||
proc otClassInfoMethods+Cached class {
|
||||
global _obTcl_Objclass _obTcl_SysMethod
|
||||
set l [info procs ${class}::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class}::(.*)" $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}::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
if [info exists _obTcl_Cached($i)] { continue }
|
||||
if [info exists _obTcl_SysMethod($i)] { continue }
|
||||
regsub "${class}::(.*)" $i {\1} tmp
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otClassInfoSysMethods class {
|
||||
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
|
||||
set l [info procs ${class}::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
if [info exists _obTcl_Cached($i)] { continue }
|
||||
if ![info exists _obTcl_SysMethod($i)] { continue }
|
||||
regsub "${class}::(.*)" $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::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class}::(.*)" $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
|
||||
}
|
||||
|
||||
3
ofac.c
3
ofac.c
@ -101,6 +101,7 @@
|
||||
#include "maximize.h"
|
||||
#include "difrac.h"
|
||||
#include "sicscron.h"
|
||||
#include "lin2ang.h"
|
||||
/*----------------------- Server options creation -------------------------*/
|
||||
static int IFServerOption(SConnection *pCon, SicsInterp *pSics, void *pData,
|
||||
int argc, char *argv[])
|
||||
@ -271,6 +272,7 @@
|
||||
AddCommand(pInter,"MakeAmorStatus",AmorStatusFactory,NULL,NULL);
|
||||
AddCommand(pInter,"MakeMaximize",MaximizeFactory,NULL,NULL);
|
||||
AddCommand(pInter,"MakeDifrac",MakeDifrac,NULL,NULL);
|
||||
AddCommand(pInter,"MakeLin2Ang",MakeLin2Ang,NULL,NULL);
|
||||
}
|
||||
/*---------------------------------------------------------------------------*/
|
||||
static void KillIniCommands(SicsInterp *pSics)
|
||||
@ -322,6 +324,7 @@
|
||||
RemoveCommand(pSics,"MakeAmorStatus");
|
||||
RemoveCommand(pSics,"MakeMaximize");
|
||||
RemoveCommand(pSics,"MakeDifrac");
|
||||
RemoveCommand(pSics,"MakeLin2Ang");
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -1,24 +1,22 @@
|
||||
# RuenBuffer wuerg
|
||||
Buf new wuerg
|
||||
hm CountMode timer
|
||||
hm preset 2.000000
|
||||
hm preset 100.000000
|
||||
hm genbin 120.000000 35.000000 512
|
||||
hm init
|
||||
datafile focus-1001848.hdf
|
||||
datafile setAccess 3
|
||||
dbfile test.db
|
||||
dbfile UNKNOWN
|
||||
dbfile setAccess 2
|
||||
# Motor th
|
||||
th SoftZero 0.000000
|
||||
th SoftLowerLim -100.000000
|
||||
th SoftLowerLim -120.000000
|
||||
th SoftUpperLim 120.000000
|
||||
th Fixed -1.000000
|
||||
th sign 1.000000
|
||||
th InterruptMode 0.000000
|
||||
th AccessCode 2.000000
|
||||
#Crystallographic Settings
|
||||
hkl lambda 1.179600
|
||||
hkl setub 0.054026 0.059888 0.003094 0.059891 -0.054031 0.000506 0.000776 0.000621 -0.254583
|
||||
hkl lambda 0.703790
|
||||
hkl setub -0.124702 0.001618 -0.041357 -0.104448 -0.001326 0.049388 0.000751 0.084094 0.001574
|
||||
det1dist 300.
|
||||
det1dist setAccess 1
|
||||
det1zeroy 128.
|
||||
@ -31,15 +29,15 @@ monodescription unknownit crystal
|
||||
monodescription setAccess 1
|
||||
# Motor om
|
||||
om SoftZero 0.000000
|
||||
om SoftLowerLim -5.000000
|
||||
om SoftUpperLim 130.000000
|
||||
om SoftLowerLim -73.000000
|
||||
om SoftUpperLim 134.000000
|
||||
om Fixed -1.000000
|
||||
om sign 1.000000
|
||||
om InterruptMode 0.000000
|
||||
om AccessCode 2.000000
|
||||
# Motor stt
|
||||
stt SoftZero 0.000000
|
||||
stt SoftLowerLim -100.000000
|
||||
stt SoftLowerLim -120.000000
|
||||
stt SoftUpperLim 120.000000
|
||||
stt Fixed -1.000000
|
||||
stt sign 1.000000
|
||||
@ -47,16 +45,16 @@ stt InterruptMode 0.000000
|
||||
stt AccessCode 2.000000
|
||||
# Motor ch
|
||||
ch SoftZero 0.000000
|
||||
ch SoftLowerLim 84.000000
|
||||
ch SoftUpperLim 210.000000
|
||||
ch SoftLowerLim 0.000000
|
||||
ch SoftUpperLim 360.000000
|
||||
ch Fixed -1.000000
|
||||
ch sign 1.000000
|
||||
ch InterruptMode 0.000000
|
||||
ch AccessCode 2.000000
|
||||
# Motor ph
|
||||
ph SoftZero 0.000000
|
||||
ph SoftLowerLim -360.000000
|
||||
ph SoftUpperLim 350.000000
|
||||
ph SoftLowerLim 0.000000
|
||||
ph SoftUpperLim 360.000000
|
||||
ph Fixed -1.000000
|
||||
ph sign 1.000000
|
||||
ph InterruptMode 0.000000
|
||||
@ -79,36 +77,38 @@ muca InterruptMode 0.000000
|
||||
muca AccessCode 2.000000
|
||||
# Motor phi
|
||||
phi SoftZero 0.000000
|
||||
phi SoftLowerLim -360.000000
|
||||
phi SoftUpperLim 350.000000
|
||||
phi SoftLowerLim 0.000000
|
||||
phi SoftUpperLim 360.000000
|
||||
phi Fixed -1.000000
|
||||
phi sign 1.000000
|
||||
phi InterruptMode 0.000000
|
||||
phi AccessCode 2.000000
|
||||
# Motor chi
|
||||
chi SoftZero 0.000000
|
||||
chi SoftLowerLim 84.000000
|
||||
chi SoftUpperLim 210.000000
|
||||
chi SoftLowerLim 0.000000
|
||||
chi SoftUpperLim 360.000000
|
||||
chi Fixed -1.000000
|
||||
chi sign 1.000000
|
||||
chi InterruptMode 0.000000
|
||||
chi AccessCode 2.000000
|
||||
# Motor omega
|
||||
omega SoftZero 0.000000
|
||||
omega SoftLowerLim -5.000000
|
||||
omega SoftUpperLim 130.000000
|
||||
omega SoftLowerLim -73.000000
|
||||
omega SoftUpperLim 134.000000
|
||||
omega Fixed -1.000000
|
||||
omega sign 1.000000
|
||||
omega InterruptMode 0.000000
|
||||
omega AccessCode 2.000000
|
||||
# Motor twotheta
|
||||
twotheta SoftZero 0.000000
|
||||
twotheta SoftLowerLim -100.000000
|
||||
twotheta SoftLowerLim -120.000000
|
||||
twotheta SoftUpperLim 120.000000
|
||||
twotheta Fixed -1.000000
|
||||
twotheta sign 1.000000
|
||||
twotheta InterruptMode 0.000000
|
||||
twotheta AccessCode 2.000000
|
||||
lastscancommand sscan ch 180 190 10 2
|
||||
lastscancommand setAccess 2
|
||||
banana CountMode timer
|
||||
banana preset 100.000000
|
||||
sample_mur 0.000000
|
||||
@ -122,7 +122,7 @@ phone setAccess 2
|
||||
adress UNKNOWN
|
||||
adress setAccess 2
|
||||
# Counter counter
|
||||
counter SetPreset 0.500000
|
||||
counter SetPreset 2.000000
|
||||
counter SetMode Timer
|
||||
# Motor som
|
||||
som SoftZero 0.000000
|
||||
@ -237,9 +237,9 @@ d1r sign 1.000000
|
||||
d1r InterruptMode 0.000000
|
||||
d1r AccessCode 2.000000
|
||||
# Motor tasse
|
||||
tasse SoftZero 1.000000
|
||||
tasse SoftLowerLim -132.000000
|
||||
tasse SoftUpperLim 128.000000
|
||||
tasse SoftZero 0.000000
|
||||
tasse SoftLowerLim -130.000000
|
||||
tasse SoftUpperLim 130.000000
|
||||
tasse Fixed -1.000000
|
||||
tasse sign 1.000000
|
||||
tasse InterruptMode 0.000000
|
||||
@ -285,9 +285,9 @@ stu sign 1.000000
|
||||
stu InterruptMode 0.000000
|
||||
stu AccessCode 2.000000
|
||||
# Motor stl
|
||||
stl SoftZero 5.000000
|
||||
stl SoftLowerLim -35.000000
|
||||
stl SoftUpperLim 25.000000
|
||||
stl SoftZero 0.000000
|
||||
stl SoftLowerLim -30.000000
|
||||
stl SoftUpperLim 30.000000
|
||||
stl Fixed -1.000000
|
||||
stl sign 1.000000
|
||||
stl InterruptMode 0.000000
|
||||
@ -325,9 +325,9 @@ a5 sign 1.000000
|
||||
a5 InterruptMode 0.000000
|
||||
a5 AccessCode 2.000000
|
||||
# Motor a4
|
||||
a4 SoftZero 1.000000
|
||||
a4 SoftLowerLim -132.000000
|
||||
a4 SoftUpperLim 128.000000
|
||||
a4 SoftZero 0.000000
|
||||
a4 SoftLowerLim -130.000000
|
||||
a4 SoftUpperLim 130.000000
|
||||
a4 Fixed -1.000000
|
||||
a4 sign 1.000000
|
||||
a4 InterruptMode 0.000000
|
||||
@ -356,13 +356,11 @@ a1 Fixed -1.000000
|
||||
a1 sign 1.000000
|
||||
a1 InterruptMode 0.000000
|
||||
a1 AccessCode 2.000000
|
||||
lastscancommand cscan a4 10 .1 10 3
|
||||
lastscancommand setAccess 2
|
||||
user Daniel_the_Clementine
|
||||
user setAccess 2
|
||||
sample Bi2212 #1, th vs SGU=-12.5
|
||||
sample DanielOxid
|
||||
sample setAccess 2
|
||||
title TopsiTupsiTapsi
|
||||
title setAccess 2
|
||||
starttime 2000-02-21 09:08:52
|
||||
starttime UNKNOWN
|
||||
starttime setAccess 2
|
||||
|
||||
791
tcl/base.tcl
791
tcl/base.tcl
@ -1,791 +0,0 @@
|
||||
crunch_skip begin
|
||||
DOC "class Base" {
|
||||
NAME
|
||||
Base - The basic class inherited by all obTcl objects
|
||||
|
||||
SYNOPSIS
|
||||
Base new <obj>
|
||||
- Creates an object of the simplest possible class.
|
||||
|
||||
DESCRIPTION
|
||||
All classes inherits the Base class automatically. The Base class
|
||||
provides methods that are essential for manipulating obTcl-objects,
|
||||
such as `info' and `destroy'.
|
||||
|
||||
METHODS
|
||||
Base provides the following generic methods to all objects:
|
||||
|
||||
new - EXPERIMENTAL! Arranges to create a new object of
|
||||
the class of the invoking object.
|
||||
|
||||
instance - EXPERIMENTAL! Arranges to create a new object of
|
||||
the class of the invoking object. This method
|
||||
differs from `new' by NOT automatically invoking
|
||||
the `init' method of the new object.
|
||||
One possible usage: Create a replacement for the
|
||||
normal class object -a replacement which has no
|
||||
hard-coded methods (this will need careful design
|
||||
though).
|
||||
|
||||
init - Does nothing. The init method is automatically
|
||||
invoked whenever an object is created with `new'.
|
||||
|
||||
destroy - Frees all instance variables of the object, and
|
||||
the object itself.
|
||||
|
||||
class - Returns the class of the object.
|
||||
|
||||
set name ?value?
|
||||
- Sets the instance variable `name' to value.
|
||||
If no value is specified, the current value is
|
||||
returned. Mainly used for debugging purposes.
|
||||
|
||||
info <cmd> - Returns information about the object. See INFO
|
||||
below.
|
||||
|
||||
eval <script> - Evaluates `script' in the context of the object.
|
||||
Useful for debugging purposes. Not meant to be
|
||||
used for other purposes (create a method instead).
|
||||
One useful trick (if you use the Tcl-debugger in
|
||||
this package) is to enter:
|
||||
obj eval bp
|
||||
to be able to examine `obj's view of the world
|
||||
(breakpoints must be enabled, of course).
|
||||
|
||||
unknown <method> <args>
|
||||
- Automatically invoked when unknown methods are
|
||||
invoked. the Base class defines this method to
|
||||
print an error message, but this can be overridden
|
||||
by derived classes.
|
||||
|
||||
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
|
||||
- Define an option handler.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
conf_verify <args>
|
||||
conf_init <args>
|
||||
- Set options. <args> are option-value pairs.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
configure <args>
|
||||
- Set options. <args> are option-value pairs.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
cget <opt> - Get option value.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
verify_unknown <args>
|
||||
init_unknown <args>
|
||||
configure_unknown <args>
|
||||
cget_unknown <opt>
|
||||
- These methods are automatically invoked when a requested
|
||||
option has not been defined.
|
||||
See OPTION HANDLER below for a description.
|
||||
|
||||
INFO
|
||||
The method `info' can be used to inspect an object. In the list below
|
||||
(I) means the command is only applicable to object instances, whereas
|
||||
(C) means that the command can be applied either to the class object, or
|
||||
to the object instance, if that is more convenient.
|
||||
Existing commands:
|
||||
|
||||
instvars - (I) Returns the names of all existing instance variables.
|
||||
iclassvars - (I) List instance class variables
|
||||
|
||||
classvars - (C) List class variables.
|
||||
objects - (C) List objects of this class.
|
||||
methods - (C) List methods defined in this class.
|
||||
sysmethods - (C) List system methods defined in this class.
|
||||
cached - (C) List cached methods for this class.
|
||||
body <method> - (C) List the body of a method.
|
||||
args <method> - (C) List formal parameters for a method.
|
||||
|
||||
options - (I) List the current option values in the format
|
||||
"option-value pairs".
|
||||
defaults - (C) List the current default values in the format
|
||||
"option-value pairs". These values are the initial
|
||||
values each new object will be given.
|
||||
|
||||
OPTION HANDLER
|
||||
The method `option' is used to define options. It should be used on
|
||||
the class-object, which serves as a repository for default values
|
||||
and for code sections to run to verify and make use of new default values.
|
||||
|
||||
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
|
||||
Define an option for this class.
|
||||
Defining an option results in an instance variable
|
||||
of the same name (with the leading '-' stripped)
|
||||
being defined. This variable will be initiated
|
||||
with the value <default>.
|
||||
|
||||
The sections `verify', `init' and `configure' can be defined.
|
||||
|
||||
`verify' is used to verify new parameters without affecting
|
||||
the object. It is typically called by an object's init method
|
||||
before all parts of the object have been created.
|
||||
|
||||
`init' is used for rare situations where some action should be taken
|
||||
just after the object has been fully created. I.e when setting
|
||||
the option variable via `verify' was not sufficient.
|
||||
|
||||
The `configure' section is invoked when the configure method is
|
||||
called to re-configure an object.
|
||||
|
||||
Example usage:
|
||||
|
||||
class Graph
|
||||
Graph inherit Widget
|
||||
|
||||
Graph option {-width} 300 verify {
|
||||
if { $width >= 600 } {
|
||||
error "width must be less than 600"
|
||||
}
|
||||
} configure {
|
||||
$self.grf configure -width $width
|
||||
}
|
||||
|
||||
Note 1: The `verify' section should never attempt
|
||||
to access structures in the object (i.e widgets), since
|
||||
it is supposed to be callable before they exist!
|
||||
Use the `configure' section to manipulate the object.
|
||||
|
||||
Note 2: Using "break" or "error" in the verify section results
|
||||
in the newly specified option value being rejected.
|
||||
|
||||
conf_verify <args>
|
||||
Invoke all "verify" sections for options-value pairs
|
||||
specified in <args>.
|
||||
conf_init <args>
|
||||
Invoke all "init" sections for options-value pairs
|
||||
specified in <args>.
|
||||
|
||||
Example usage:
|
||||
|
||||
Graph method init { args } {
|
||||
instvar width
|
||||
|
||||
# Set any option variables from $args
|
||||
#
|
||||
eval $self conf_verify $args ;# Set params
|
||||
|
||||
next -width $width ;# Get frame
|
||||
|
||||
CreateRestOfObject ;# Bogus
|
||||
|
||||
# Option handlers that wish to affect the
|
||||
# object during init may declare an "init"
|
||||
# section. Run any such sections now:
|
||||
#
|
||||
eval $self conf_init $args
|
||||
}
|
||||
|
||||
Graph .graph -width 400 ;# Set width initially
|
||||
|
||||
configure <args>
|
||||
Invoke all "configure" sections for options-value pairs
|
||||
specified in <args>.
|
||||
|
||||
Example usage:
|
||||
|
||||
# First create object
|
||||
#
|
||||
Graph .graph -width 300
|
||||
|
||||
# Use `configure' to configure the object
|
||||
#
|
||||
.graph configure -width 200
|
||||
|
||||
cget <opt>
|
||||
Returns the current value of option <opt>.
|
||||
Example usage:
|
||||
|
||||
.graph cget -width
|
||||
|
||||
<sect>_unknown <args>
|
||||
These methods are called when attempting to invoke sections
|
||||
for unknown options. In this way a class may define methods
|
||||
to catch usage of "configure", "cget", etc. for undefined
|
||||
options.
|
||||
Example:
|
||||
|
||||
Graph method configure_unknown { opt args } {
|
||||
eval {$self-cmd configure $opt} $args
|
||||
}
|
||||
|
||||
See the definitions of the Base and Widget classes for their
|
||||
usage of these methods.
|
||||
}
|
||||
crunch_skip end
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Define the Base class. This class provides introspection etc.
|
||||
#
|
||||
# It also provides "set", which gives access to object
|
||||
# internal variables, and 'eval' which lets you run arbitrary scripts in
|
||||
# the objects context. You may wish to remove those methods if you
|
||||
# want to disallow this.
|
||||
|
||||
class Base
|
||||
|
||||
Base method init args {}
|
||||
|
||||
Base method destroy args {
|
||||
otFreeObj $self
|
||||
}
|
||||
|
||||
Base method class args {
|
||||
return $iclass
|
||||
}
|
||||
|
||||
# Note: The `set' method takes on the class of the caller, so
|
||||
# instvars will use the callers scope.
|
||||
#
|
||||
Base method set args {
|
||||
set class $iclass
|
||||
# instvar [lindex $args 0]
|
||||
set var [lindex $args 0]
|
||||
regexp -- {^([^(]*)\(.*\)$} $var m var
|
||||
instvar $var
|
||||
return [eval set $args]
|
||||
}
|
||||
|
||||
Base method eval l {
|
||||
return [eval $l]
|
||||
}
|
||||
|
||||
Base method info { cmd args } {
|
||||
switch $cmd {
|
||||
"instvars" {return [eval {otObjInfoVars\
|
||||
_oIV_${iclass}:${self}: _oIV_${iclass}:${self}:} $args]}
|
||||
"iclassvars" {otObjInfoVars _oICV_${iclass}: _oICV_${iclass}: $args}
|
||||
"classvars" {otObjInfoVars _oDCV_${iclass}: _oDCV_${iclass}: $args}
|
||||
"objects" {otObjInfoObjects $iclass}
|
||||
"methods" {otClassInfoMethods $iclass}
|
||||
"sysmethods" {otClassInfoSysMethods $iclass}
|
||||
"cached" {otClassInfoCached $iclass}
|
||||
"body" {otClassInfoBody $iclass $args}
|
||||
"args" {otClassInfoArgs $iclass $args}
|
||||
|
||||
"options" {$iclass::collectOptions values ret
|
||||
return [array get ret] }
|
||||
"defaults" {$iclass::collectOptions defaults ret
|
||||
return [array get ret] }
|
||||
|
||||
default {
|
||||
return -code error \
|
||||
-errorinfo "Undefined command 'info $cmd'" \
|
||||
"Undefined command 'info $cmd'"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
Base method unknown args {
|
||||
return -code error \
|
||||
-errorinfo "Undefined method '$method' invoked" \
|
||||
"Undefined method '$method' invoked"
|
||||
}
|
||||
|
||||
#------- START EXPERIMENTAL
|
||||
|
||||
Base method new { obj args } {
|
||||
eval {otNew $iclass $obj} $args
|
||||
}
|
||||
|
||||
Base method instance { obj args } {
|
||||
eval {otInstance $iclass $obj} $args
|
||||
}
|
||||
|
||||
Base method sys_method args {
|
||||
eval {otMkMethod S $iclass} $args
|
||||
}
|
||||
|
||||
Base method method args {
|
||||
eval {otMkMethod N $iclass} $args
|
||||
}
|
||||
|
||||
Base method del_method args {
|
||||
eval {otRmMethod $iclass} $args
|
||||
}
|
||||
|
||||
Base method inherit args {
|
||||
eval {otInherit $iclass} $args
|
||||
}
|
||||
|
||||
# class AnonInst - inherit from this class to be able to generate
|
||||
# anonymous objects. Example:
|
||||
#
|
||||
# class Foo
|
||||
# Foo inherit AnonInst
|
||||
# set obj [Foo new]
|
||||
#
|
||||
# NOTE: EXPERIMENTAL!!!
|
||||
|
||||
class AnonInst
|
||||
AnonInst method anonPrefix p {
|
||||
iclassvar _prefix
|
||||
set _prefix $p
|
||||
}
|
||||
AnonInst method new {{obj {}} args} {
|
||||
iclassvar _count _prefix
|
||||
if ![info exists _count] {
|
||||
set _count 0
|
||||
}
|
||||
if ![info exists _prefix] {
|
||||
set _prefix "$iclass"
|
||||
}
|
||||
if ![string compare "" $obj] {
|
||||
set obj $_prefix[incr _count]
|
||||
}
|
||||
eval next {$obj} $args
|
||||
return $obj
|
||||
}
|
||||
#------- END EXPERIMENTAL
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Configure stuff
|
||||
#----------------------------------------------------------------------
|
||||
# The configuaration stuff is, for various reasons, probably the most
|
||||
# change-prone part of obTcl.
|
||||
#
|
||||
# After fiddling around with various methods for handling options,
|
||||
# this is what I came up with. It uses one method for each class and option,
|
||||
# plus one dispatch-method for each of "conf_init", "conf_verify", "configure"
|
||||
# and "cget" per class. Any extra sections in the `option' handler
|
||||
# results in another dispatch-method being created.
|
||||
# Attempts at handling undefined options are redirected to
|
||||
#
|
||||
# <section_name>_unknown
|
||||
#
|
||||
# Note:
|
||||
# Every new object is initialized by a call to `initialize'.
|
||||
# This is done in the proc "new", before `init' is called, to guarantee
|
||||
# that initial defaults are set before usage. `initialize' calls "next", so
|
||||
# all inherited classes are given a chance to set their initial defaults.
|
||||
#
|
||||
# Sections and their used (by convention):
|
||||
#
|
||||
# verify - Called at beginning of object initialization to verify
|
||||
# specified options.
|
||||
# init - Called at end of the class' `init' method.
|
||||
# Use for special configuration.
|
||||
# configure
|
||||
# - This section should use the new value to configure
|
||||
# the object.
|
||||
#
|
||||
|
||||
# MkSectMethod - Define a method which does:
|
||||
# For each option specified, call the handler for the specified section
|
||||
# and option. If this fails, call the <section>_unknown handler.
|
||||
# If this fails too, return an error.
|
||||
# Note that the normal call of the method `unknown' is avoided by
|
||||
# telling the unknown handler to avoid this (by means of the global array
|
||||
# "_obTcl_unknBarred").
|
||||
#
|
||||
proc otMkSectMethod { class name sect } {
|
||||
$class sys_method $name args "
|
||||
array set Opts \$args
|
||||
foreach i \[array names Opts\] {
|
||||
global _obTcl_unknBarred
|
||||
set _obTcl_unknBarred(\$class::${sect}:\$i) 1
|
||||
if \[catch {\$class::$sect:\$i \$Opts(\$i)} err\] {
|
||||
if \[catch {\$class::${sect}_unknown\
|
||||
\$i \$Opts(\$i)}\] {
|
||||
unset _obTcl_unknBarred(\$class::${sect}:\$i)
|
||||
error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
|
||||
\t\$err
|
||||
\"
|
||||
}
|
||||
}
|
||||
unset _obTcl_unknBarred(\$class::${sect}:\$i)
|
||||
}
|
||||
"
|
||||
}
|
||||
|
||||
# Note: MkOptHandl is really a part of `option' below.
|
||||
#
|
||||
proc otMkOptHandl {} {
|
||||
uplevel 1 {
|
||||
$iclass sys_method "cget" opt "
|
||||
classvar classOptions
|
||||
if \[catch {$iclass::cget:\$opt} ret\] {
|
||||
if \[catch {\$class::cget_unknown \$opt} ret\] {
|
||||
error \"Unable to do 'cget \$opt'\"
|
||||
}
|
||||
}
|
||||
return \$ret
|
||||
"
|
||||
otMkSectMethod $iclass conf_init init
|
||||
$iclass sys_method initialize {} {
|
||||
next
|
||||
classvar optDefaults
|
||||
eval instvar [array names optDefaults]
|
||||
foreach i [array names optDefaults] {
|
||||
set $i $optDefaults($i)
|
||||
}
|
||||
}
|
||||
|
||||
# arr - Out-param
|
||||
#
|
||||
$iclass sys_method collectOptions { mode arr } {
|
||||
classvar classOptions optDefaults
|
||||
|
||||
upvar 1 $arr ret
|
||||
next $mode ret
|
||||
eval instvar [array names optDefaults]
|
||||
foreach i [array names optDefaults] {
|
||||
if [string compare "defaults" $mode] {
|
||||
set ret(-$i) [set $classOptions(-$i)]
|
||||
} else {
|
||||
set ret(-$i) $optDefaults($i)
|
||||
}
|
||||
}
|
||||
}
|
||||
otMkSectMethod $iclass conf_verify verify
|
||||
otMkSectMethod $iclass configure configure
|
||||
|
||||
set _optPriv(section,cget) 1
|
||||
set _optPriv(section,init) 1
|
||||
set _optPriv(section,initialize) 1
|
||||
set _optPriv(section,verify) 1
|
||||
set _optPriv(section,configure) 1
|
||||
}
|
||||
}
|
||||
|
||||
otMkSectMethod Base configure configure
|
||||
|
||||
# _optPriv is used for internal option handling house keeping
|
||||
# Note: checking for existence of a proc is not always a good idea,
|
||||
# since it may simply be a cached pointer to a inherited method.
|
||||
#
|
||||
Base method option { opt dflt args } {
|
||||
|
||||
classvar_of_class $iclass optDefaults classOptions _optPriv
|
||||
|
||||
set var [string range $opt 1 end]
|
||||
set optDefaults($var) $dflt
|
||||
set classOptions($opt) $var
|
||||
|
||||
array set tmp $args
|
||||
if ![info exists _optPriv(initialize)] {
|
||||
otMkOptHandl
|
||||
set _optPriv(initialize) 1
|
||||
}
|
||||
foreach i [array names tmp] {
|
||||
if ![info exists _optPriv(section,$i)] {
|
||||
otMkSectMethod $iclass $i $i
|
||||
set _optPriv(section,$i) 1
|
||||
}
|
||||
$iclass sys_method "$i:$opt" _val "
|
||||
instvar $var
|
||||
set _old_val \$[set var]
|
||||
set $var \$_val
|
||||
set ret \[catch {$tmp($i)} res\]
|
||||
if {\$ret != 0 && \$ret != 2 } {
|
||||
set $var \$_old_val
|
||||
return -code \$ret -errorinfo \$res \$res
|
||||
}
|
||||
return \$res
|
||||
"
|
||||
set _optPriv($i:$opt) 1
|
||||
}
|
||||
if ![info exists _optPriv(cget:$opt)] {
|
||||
$iclass sys_method "cget:$opt" {} "
|
||||
instvar $var
|
||||
return \$[set var]
|
||||
"
|
||||
set _optPriv(cget:$opt) 1
|
||||
}
|
||||
if ![info exists tmp(verify)] {
|
||||
$iclass sys_method "verify:$opt" _val "
|
||||
instvar $var
|
||||
set $var \$_val
|
||||
"
|
||||
set _optPriv(verify:$opt) 1
|
||||
}
|
||||
if ![info exists tmp(configure)] {
|
||||
$iclass sys_method "configure:$opt" _val "
|
||||
instvar $var
|
||||
set $var \$_val
|
||||
"
|
||||
set _optPriv(configure:$opt) 1
|
||||
}
|
||||
if ![info exists tmp(init)] {
|
||||
$iclass sys_method "init:$opt" _val {}
|
||||
set _optPriv(init:$opt) 1
|
||||
}
|
||||
}
|
||||
|
||||
# Default methods for non-compulsory
|
||||
# standard sections in an option definition:
|
||||
#
|
||||
Base sys_method init_unknown { opt val } {}
|
||||
Base sys_method verify_unknown { opt val } {}
|
||||
|
||||
# Catch initialize for classes which have no option handlers:
|
||||
#
|
||||
Base sys_method initialize {} {}
|
||||
|
||||
# Catch conf_init in case no option handlers have been defined.
|
||||
#
|
||||
Base sys_method conf_init {} {}
|
||||
|
||||
crunch_skip begin
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# class Widget
|
||||
# Base class for obTcl's Tk-widgets.
|
||||
#
|
||||
|
||||
DOC "class Widget (Tk) base class for widgets" {
|
||||
NAME
|
||||
Widget - A base class for mega-widgets
|
||||
|
||||
SYNOPSIS
|
||||
Widget new <obj> ?tk_widget_type? ?config options?
|
||||
Widget <obj> ?tk_widget_type? ?config options?
|
||||
|
||||
DESCRIPTION
|
||||
The widget class provides a base class for Tk-objects.
|
||||
This class knows about widget naming conventions, so, for example,
|
||||
destroying a Widget object will destroy any descendants of this object.
|
||||
|
||||
The `new' method need not be specified if the object name starts with a
|
||||
leading ".". Thus giving syntactical compatibility with Tk for
|
||||
creating widgets.
|
||||
|
||||
If `tk_widget_type' is not specified, the widget will be created as
|
||||
a `frame'. If the type is specified it must be one of the existing
|
||||
Tk-widget types, for example: button, radiobutton, text, etc.
|
||||
See the Tk documentation for available widget types.
|
||||
|
||||
The normal case is to use a frame as the base for a mega-widget.
|
||||
This is also the recommended way, since it results in the Tk class-name
|
||||
of the frame being automatically set to the objects class name -thus
|
||||
resulting in "winfo class <obj>" returning the mega-widget's class
|
||||
name.
|
||||
|
||||
In order to create mega-widgets, derive new classes from this class.
|
||||
|
||||
METHODS
|
||||
The following methods are defined in Widget:
|
||||
|
||||
init ?<args>? - Creates a frame widget, and configures it if any
|
||||
configuration options are present. Automatically
|
||||
invoked by the creation process, so there is no
|
||||
need to call it (provided that you use 'next' in
|
||||
the init-method of the derived class).
|
||||
|
||||
destroy - Destroys the object and associated tk-widget.
|
||||
For Tk-compatibility, the function `destroy' can be
|
||||
used instead, example:
|
||||
|
||||
destroy <obj>
|
||||
|
||||
Note: If you plan to mix Tk-widgets transparently
|
||||
with mega-widgets, you should use the _function_
|
||||
`destroy'.
|
||||
Any descendant objects of <obj> will also be
|
||||
destroyed (this goes for both Tk-widgets and
|
||||
mega-widgets).
|
||||
|
||||
set - Overrides the `set' method of the Base class to
|
||||
allow objects of type `scrollbar' to work correctly.
|
||||
|
||||
unknown - Overrides the `unknown' method of the Base class.
|
||||
Directs any unknown methods to the main frame of
|
||||
the Widget object.
|
||||
|
||||
unknown_opt - Overrides the same method from the Base class.
|
||||
Automatically called from the option handling system.
|
||||
Directs any unknown options to the main frame of the
|
||||
Widget object.
|
||||
|
||||
In addition, all non-shadowed methods from the Base class can be used.
|
||||
|
||||
Any method that cannot be resolved is passed on to the associated
|
||||
Tk-widget. This behaviour can be altered for any derived classes
|
||||
by defining a new `unknown' method (thus shadowing Widget's own
|
||||
`unknown' method). The same technique can be used to override
|
||||
the `unknown_opt' method.
|
||||
|
||||
EXAMPLES
|
||||
A simple example of deriving a class MegaButton which consists of
|
||||
a button widget initiated with the text "MEGA" (yes, I know, it's
|
||||
silly).
|
||||
|
||||
class MegaButton
|
||||
MegaButton inherit Widget
|
||||
|
||||
MegaButton method init { args } {
|
||||
#
|
||||
# Allow the Widget class to create a button for us
|
||||
# (we need to specify widget type `button')
|
||||
#
|
||||
eval next button $args
|
||||
|
||||
$self configure -text "MEGA"
|
||||
}
|
||||
|
||||
frame .f
|
||||
MegaButton .f.b -background red -foreground white
|
||||
pack .f .f.b
|
||||
|
||||
This example shows how to specify a Tk-widget type (button), although
|
||||
I advice against specifying anything (thus using a frame).
|
||||
See DESCRIPTION above for the reasoning behind this. Also note that
|
||||
`eval' is used to split $args into separate arguments for passing to
|
||||
the init method of the Widget class.
|
||||
|
||||
A more realistic example:
|
||||
|
||||
class ScrolledText
|
||||
ScrolledText inherit Widget
|
||||
|
||||
ScrolledText method init { args } {
|
||||
next
|
||||
|
||||
text $self.t -yscrollcommand "$self.sb set"
|
||||
scrollbar $self.sb -command "$self.t yview"
|
||||
|
||||
pack $self.sb -side right -fill y
|
||||
pack $self.t -side left
|
||||
|
||||
eval $self configure $args
|
||||
}
|
||||
|
||||
ScrolledText method unknown { args } {
|
||||
eval {$self.t $method} $args
|
||||
}
|
||||
|
||||
ScrolledText .st
|
||||
.st insert end [exec cat /etc/passwd]
|
||||
pack .st
|
||||
|
||||
This creates a new class, ScrolledText, containing a text window
|
||||
and a vertical scrollbar. It arranges for all unknown methods to
|
||||
be directed to the text widget; thus allowing `.st insert' to work
|
||||
normally (along with any other text methods).
|
||||
|
||||
NOTES
|
||||
Widget binds the "destroy" method to the <Destroy> event of
|
||||
the holding window, so be careful not to remove this binding
|
||||
inadvertently.
|
||||
}
|
||||
|
||||
crunch_skip end
|
||||
|
||||
class Widget
|
||||
|
||||
# init Create a tk-widget of specified type (or frame if not specified).
|
||||
# If the corresponding Tk-widget already exists, it will be used.
|
||||
# Otherwise the Tk-widget will be created.
|
||||
# The tk-widget will be named $self if $self has a leading ".",
|
||||
# otherwise a "." is prepended to $self to form the wigdet name.
|
||||
# The instvar `win' will contain the widgets window name, and
|
||||
# the instvar `wincmd' will contain the name of the widget's associated
|
||||
# command.
|
||||
|
||||
Widget method init args {
|
||||
instvar win wincmd
|
||||
|
||||
next
|
||||
|
||||
set first "[lindex $args 0]"
|
||||
set c1 "[string index $first 0]"
|
||||
if { ![string compare "" "$c1"] || ![string compare "-" "$c1"] } {
|
||||
set type frame
|
||||
set cl "-class $iclass"
|
||||
} else {
|
||||
set type $first
|
||||
set args [lrange $args 1 end]
|
||||
set cl ""
|
||||
}
|
||||
if [string compare "" [info commands $self-cmd]] {
|
||||
set win $self
|
||||
set wincmd $self-cmd
|
||||
} else {
|
||||
if ![string compare "." [string index $self 0]] {
|
||||
rename $self _ooTmp
|
||||
eval $type $self $cl $args
|
||||
rename $self $self-cmd
|
||||
rename _ooTmp $self
|
||||
set win $self
|
||||
set wincmd $self-cmd
|
||||
} else {
|
||||
eval $type .$self $cl $args
|
||||
set win .$self
|
||||
#set wincmd .$self-cmd
|
||||
set wincmd .$self
|
||||
}
|
||||
}
|
||||
bind $win <Destroy> "\
|
||||
if { !\[string compare \"%W\" \"$self\"\] && !\[catch {info args $self}\] } {
|
||||
$self destroy -obj_only }"
|
||||
|
||||
return $self
|
||||
}
|
||||
|
||||
# Just for the case when there are no option-handlers defined:
|
||||
#
|
||||
Widget sys_method configure args {
|
||||
instvar wincmd
|
||||
eval {$wincmd configure} $args
|
||||
}
|
||||
Widget sys_method cget opt {
|
||||
instvar wincmd
|
||||
eval {$wincmd cget} $opt
|
||||
}
|
||||
|
||||
Widget sys_method configure_unknown { opt args } {
|
||||
instvar wincmd
|
||||
eval {$wincmd configure $opt} $args
|
||||
}
|
||||
|
||||
Widget sys_method cget_unknown opt {
|
||||
instvar wincmd
|
||||
$wincmd cget $opt
|
||||
}
|
||||
Widget sys_method init_unknown { opt val } {
|
||||
puts "init_unknown: $opt $val (iclass=$iclass class=$class)"
|
||||
}
|
||||
|
||||
Widget sys_method unknown args {
|
||||
instvar wincmd
|
||||
eval {$wincmd $method} $args
|
||||
}
|
||||
|
||||
# Note: no "next" used! Does the `Base::destroy' stuff here for performance.
|
||||
#
|
||||
Widget method destroy args {
|
||||
|
||||
instvar win wincmd
|
||||
|
||||
# Must copy vars since they are destroyed by `otFreeObj'
|
||||
set wp $win
|
||||
set w $wincmd
|
||||
|
||||
otFreeObj $self
|
||||
catch {bind $w <Destroy> {}}
|
||||
if [string compare "-obj_only" $args] {
|
||||
if [string compare $w $wp] {
|
||||
rename $w $wp
|
||||
}
|
||||
if [string compare "-keepwin" $args] {
|
||||
destroy $wp
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# The method `set' defined here shadows the `set' method from Base.
|
||||
# This allows wrapper objects around Tk-scrollbars to work correctly.
|
||||
#
|
||||
Widget sys_method set args {
|
||||
instvar wincmd
|
||||
eval {$wincmd set} $args
|
||||
}
|
||||
|
||||
Widget sys_method base_set args {
|
||||
eval Base::set $args
|
||||
}
|
||||
|
||||
791
tcl/base8.tcl
791
tcl/base8.tcl
@ -1,791 +0,0 @@
|
||||
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" {$iclassVVcollectOptions values ret
|
||||
return [array get ret] }
|
||||
"defaults" {$iclassVVcollectOptions 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(\$classVV${sect}V\$i) 1
|
||||
if \[catch {\$classVV$sectV\$i \$Opts(\$i)} err\] {
|
||||
if \[catch {\$classVV${sect}_unknown\
|
||||
\$i \$Opts(\$i)}\] {
|
||||
unset _obTcl_unknBarred(\$classVV${sect}V\$i)
|
||||
error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
|
||||
\t\$err
|
||||
\"
|
||||
}
|
||||
}
|
||||
unset _obTcl_unknBarred(\$classVV${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 {$iclassVVcgetV\$opt} ret\] {
|
||||
if \[catch {\$classVVcget_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
|
||||
}
|
||||
|
||||
126
tcl/cscan.tcl
126
tcl/cscan.tcl
@ -1,126 +0,0 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# center scan. A convenience scan for the one and only Daniel Clemens
|
||||
# at TOPSI. Scans around a given ceter point. Requires the scan command
|
||||
# for TOPSI to work.
|
||||
#
|
||||
# another convenience scan:
|
||||
# sscan var1 start end var1 start end .... np preset
|
||||
# scans var1, var2 from start to end with np steps and a preset of preset
|
||||
#
|
||||
# Mark Koennecke, August, 22, 1997
|
||||
#-----------------------------------------------------------------------------
|
||||
proc cscan { var center delta np preset } {
|
||||
#------ start with some argument checking
|
||||
set t [SICSType $var]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is NOT drivable!" $var]
|
||||
return
|
||||
}
|
||||
set t [SICSType $center]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $center]
|
||||
return
|
||||
}
|
||||
set t [SICSType $delta]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $delta]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $np]
|
||||
return
|
||||
}
|
||||
set t [SICSType $preset]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $preset]
|
||||
return
|
||||
}
|
||||
#-------- store command in lastscancommand
|
||||
set txt [format "cscan %s %s %s %s %s" $var $center \
|
||||
$delta $np $preset]
|
||||
catch {lastscancommand $txt}
|
||||
#-------- set standard parameters
|
||||
scan clear
|
||||
scan preset $preset
|
||||
scan np [expr $np*2 + 1]
|
||||
#--------- calculate start
|
||||
set start [expr $center - $np * $delta]
|
||||
set ret [catch {scan var $var $start $delta} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
#---------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc sscan args {
|
||||
scan clear
|
||||
#------- check arguments: the last two must be preset and np!
|
||||
set l [llength $args]
|
||||
if { $l < 5} {
|
||||
ClientPut "ERROR: Insufficient number of arguments to sscan"
|
||||
return
|
||||
}
|
||||
set preset [lindex $args [expr $l - 1]]
|
||||
set np [lindex $args [expr $l - 2]]
|
||||
set t [SICSType $preset]
|
||||
ClientPut $t
|
||||
ClientPut [string first $t "NUM"]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for preset, got %s" \
|
||||
$preset]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for np, got %s" \
|
||||
$np]
|
||||
return
|
||||
}
|
||||
scan preset $preset
|
||||
scan np $np
|
||||
#--------- do variables
|
||||
set nvar [expr ($l - 2) / 3]
|
||||
for { set i 0 } { $i < $nvar} { incr i } {
|
||||
set var [lindex $args [expr $i * 3]]
|
||||
set t [SICSType $var]
|
||||
if {[string compare $t DRIV] != 0} {
|
||||
ClientPut [format "ERROR: %s is not drivable" $var]
|
||||
return
|
||||
}
|
||||
set start [lindex $args [expr ($i * 3) + 1]]
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for start, got %s" \
|
||||
$start]
|
||||
return
|
||||
}
|
||||
set end [lindex $args [expr ($i * 3) + 2]]
|
||||
set t [SICSType $end]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for end, got %s" \
|
||||
$end]
|
||||
return
|
||||
}
|
||||
#--------- do scan parameters
|
||||
set step [expr double($end - $start)/double($np)]
|
||||
set ret [catch {scan var $var $start $step} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
}
|
||||
#------------- set lastcommand text
|
||||
set txt [format "sscan %s" [join $args]]
|
||||
catch {lastscancommand $txt}
|
||||
#------------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
297
tcl/inherit.tcl
297
tcl/inherit.tcl
@ -1,297 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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 *::$i]
|
||||
eval lappend tmp [array names _obTcl_Cached *::${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 *::* 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 *::* $name] {
|
||||
set tmp [split $name :]
|
||||
set class [lindex $tmp 0]
|
||||
set func [join [lrange $tmp 2 end] :]
|
||||
|
||||
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}::$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::${method}_next args $tmp
|
||||
} else {
|
||||
proc $class::${method}_next args return
|
||||
}
|
||||
set _obTcl_Cached(${class}::${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}::${method}_next)] {
|
||||
otNextPrepare
|
||||
}
|
||||
|
||||
incr _obTcl_Cnt 1
|
||||
set ret [catch {uplevel 1 {${class}::${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::$func]] &&
|
||||
![info exists _obTcl_Cached(${class}::$func)] } {
|
||||
return "$class::$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::$func"
|
||||
}
|
||||
|
||||
297
tcl/inherit8.tcl
297
tcl/inherit8.tcl
@ -1,297 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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 $classVV${method}_next args $tmp
|
||||
} else {
|
||||
proc $classVV${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 $classVV$func]] &&
|
||||
![info exists _obTcl_Cached(${class}VV$func)] } {
|
||||
return "$classVV$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 $classVV$func"
|
||||
}
|
||||
|
||||
616
tcl/init.tcl
616
tcl/init.tcl
@ -1,616 +0,0 @@
|
||||
# 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
|
||||
#
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
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 7.6
|
||||
#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
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
293
tcl/init8.c
293
tcl/init8.c
@ -1,293 +0,0 @@
|
||||
#include <tcl.h>
|
||||
static char init_tcl[] =
|
||||
"# init.tcl --\n#\n# Default system startup file for Tcl-based appli"
|
||||
"cations. Defines\n# \"unknown\" procedure and auto-load facilities."
|
||||
"\n#\n# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28\n#\n# Copyright (c)"
|
||||
" 1991-1993 The Regents of the University of California.\n# Copyrig"
|
||||
"ht (c) 1994-1996 Sun Microsystems, Inc.\n#\n# See the file \"license"
|
||||
".terms\" for information on usage and redistribution\n# of this fil"
|
||||
"e, and for a DISCLAIMER OF ALL WARRANTIES.\n#\n#-------------------"
|
||||
"---------------------------------------------------------\n#\n# Mod"
|
||||
"ified by Mark Koennecke in order to redirect unknown into the Sic"
|
||||
"s\n# mechanism. Thereby disabling command shortcuts and execution "
|
||||
"of shell\n# commands for security reasons.\n#\n# February 1997\n# Hac"
|
||||
"ked for Tcl 8.0 September 1997, bad hack if problems start anew\n#"
|
||||
"\n#---------------------------------------------------------------"
|
||||
"------------\n \nif {[info commands package] == \"\"} {\n error \"ve"
|
||||
"rsion mismatch: library\\nscripts expect Tcl version 7.5b1 or late"
|
||||
"r but the loaded version is\\nonly [info patchlevel]\"\n}\npackage re"
|
||||
"quire -exact Tcl 8.0\n#if [catch {set auto_path $env(TCLLIBPATH)}]"
|
||||
" {\n# set auto_path \"\"\n#}\nif {[lsearch -exact $auto_path [info "
|
||||
"library]] < 0} {\n lappend auto_path [info library]\n}\ncatch {\n "
|
||||
" foreach dir $tcl_pkgPath {\n\tif {[lsearch -exact $auto_path $di"
|
||||
"r] < 0} {\n\t lappend auto_path $dir\n\t}\n }\n unset dir\n}\npa"
|
||||
"ckage unknown tclPkgUnknown\n\n# Some machines, such as the Macinto"
|
||||
"sh, do not have exec. Also, on all\n# platforms, safe interpreters"
|
||||
" do not have exec.\n# exec hereby disabled for Security reasons! M"
|
||||
"K\n set auto_noexec 1\n\n\nset errorCode \"\"\nset errorInfo \"\"\n\n# un"
|
||||
"known --\n# This procedure is called when a Tcl command is invoked"
|
||||
" that doesn't\n# exist in the interpreter. It takes the following"
|
||||
" steps to make the\n# command available:\n#\n#\t1. See if the autoloa"
|
||||
"d facility can locate the command in a\n#\t Tcl script file. If "
|
||||
"so, load it and execute it.\n#\t2. If the command was invoked inter"
|
||||
"actively at top-level:\n#\t (a) see if the command exists as an "
|
||||
"executable UNIX program.\n#\t\tIf so, \"exec\" the command.\n#\t (b) "
|
||||
"see if the command requests csh-like history substitution\n#\t\tin o"
|
||||
"ne of the common forms !!, !<number>, or ^old^new. If\n#\t\tso, emu"
|
||||
"late csh's history substitution.\n#\t (c) see if the command is "
|
||||
"a unique abbreviation for another\n#\t\tcommand. If so, invoke the "
|
||||
"command.\n#\n# Arguments:\n# args -\tA list whose elements are the wo"
|
||||
"rds of the original\n#\t\tcommand, including the command name.\n\nproc"
|
||||
" unknown args {\n global auto_noexec auto_noload env unknown_pe"
|
||||
"nding tcl_interactive\n global errorCode errorInfo\n\n # Save "
|
||||
"the values of errorCode and errorInfo variables, since they\n #"
|
||||
" may get modified if caught errors occur below. The variables wi"
|
||||
"ll\n # be restored just before re-executing the missing command"
|
||||
".\n\n set savedErrorCode $errorCode\n set savedErrorInfo $erro"
|
||||
"rInfo\n set name [lindex $args 0]\n if ![info exists auto_nol"
|
||||
"oad] {\n\t#\n\t# Make sure we're not trying to load the same proc twi"
|
||||
"ce.\n\t#\n\tif [info exists unknown_pending($name)] {\n\t return -co"
|
||||
"de error \"self-referential recursion in \\\"unknown\\\" for command \\"
|
||||
"\"$name\\\"\";\n\t}\n\tset unknown_pending($name) pending;\n\tset ret [catc"
|
||||
"h {auto_load $name} msg]\n\tunset unknown_pending($name);\n\tif {$ret"
|
||||
" != 0} {\n\t return -code $ret -errorcode $errorCode \\\n\t\t\"error "
|
||||
"while autoloading \\\"$name\\\": $msg\"\n\t}\n\tif ![array size unknown_pe"
|
||||
"nding] {\n\t unset unknown_pending\n\t}\n\tif $msg {\n\t set errorC"
|
||||
"ode $savedErrorCode\n\t set errorInfo $savedErrorInfo\n\t set c"
|
||||
"ode [catch {uplevel $args} msg]\n\t if {$code == 1} {\n\t\t#\n\t\t# S"
|
||||
"trip the last five lines off the error stack (they're\n\t\t# from th"
|
||||
"e \"uplevel\" command).\n\t\t#\n\n\t\tset new [split $errorInfo \\n]\n\t\tset "
|
||||
"new [join [lrange $new 0 [expr [llength $new] - 6]] \\n]\n\t\treturn "
|
||||
"-code error -errorcode $errorCode \\\n\t\t\t-errorinfo $new $msg\n\t "
|
||||
"} else {\n\t\treturn -code $code $msg\n\t }\n\t}\n }\n \n # Try"
|
||||
" running SICS for a change\n set ret [catch {uplevel #0 SicsUnk"
|
||||
"nown $args} msg]\n if {$ret == 1} {\n return -code error "
|
||||
"$msg\n } else {\n return -code ok $msg\n }\n}\n\n# auto_lo"
|
||||
"ad --\n# Checks a collection of library directories to see if a pr"
|
||||
"ocedure\n# is defined in one of them. If so, it sources the appro"
|
||||
"priate\n# library file to create the procedure. Returns 1 if it s"
|
||||
"uccessfully\n# loaded the procedure, 0 otherwise.\n#\n# Arguments: \n"
|
||||
"# cmd -\t\t\tName of the command to find and load.\n\nproc auto_load c"
|
||||
"md {\n global auto_index auto_oldpath auto_path env errorInfo e"
|
||||
"rrorCode\n\n if [info exists auto_index($cmd)] {\n\tuplevel #0 $au"
|
||||
"to_index($cmd)\n\treturn [expr {[info commands $cmd] != \"\"}]\n }\n"
|
||||
" if ![info exists auto_path] {\n\treturn 0\n }\n if [info ex"
|
||||
"ists auto_oldpath] {\n\tif {$auto_oldpath == $auto_path} {\n\t ret"
|
||||
"urn 0\n\t}\n }\n set auto_oldpath $auto_path\n for {set i [ex"
|
||||
"pr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {\n\tset dir [l"
|
||||
"index $auto_path $i]\n\tset f \"\"\n\tif [catch {set f [open [file join"
|
||||
" $dir tclIndex]]}] {\n\t continue\n\t}\n\tset error [catch {\n\t se"
|
||||
"t id [gets $f]\n\t if {$id == \"# Tcl autoload index file, versio"
|
||||
"n 2.0\"} {\n\t\teval [read $f]\n\t } elseif {$id == \"# Tcl autoload "
|
||||
"index file: each line identifies a Tcl\"} {\n\t\twhile {[gets $f line"
|
||||
"] >= 0} {\n\t\t if {([string index $line 0] == \"#\")\n\t\t\t || ([l"
|
||||
"length $line] != 2)} {\n\t\t\tcontinue\n\t\t }\n\t\t set name [lindex"
|
||||
" $line 0]\n\t\t set auto_index($name) \\\n\t\t\t\"source [file join $di"
|
||||
"r [lindex $line 1]]\"\n\t\t}\n\t } else {\n\t\terror \"[file join $dir t"
|
||||
"clIndex] isn't a proper Tcl index file\"\n\t }\n\t} msg]\n\tif {$f !="
|
||||
" \"\"} {\n\t close $f\n\t}\n\tif $error {\n\t error $msg $errorInfo $"
|
||||
"errorCode\n\t}\n }\n if [info exists auto_index($cmd)] {\n\tuplev"
|
||||
"el #0 $auto_index($cmd)\n\tif {[info commands $cmd] != \"\"} {\n\t r"
|
||||
"eturn 1\n\t}\n }\n return 0\n}\n\nif {[string compare $tcl_platfor"
|
||||
"m(platform) windows] == 0} {\n\n# auto_execok --\n#\n# Returns string"
|
||||
" that indicates name of program to execute if \n# name corresponds"
|
||||
" to a shell builtin or an executable in the\n# Windows search path"
|
||||
", or \"\" otherwise. Builds an associative \n# array auto_execs tha"
|
||||
"t caches information about previous checks, \n# for speed.\n#\n# Arg"
|
||||
"uments: \n# name -\t\t\tName of a command.\n\n# Windows version.\n#\n# No"
|
||||
"te that info executable doesn't work under Windows, so we have to"
|
||||
"\n# look for files with .exe, .com, or .bat extensions. Also, the"
|
||||
" path\n# may be in the Path or PATH environment variables, and pat"
|
||||
"h\n# components are separated with semicolons, not colons as under"
|
||||
" Unix.\n#\nproc auto_execok name {\n global auto_execs env tcl_pl"
|
||||
"atform\n\n if [info exists auto_execs($name)] {\n\treturn $auto_ex"
|
||||
"ecs($name)\n }\n set auto_execs($name) \"\"\n\n if {[lsearch -"
|
||||
"exact {cls copy date del erase dir echo mkdir md rename \n\t ren"
|
||||
" rmdir rd time type ver vol} $name] != -1} {\n\tif {[info exists en"
|
||||
"v(COMSPEC)]} {\n\t set comspec $env(COMSPEC) \n\t} elseif {[info e"
|
||||
"xists env(ComSpec)]} {\n\t set comspec $env(ComSpec)\n\t} elseif {"
|
||||
"$tcl_platform(os) == \"Windows NT\"} {\n\t set comspec \"cmd.exe\"\n\t"
|
||||
"} else {\n\t set comspec \"command.com\"\n\t}\n\treturn [set auto_exec"
|
||||
"s($name) [list $comspec /c $name]]\n }\n\n if {[llength [file "
|
||||
"split $name]] != 1} {\n\tforeach ext {{} .com .exe .bat} {\n\t set"
|
||||
" file ${name}${ext}\n\t if {[file exists $file] && ![file isdire"
|
||||
"ctory $file]} {\n\t\treturn [set auto_execs($name) $file]\n\t }\n\t}\n"
|
||||
"\treturn \"\"\n }\n\n set path \"[file dirname [info nameof]];.;\"\n"
|
||||
" if {[info exists env(WINDIR)]} {\n\tset windir $env(WINDIR) \n "
|
||||
" } elseif {[info exists env(windir)]} {\n\tset windir $env(windir)"
|
||||
"\n }\n if {[info exists windir]} {\n\tif {$tcl_platform(os) == "
|
||||
"\"Windows NT\"} {\n\t append path \"$windir/system32;\"\n\t}\n\tappend p"
|
||||
"ath \"$windir/system;$windir;\"\n }\n\n if {! [info exists env(P"
|
||||
"ATH)]} {\n\tif [info exists env(Path)] {\n\t append path $env(Path"
|
||||
")\n\t} else {\n\t return \"\"\n\t}\n } else {\n\tappend path $env(PATH"
|
||||
")\n }\n\n foreach dir [split $path {;}] {\n\tif {$dir == \"\"} {\n\t"
|
||||
" set dir .\n\t}\n\tforeach ext {{} .com .exe .bat} {\n\t set file"
|
||||
" [file join $dir ${name}${ext}]\n\t if {[file exists $file] && !"
|
||||
"[file isdirectory $file]} {\n\t\treturn [set auto_execs($name) $file"
|
||||
"]\n\t }\n\t}\n }\n return \"\"\n}\n\n} else {\n\n# auto_execok --\n#\n#"
|
||||
" Returns string that indicates name of program to execute if \n# n"
|
||||
"ame corresponds to an executable in the path. Builds an associati"
|
||||
"ve \n# array auto_execs that caches information about previous che"
|
||||
"cks, \n# for speed.\n#\n# Arguments: \n# name -\t\t\tName of a command.\n"
|
||||
"\n# Unix version.\n#\nproc auto_execok name {\n global auto_execs "
|
||||
"env\n\n if [info exists auto_execs($name)] {\n\treturn $auto_execs"
|
||||
"($name)\n }\n set auto_execs($name) \"\"\n if {[llength [file"
|
||||
" split $name]] != 1} {\n\tif {[file executable $name] && ![file isd"
|
||||
"irectory $name]} {\n\t set auto_execs($name) $name\n\t}\n\treturn $a"
|
||||
"uto_execs($name)\n }\n foreach dir [split $env(PATH) :] {\n\tif"
|
||||
" {$dir == \"\"} {\n\t set dir .\n\t}\n\tset file [file join $dir $name"
|
||||
"]\n\tif {[file executable $file] && ![file isdirectory $file]} {\n\t "
|
||||
" set auto_execs($name) $file\n\t return $file\n\t}\n }\n ret"
|
||||
"urn \"\"\n}\n\n}\n# auto_reset --\n# Destroy all cached information for "
|
||||
"auto-loading and auto-execution,\n# so that the information gets r"
|
||||
"ecomputed the next time it's needed.\n# Also delete any procedures"
|
||||
" that are listed in the auto-load index\n# except those defined in"
|
||||
" this file.\n#\n# Arguments: \n# None.\n\nproc auto_reset {} {\n glo"
|
||||
"bal auto_execs auto_index auto_oldpath\n foreach p [info procs]"
|
||||
" {\n\tif {[info exists auto_index($p)] && ![string match auto_* $p]"
|
||||
"\n\t\t&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup\n\t\t\ttclPkg"
|
||||
"Unknown} $p] < 0)} {\n\t rename $p {}\n\t}\n }\n catch {unset "
|
||||
"auto_execs}\n catch {unset auto_index}\n catch {unset auto_ol"
|
||||
"dpath}\n}\n\n# auto_mkindex --\n# Regenerate a tclIndex file from Tcl"
|
||||
" source files. Takes as argument\n# the name of the directory in "
|
||||
"which the tclIndex file is to be placed,\n# followed by any number"
|
||||
" of glob patterns to use in that directory to\n# locate all of the"
|
||||
" relevant files.\n#\n# Arguments: \n# dir -\t\t\tName of the directory "
|
||||
"in which to create an index.\n# args -\t\tAny number of additional a"
|
||||
"rguments giving the\n#\t\t\tnames of files within dir. If no additio"
|
||||
"nal\n#\t\t\tare given auto_mkindex will look for *.tcl.\n\nproc auto_mk"
|
||||
"index {dir args} {\n global errorCode errorInfo\n set oldDir "
|
||||
"[pwd]\n cd $dir\n set dir [pwd]\n append index \"# Tcl autol"
|
||||
"oad index file, version 2.0\\n\"\n append index \"# This file is g"
|
||||
"enerated by the \\\"auto_mkindex\\\" command\\n\"\n append index \"# a"
|
||||
"nd sourced to set up indexing information for one or\\n\"\n appen"
|
||||
"d index \"# more commands. Typically each line is a command that\\"
|
||||
"n\"\n append index \"# sets an element in the auto_index array, w"
|
||||
"here the\\n\"\n append index \"# element name is the name of a com"
|
||||
"mand and the value is\\n\"\n append index \"# a script that loads "
|
||||
"the command.\\n\\n\"\n if {$args == \"\"} {\n\tset args *.tcl\n }\n "
|
||||
" foreach file [eval glob $args] {\n\tset f \"\"\n\tset error [catch {\n"
|
||||
"\t set f [open $file]\n\t while {[gets $f line] >= 0} {\n\t\tif ["
|
||||
"regexp {^proc[ \t]+([^ \t]*)} $line match procName] {\n\t\t append "
|
||||
"index \"set [list auto_index($procName)]\"\n\t\t append index \" \\[l"
|
||||
"ist source \\[file join \\$dir [list $file]\\]\\]\\n\"\n\t\t}\n\t }\n\t "
|
||||
"close $f\n\t} msg]\n\tif $error {\n\t set code $errorCode\n\t set i"
|
||||
"nfo $errorInfo\n\t catch {close $f}\n\t cd $oldDir\n\t error $"
|
||||
"msg $info $code\n\t}\n }\n set f \"\"\n set error [catch {\n\tset"
|
||||
" f [open tclIndex w]\n\tputs $f $index nonewline\n\tclose $f\n\tcd $old"
|
||||
"Dir\n } msg]\n if $error {\n\tset code $errorCode\n\tset info $er"
|
||||
"rorInfo\n\tcatch {close $f}\n\tcd $oldDir\n\terror $msg $info $code\n "
|
||||
" }\n}\n\n# pkg_mkIndex --\n# This procedure creates a package index i"
|
||||
"n a given directory. The\n# package index consists of a \"pkgIndex"
|
||||
".tcl\" file whose contents are\n# a Tcl script that sets up package"
|
||||
" information with \"package require\"\n# commands. The commands des"
|
||||
"cribe all of the packages defined by the\n# files given as argumen"
|
||||
"ts.\n#\n# Arguments:\n# dir -\t\t\tName of the directory in which to cr"
|
||||
"eate the index.\n# args -\t\tAny number of additional arguments, eac"
|
||||
"h giving\n#\t\t\ta glob pattern that matches the names of one or\n#\t\t\t"
|
||||
"more shared libraries or Tcl script files in\n#\t\t\tdir.\n\nproc pkg_m"
|
||||
"kIndex {dir args} {\n global errorCode errorInfo\n append ind"
|
||||
"ex \"# Tcl package index file, version 1.0\\n\"\n append index \"# "
|
||||
"This file is generated by the \\\"pkg_mkIndex\\\" command\\n\"\n appe"
|
||||
"nd index \"# and sourced either when an application starts up or\\n"
|
||||
"\"\n append index \"# by a \\\"package unknown\\\" script. It invoke"
|
||||
"s the\\n\"\n append index \"# \\\"package ifneeded\\\" command to set "
|
||||
"up package-related\\n\"\n append index \"# information so that pac"
|
||||
"kages will be loaded automatically\\n\"\n append index \"# in resp"
|
||||
"onse to \\\"package require\\\" commands. When this\\n\"\n append in"
|
||||
"dex \"# script is sourced, the variable \\$dir must contain the\\n\"\n"
|
||||
" append index \"# full path name of this file's directory.\\n\"\n "
|
||||
" set oldDir [pwd]\n cd $dir\n foreach file [eval glob $args"
|
||||
"] {\n\t# For each file, figure out what commands and packages it pr"
|
||||
"ovides.\n\t# To do this, create a child interpreter, load the file "
|
||||
"into the\n\t# interpreter, and get a list of the new commands and p"
|
||||
"ackages\n\t# that are defined. Define an empty \"package unknown\" s"
|
||||
"cript so\n\t# that there are no recursive package inclusions.\n\n\tset"
|
||||
" c [interp create]\n\n\t# If Tk is loaded in the parent interpreter,"
|
||||
" load it into the\n\t# child also, in case the extension depends on"
|
||||
" it.\n\n\tforeach pkg [info loaded] {\n\t if {[lindex $pkg 1] == \"T"
|
||||
"k\"} {\n\t\t$c eval {set argv {-geometry +0+0}}\n\t\tload [lindex $pkg 0"
|
||||
"] Tk $c\n\t\tbreak\n\t }\n\t}\n\t$c eval [list set file $file]\n\tif [cat"
|
||||
"ch {\n\t $c eval {\n\t\tproc dummy args {}\n\t\tpackage unknown dummy\n"
|
||||
"\t\tset origCmds [info commands]\n\t\tset dir \"\"\t\t;# in case file is p"
|
||||
"kgIndex.tcl\n\t\tset pkgs \"\"\n\n\t\t# Try to load the file if it has the"
|
||||
" shared library extension,\n\t\t# otherwise source it. It's importa"
|
||||
"nt not to try to load\n\t\t# files that aren't shared libraries, bec"
|
||||
"ause on some systems\n\t\t# (like SunOS) the loader will abort the w"
|
||||
"hole application\n\t\t# when it gets an error.\n\n\t\tif {[string compar"
|
||||
"e [file extension $file] \\\n\t\t\t[info sharedlibextension]] == 0} {\n"
|
||||
"\n\t\t # The \"file join .\" command below is necessary. Without\n\t"
|
||||
"\t # it, if the file name has no \\'s and we're on UNIX, the\n\t\t "
|
||||
" # load command will invoke the LD_LIBRARY_PATH search\n\t\t # "
|
||||
"mechanism, which could cause the wrong file to be used.\n\n\t\t lo"
|
||||
"ad [file join . $file]\n\t\t set type load\n\t\t} else {\n\t\t sourc"
|
||||
"e $file\n\t\t set type source\n\t\t}\n\t\tforeach i [info commands] {\n\t"
|
||||
"\t set cmds($i) 1\n\t\t}\n\t\tforeach i $origCmds {\n\t\t catch {unse"
|
||||
"t cmds($i)}\n\t\t}\n\t\tforeach i [package names] {\n\t\t if {([string "
|
||||
"compare [package provide $i] \"\"] != 0)\n\t\t\t && ([string compare"
|
||||
" $i Tcl] != 0)\n\t\t\t && ([string compare $i Tk] != 0)} {\n\t\t\tlapp"
|
||||
"end pkgs [list $i [package provide $i]]\n\t\t }\n\t\t}\n\t }\n\t} msg"
|
||||
"] {\n\t puts \"error while loading or sourcing $file: $msg\"\n\t}\n\tf"
|
||||
"oreach pkg [$c eval set pkgs] {\n\t lappend files($pkg) [list $f"
|
||||
"ile [$c eval set type] \\\n\t\t [lsort [$c eval array names cmds]]"
|
||||
"]\n\t}\n\tinterp delete $c\n }\n foreach pkg [lsort [array names "
|
||||
"files]] {\n\tappend index \"\\npackage ifneeded $pkg\\\n\t\t\\[list tclPkg"
|
||||
"Setup \\$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\\\n\t\t[list $files($"
|
||||
"pkg)]\\]\"\n }\n set f [open pkgIndex.tcl w]\n puts $f $index"
|
||||
"\n close $f\n cd $oldDir\n}\n\n# tclPkgSetup --\n# This is a util"
|
||||
"ity procedure use by pkgIndex.tcl files. It is invoked\n# as part"
|
||||
" of a \"package ifneeded\" script. It calls \"package provide\"\n# to"
|
||||
" indicate that a package is available, then sets entries in the\n#"
|
||||
" auto_index array so that the package's files will be auto-loaded"
|
||||
" when\n# the commands are used.\n#\n# Arguments:\n# dir -\t\t\tDirectory"
|
||||
" containing all the files for this package.\n# pkg -\t\t\tName of the"
|
||||
" package (no version number).\n# version -\t\tVersion number for the"
|
||||
" package, such as 2.1.3.\n# files -\t\tList of files that constitute"
|
||||
" the package. Each\n#\t\t\telement is a sub-list with three elements"
|
||||
". The first\n#\t\t\tis the name of a file relative to $dir, the seco"
|
||||
"nd is\n#\t\t\t\"load\" or \"source\", indicating whether the file is a\n#\t"
|
||||
"\t\tloadable binary or a script to source, and the third\n#\t\t\tis a l"
|
||||
"ist of commands defined by this file.\n\nproc tclPkgSetup {dir pkg "
|
||||
"version files} {\n global auto_index\n\n package provide $pkg "
|
||||
"$version\n foreach fileInfo $files {\n\tset f [lindex $fileInfo 0"
|
||||
"]\n\tset type [lindex $fileInfo 1]\n\tforeach cmd [lindex $fileInfo 2"
|
||||
"] {\n\t if {$type == \"load\"} {\n\t\tset auto_index($cmd) [list load"
|
||||
" [file join $dir $f] $pkg]\n\t } else {\n\t\tset auto_index($cmd) ["
|
||||
"list source [file join $dir $f]]\n\t } \n\t}\n }\n}\n\n# tclMacPkgS"
|
||||
"earch --\n# The procedure is used on the Macintosh to search a giv"
|
||||
"en directory for files\n# with a TEXT resource named \"pkgIndex\". "
|
||||
"If it exists it is sourced in to the\n# interpreter to setup the p"
|
||||
"ackage database.\n\nproc tclMacPkgSearch {dir} {\n foreach x [glo"
|
||||
"b -nocomplain [file join $dir *.shlb]] {\n\tif [file isfile $x] {\n\t"
|
||||
" set res [resource open $x]\n\t foreach y [resource list TEXT"
|
||||
" $res] {\n\t\tif {$y == \"pkgIndex\"} {source -rsrc pkgIndex}\n\t }\n\t"
|
||||
" resource close $res\n\t}\n }\n}\n\n# tclPkgUnknown --\n# This pro"
|
||||
"cedure provides the default for the \"package unknown\" function.\n#"
|
||||
" It is invoked when a package that's needed can't be found. It s"
|
||||
"cans\n# the auto_path directories and their immediate children loo"
|
||||
"king for\n# pkgIndex.tcl files and sources any such files that are"
|
||||
" found to setup\n# the package database. (On the Macintosh we als"
|
||||
"o search for pkgIndex\n# TEXT resources in all files.)\n#\n# Argumen"
|
||||
"ts:\n# name -\t\tName of desired package. Not used.\n# version -\t\tVe"
|
||||
"rsion of desired package. Not used.\n# exact -\t\tEither \"-exact\" o"
|
||||
"r omitted. Not used.\n\nproc tclPkgUnknown {name version {exact {}"
|
||||
"}} {\n global auto_path tcl_platform env\n\n if ![info exists "
|
||||
"auto_path] {\n\treturn\n }\n for {set i [expr [llength $auto_pa"
|
||||
"th] - 1]} {$i >= 0} {incr i -1} {\n\tset dir [lindex $auto_path $i]"
|
||||
"\n\tset file [file join $dir pkgIndex.tcl]\n\tif [file readable $file"
|
||||
"] {\n\t source $file\n\t}\n\tforeach file [glob -nocomplain [file jo"
|
||||
"in $dir * pkgIndex.tcl]] {\n\t if [file readable $file] {\n\t\tset "
|
||||
"dir [file dirname $file]\n\t\tsource $file\n\t }\n\t}\n\t# On the Macin"
|
||||
"tosh we also look in the resource fork \n\t# of shared libraries\n\ti"
|
||||
"f {$tcl_platform(platform) == \"macintosh\"} {\n\t set dir [lindex"
|
||||
" $auto_path $i]\n\t tclMacPkgSearch $dir\n\t foreach x [glob -n"
|
||||
"ocomplain [file join $dir *]] {\n\t\tif [file isdirectory $x] {\n\t\t "
|
||||
" set dir $x\n\t\t tclMacPkgSearch $dir\n\t\t}\n\t }\n\t}\n }\n}\n"
|
||||
;
|
||||
int init_Init(Tcl_Interp* interp)
|
||||
{
|
||||
Tcl_SetVar(interp, "package_name", "init", TCL_GLOBAL_ONLY);
|
||||
if (Tcl_GlobalEval(interp, init_tcl) != TCL_OK) return TCL_ERROR;
|
||||
Tcl_UnsetVar(interp, "package_name", TCL_GLOBAL_ONLY);
|
||||
return TCL_OK;
|
||||
}
|
||||
617
tcl/init8.tcl
617
tcl/init8.tcl
@ -1,617 +0,0 @@
|
||||
# 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
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
292
tcl/initcl.c
292
tcl/initcl.c
@ -1,292 +0,0 @@
|
||||
#include <tcl.h>
|
||||
static char init_tcl[] =
|
||||
"# init.tcl --\n#\n# Default system startup file for Tcl-based appli"
|
||||
"cations. Defines\n# \"unknown\" procedure and auto-load facilities."
|
||||
"\n#\n# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28\n#\n# Copyright (c)"
|
||||
" 1991-1993 The Regents of the University of California.\n# Copyrig"
|
||||
"ht (c) 1994-1996 Sun Microsystems, Inc.\n#\n# See the file \"license"
|
||||
".terms\" for information on usage and redistribution\n# of this fil"
|
||||
"e, and for a DISCLAIMER OF ALL WARRANTIES.\n#\n#-------------------"
|
||||
"---------------------------------------------------------\n#\n# Mod"
|
||||
"ified by Mark Koennecke in order to redirect unknown into the Sic"
|
||||
"s\n# mechanism. Thereby disabling command shortcuts and execution "
|
||||
"of shell\n# commands for security reasons.\n#\n# February 1997\n#\n#--"
|
||||
"-----------------------------------------------------------------"
|
||||
"--------\n \nif {[info commands package] == \"\"} {\n error \"versio"
|
||||
"n mismatch: library\\nscripts expect Tcl version 7.5b1 or later bu"
|
||||
"t the loaded version is\\nonly [info patchlevel]\"\n}\npackage requir"
|
||||
"e -exact Tcl 7.6\n#if [catch {set auto_path $env(TCLLIBPATH)}] {\n#"
|
||||
" set auto_path \"\"\n#}\nif {[lsearch -exact $auto_path [info libr"
|
||||
"ary]] < 0} {\n lappend auto_path [info library]\n}\ncatch {\n f"
|
||||
"oreach dir $tcl_pkgPath {\n\tif {[lsearch -exact $auto_path $dir] <"
|
||||
" 0} {\n\t lappend auto_path $dir\n\t}\n }\n unset dir\n}\npackag"
|
||||
"e unknown tclPkgUnknown\n\n# Some machines, such as the Macintosh, "
|
||||
"do not have exec. Also, on all\n# platforms, safe interpreters do "
|
||||
"not have exec.\n# exec hereby disabled for Security reasons! MK\n "
|
||||
" set auto_noexec 1\n\n\nset errorCode \"\"\nset errorInfo \"\"\n\n# unknow"
|
||||
"n --\n# This procedure is called when a Tcl command is invoked tha"
|
||||
"t doesn't\n# exist in the interpreter. It takes the following ste"
|
||||
"ps to make the\n# command available:\n#\n#\t1. See if the autoload fa"
|
||||
"cility can locate the command in a\n#\t Tcl script file. If so, "
|
||||
"load it and execute it.\n#\t2. If the command was invoked interacti"
|
||||
"vely at top-level:\n#\t (a) see if the command exists as an exec"
|
||||
"utable UNIX program.\n#\t\tIf so, \"exec\" the command.\n#\t (b) see "
|
||||
"if the command requests csh-like history substitution\n#\t\tin one o"
|
||||
"f the common forms !!, !<number>, or ^old^new. If\n#\t\tso, emulate"
|
||||
" csh's history substitution.\n#\t (c) see if the command is a un"
|
||||
"ique abbreviation for another\n#\t\tcommand. If so, invoke the comm"
|
||||
"and.\n#\n# Arguments:\n# args -\tA list whose elements are the words "
|
||||
"of the original\n#\t\tcommand, including the command name.\n\nproc unk"
|
||||
"nown args {\n global auto_noexec auto_noload env unknown_pendin"
|
||||
"g tcl_interactive\n global errorCode errorInfo\n\n # Save the "
|
||||
"values of errorCode and errorInfo variables, since they\n # may"
|
||||
" get modified if caught errors occur below. The variables will\n "
|
||||
" # be restored just before re-executing the missing command.\n\n "
|
||||
" set savedErrorCode $errorCode\n set savedErrorInfo $errorInf"
|
||||
"o\n set name [lindex $args 0]\n if ![info exists auto_noload]"
|
||||
" {\n\t#\n\t# Make sure we're not trying to load the same proc twice.\n"
|
||||
"\t#\n\tif [info exists unknown_pending($name)] {\n\t return -code e"
|
||||
"rror \"self-referential recursion in \\\"unknown\\\" for command \\\"$na"
|
||||
"me\\\"\";\n\t}\n\tset unknown_pending($name) pending;\n\tset ret [catch {a"
|
||||
"uto_load $name} msg]\n\tunset unknown_pending($name);\n\tif {$ret != "
|
||||
"0} {\n\t return -code $ret -errorcode $errorCode \\\n\t\t\"error whil"
|
||||
"e autoloading \\\"$name\\\": $msg\"\n\t}\n\tif ![array size unknown_pendin"
|
||||
"g] {\n\t unset unknown_pending\n\t}\n\tif $msg {\n\t set errorCode "
|
||||
"$savedErrorCode\n\t set errorInfo $savedErrorInfo\n\t set code "
|
||||
"[catch {uplevel $args} msg]\n\t if {$code == 1} {\n\t\t#\n\t\t# Strip"
|
||||
" the last five lines off the error stack (they're\n\t\t# from the \"u"
|
||||
"plevel\" command).\n\t\t#\n\n\t\tset new [split $errorInfo \\n]\n\t\tset new "
|
||||
"[join [lrange $new 0 [expr [llength $new] - 6]] \\n]\n\t\treturn -cod"
|
||||
"e error -errorcode $errorCode \\\n\t\t\t-errorinfo $new $msg\n\t } el"
|
||||
"se {\n\t\treturn -code $code $msg\n\t }\n\t}\n }\n \n # Try run"
|
||||
"ning SICS for a change\n set ret [catch {uplevel #0 SicsUnknown"
|
||||
" $args} msg]\n if {$ret == 1} {\n return -code error $msg"
|
||||
"\n } else {\n return -code ok $msg\n }\n}\n\n# auto_load -"
|
||||
"-\n# Checks a collection of library directories to see if a proced"
|
||||
"ure\n# is defined in one of them. If so, it sources the appropria"
|
||||
"te\n# library file to create the procedure. Returns 1 if it succe"
|
||||
"ssfully\n# loaded the procedure, 0 otherwise.\n#\n# Arguments: \n# cm"
|
||||
"d -\t\t\tName of the command to find and load.\n\nproc auto_load cmd {"
|
||||
"\n global auto_index auto_oldpath auto_path env errorInfo error"
|
||||
"Code\n\n if [info exists auto_index($cmd)] {\n\tuplevel #0 $auto_i"
|
||||
"ndex($cmd)\n\treturn [expr {[info commands $cmd] != \"\"}]\n }\n "
|
||||
"if ![info exists auto_path] {\n\treturn 0\n }\n if [info exists"
|
||||
" auto_oldpath] {\n\tif {$auto_oldpath == $auto_path} {\n\t return "
|
||||
"0\n\t}\n }\n set auto_oldpath $auto_path\n for {set i [expr ["
|
||||
"llength $auto_path] - 1]} {$i >= 0} {incr i -1} {\n\tset dir [linde"
|
||||
"x $auto_path $i]\n\tset f \"\"\n\tif [catch {set f [open [file join $di"
|
||||
"r tclIndex]]}] {\n\t continue\n\t}\n\tset error [catch {\n\t set id"
|
||||
" [gets $f]\n\t if {$id == \"# Tcl autoload index file, version 2."
|
||||
"0\"} {\n\t\teval [read $f]\n\t } elseif {$id == \"# Tcl autoload inde"
|
||||
"x file: each line identifies a Tcl\"} {\n\t\twhile {[gets $f line] >="
|
||||
" 0} {\n\t\t if {([string index $line 0] == \"#\")\n\t\t\t || ([lleng"
|
||||
"th $line] != 2)} {\n\t\t\tcontinue\n\t\t }\n\t\t set name [lindex $li"
|
||||
"ne 0]\n\t\t set auto_index($name) \\\n\t\t\t\"source [file join $dir [l"
|
||||
"index $line 1]]\"\n\t\t}\n\t } else {\n\t\terror \"[file join $dir tclIn"
|
||||
"dex] isn't a proper Tcl index file\"\n\t }\n\t} msg]\n\tif {$f != \"\"}"
|
||||
" {\n\t close $f\n\t}\n\tif $error {\n\t error $msg $errorInfo $erro"
|
||||
"rCode\n\t}\n }\n if [info exists auto_index($cmd)] {\n\tuplevel #"
|
||||
"0 $auto_index($cmd)\n\tif {[info commands $cmd] != \"\"} {\n\t retur"
|
||||
"n 1\n\t}\n }\n return 0\n}\n\nif {[string compare $tcl_platform(pl"
|
||||
"atform) windows] == 0} {\n\n# auto_execok --\n#\n# Returns string tha"
|
||||
"t indicates name of program to execute if \n# name corresponds to "
|
||||
"a shell builtin or an executable in the\n# Windows search path, or"
|
||||
" \"\" otherwise. Builds an associative \n# array auto_execs that ca"
|
||||
"ches information about previous checks, \n# for speed.\n#\n# Argumen"
|
||||
"ts: \n# name -\t\t\tName of a command.\n\n# Windows version.\n#\n# Note t"
|
||||
"hat info executable doesn't work under Windows, so we have to\n# l"
|
||||
"ook for files with .exe, .com, or .bat extensions. Also, the pat"
|
||||
"h\n# may be in the Path or PATH environment variables, and path\n# "
|
||||
"components are separated with semicolons, not colons as under Uni"
|
||||
"x.\n#\nproc auto_execok name {\n global auto_execs env tcl_platfo"
|
||||
"rm\n\n if [info exists auto_execs($name)] {\n\treturn $auto_execs("
|
||||
"$name)\n }\n set auto_execs($name) \"\"\n\n if {[lsearch -exac"
|
||||
"t {cls copy date del erase dir echo mkdir md rename \n\t ren rmd"
|
||||
"ir rd time type ver vol} $name] != -1} {\n\tif {[info exists env(CO"
|
||||
"MSPEC)]} {\n\t set comspec $env(COMSPEC) \n\t} elseif {[info exist"
|
||||
"s env(ComSpec)]} {\n\t set comspec $env(ComSpec)\n\t} elseif {$tcl"
|
||||
"_platform(os) == \"Windows NT\"} {\n\t set comspec \"cmd.exe\"\n\t} el"
|
||||
"se {\n\t set comspec \"command.com\"\n\t}\n\treturn [set auto_execs($n"
|
||||
"ame) [list $comspec /c $name]]\n }\n\n if {[llength [file spli"
|
||||
"t $name]] != 1} {\n\tforeach ext {{} .com .exe .bat} {\n\t set fil"
|
||||
"e ${name}${ext}\n\t if {[file exists $file] && ![file isdirector"
|
||||
"y $file]} {\n\t\treturn [set auto_execs($name) $file]\n\t }\n\t}\n\tret"
|
||||
"urn \"\"\n }\n\n set path \"[file dirname [info nameof]];.;\"\n "
|
||||
"if {[info exists env(WINDIR)]} {\n\tset windir $env(WINDIR) \n } "
|
||||
"elseif {[info exists env(windir)]} {\n\tset windir $env(windir)\n "
|
||||
" }\n if {[info exists windir]} {\n\tif {$tcl_platform(os) == \"Win"
|
||||
"dows NT\"} {\n\t append path \"$windir/system32;\"\n\t}\n\tappend path "
|
||||
"\"$windir/system;$windir;\"\n }\n\n if {! [info exists env(PATH)"
|
||||
"]} {\n\tif [info exists env(Path)] {\n\t append path $env(Path)\n\t}"
|
||||
" else {\n\t return \"\"\n\t}\n } else {\n\tappend path $env(PATH)\n "
|
||||
" }\n\n foreach dir [split $path {;}] {\n\tif {$dir == \"\"} {\n\t "
|
||||
"set dir .\n\t}\n\tforeach ext {{} .com .exe .bat} {\n\t set file [fi"
|
||||
"le join $dir ${name}${ext}]\n\t if {[file exists $file] && ![fil"
|
||||
"e isdirectory $file]} {\n\t\treturn [set auto_execs($name) $file]\n\t "
|
||||
" }\n\t}\n }\n return \"\"\n}\n\n} else {\n\n# auto_execok --\n#\n# Ret"
|
||||
"urns string that indicates name of program to execute if \n# name "
|
||||
"corresponds to an executable in the path. Builds an associative \n"
|
||||
"# array auto_execs that caches information about previous checks,"
|
||||
" \n# for speed.\n#\n# Arguments: \n# name -\t\t\tName of a command.\n\n# U"
|
||||
"nix version.\n#\nproc auto_execok name {\n global auto_execs env\n"
|
||||
"\n if [info exists auto_execs($name)] {\n\treturn $auto_execs($na"
|
||||
"me)\n }\n set auto_execs($name) \"\"\n if {[llength [file spl"
|
||||
"it $name]] != 1} {\n\tif {[file executable $name] && ![file isdirec"
|
||||
"tory $name]} {\n\t set auto_execs($name) $name\n\t}\n\treturn $auto_"
|
||||
"execs($name)\n }\n foreach dir [split $env(PATH) :] {\n\tif {$d"
|
||||
"ir == \"\"} {\n\t set dir .\n\t}\n\tset file [file join $dir $name]\n\ti"
|
||||
"f {[file executable $file] && ![file isdirectory $file]} {\n\t s"
|
||||
"et auto_execs($name) $file\n\t return $file\n\t}\n }\n return "
|
||||
"\"\"\n}\n\n}\n# auto_reset --\n# Destroy all cached information for auto"
|
||||
"-loading and auto-execution,\n# so that the information gets recom"
|
||||
"puted the next time it's needed.\n# Also delete any procedures tha"
|
||||
"t are listed in the auto-load index\n# except those defined in thi"
|
||||
"s file.\n#\n# Arguments: \n# None.\n\nproc auto_reset {} {\n global "
|
||||
"auto_execs auto_index auto_oldpath\n foreach p [info procs] {\n\t"
|
||||
"if {[info exists auto_index($p)] && ![string match auto_* $p]\n\t\t&"
|
||||
"& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup\n\t\t\ttclPkgUnkn"
|
||||
"own} $p] < 0)} {\n\t rename $p {}\n\t}\n }\n catch {unset auto"
|
||||
"_execs}\n catch {unset auto_index}\n catch {unset auto_oldpat"
|
||||
"h}\n}\n\n# auto_mkindex --\n# Regenerate a tclIndex file from Tcl sou"
|
||||
"rce files. Takes as argument\n# the name of the directory in whic"
|
||||
"h the tclIndex file is to be placed,\n# followed by any number of "
|
||||
"glob patterns to use in that directory to\n# locate all of the rel"
|
||||
"evant files.\n#\n# Arguments: \n# dir -\t\t\tName of the directory in w"
|
||||
"hich to create an index.\n# args -\t\tAny number of additional argum"
|
||||
"ents giving the\n#\t\t\tnames of files within dir. If no additional\n"
|
||||
"#\t\t\tare given auto_mkindex will look for *.tcl.\n\nproc auto_mkinde"
|
||||
"x {dir args} {\n global errorCode errorInfo\n set oldDir [pwd"
|
||||
"]\n cd $dir\n set dir [pwd]\n append index \"# Tcl autoload "
|
||||
"index file, version 2.0\\n\"\n append index \"# This file is gener"
|
||||
"ated by the \\\"auto_mkindex\\\" command\\n\"\n append index \"# and s"
|
||||
"ourced to set up indexing information for one or\\n\"\n append in"
|
||||
"dex \"# more commands. Typically each line is a command that\\n\"\n "
|
||||
" append index \"# sets an element in the auto_index array, where"
|
||||
" the\\n\"\n append index \"# element name is the name of a command"
|
||||
" and the value is\\n\"\n append index \"# a script that loads the "
|
||||
"command.\\n\\n\"\n if {$args == \"\"} {\n\tset args *.tcl\n }\n fo"
|
||||
"reach file [eval glob $args] {\n\tset f \"\"\n\tset error [catch {\n\t "
|
||||
" set f [open $file]\n\t while {[gets $f line] >= 0} {\n\t\tif [rege"
|
||||
"xp {^proc[ \t]+([^ \t]*)} $line match procName] {\n\t\t append inde"
|
||||
"x \"set [list auto_index($procName)]\"\n\t\t append index \" \\[list "
|
||||
"source \\[file join \\$dir [list $file]\\]\\]\\n\"\n\t\t}\n\t }\n\t clos"
|
||||
"e $f\n\t} msg]\n\tif $error {\n\t set code $errorCode\n\t set info "
|
||||
"$errorInfo\n\t catch {close $f}\n\t cd $oldDir\n\t error $msg "
|
||||
"$info $code\n\t}\n }\n set f \"\"\n set error [catch {\n\tset f ["
|
||||
"open tclIndex w]\n\tputs $f $index nonewline\n\tclose $f\n\tcd $oldDir\n"
|
||||
" } msg]\n if $error {\n\tset code $errorCode\n\tset info $errorI"
|
||||
"nfo\n\tcatch {close $f}\n\tcd $oldDir\n\terror $msg $info $code\n }\n}"
|
||||
"\n\n# pkg_mkIndex --\n# This procedure creates a package index in a "
|
||||
"given directory. The\n# package index consists of a \"pkgIndex.tcl"
|
||||
"\" file whose contents are\n# a Tcl script that sets up package inf"
|
||||
"ormation with \"package require\"\n# commands. The commands describ"
|
||||
"e all of the packages defined by the\n# files given as arguments.\n"
|
||||
"#\n# Arguments:\n# dir -\t\t\tName of the directory in which to create"
|
||||
" the index.\n# args -\t\tAny number of additional arguments, each gi"
|
||||
"ving\n#\t\t\ta glob pattern that matches the names of one or\n#\t\t\tmore"
|
||||
" shared libraries or Tcl script files in\n#\t\t\tdir.\n\nproc pkg_mkInd"
|
||||
"ex {dir args} {\n global errorCode errorInfo\n append index \""
|
||||
"# Tcl package index file, version 1.0\\n\"\n append index \"# This"
|
||||
" file is generated by the \\\"pkg_mkIndex\\\" command\\n\"\n append i"
|
||||
"ndex \"# and sourced either when an application starts up or\\n\"\n "
|
||||
" append index \"# by a \\\"package unknown\\\" script. It invokes th"
|
||||
"e\\n\"\n append index \"# \\\"package ifneeded\\\" command to set up p"
|
||||
"ackage-related\\n\"\n append index \"# information so that package"
|
||||
"s will be loaded automatically\\n\"\n append index \"# in response"
|
||||
" to \\\"package require\\\" commands. When this\\n\"\n append index "
|
||||
"\"# script is sourced, the variable \\$dir must contain the\\n\"\n "
|
||||
"append index \"# full path name of this file's directory.\\n\"\n s"
|
||||
"et oldDir [pwd]\n cd $dir\n foreach file [eval glob $args] {\n"
|
||||
"\t# For each file, figure out what commands and packages it provid"
|
||||
"es.\n\t# To do this, create a child interpreter, load the file into"
|
||||
" the\n\t# interpreter, and get a list of the new commands and packa"
|
||||
"ges\n\t# that are defined. Define an empty \"package unknown\" scrip"
|
||||
"t so\n\t# that there are no recursive package inclusions.\n\n\tset c ["
|
||||
"interp create]\n\n\t# If Tk is loaded in the parent interpreter, loa"
|
||||
"d it into the\n\t# child also, in case the extension depends on it."
|
||||
"\n\n\tforeach pkg [info loaded] {\n\t if {[lindex $pkg 1] == \"Tk\"} "
|
||||
"{\n\t\t$c eval {set argv {-geometry +0+0}}\n\t\tload [lindex $pkg 0] Tk"
|
||||
" $c\n\t\tbreak\n\t }\n\t}\n\t$c eval [list set file $file]\n\tif [catch {"
|
||||
"\n\t $c eval {\n\t\tproc dummy args {}\n\t\tpackage unknown dummy\n\t\tse"
|
||||
"t origCmds [info commands]\n\t\tset dir \"\"\t\t;# in case file is pkgIn"
|
||||
"dex.tcl\n\t\tset pkgs \"\"\n\n\t\t# Try to load the file if it has the sha"
|
||||
"red library extension,\n\t\t# otherwise source it. It's important n"
|
||||
"ot to try to load\n\t\t# files that aren't shared libraries, because"
|
||||
" on some systems\n\t\t# (like SunOS) the loader will abort the whole"
|
||||
" application\n\t\t# when it gets an error.\n\n\t\tif {[string compare [f"
|
||||
"ile extension $file] \\\n\t\t\t[info sharedlibextension]] == 0} {\n\n\t\t "
|
||||
" # The \"file join .\" command below is necessary. Without\n\t\t "
|
||||
" # it, if the file name has no \\'s and we're on UNIX, the\n\t\t #"
|
||||
" load command will invoke the LD_LIBRARY_PATH search\n\t\t # mech"
|
||||
"anism, which could cause the wrong file to be used.\n\n\t\t load ["
|
||||
"file join . $file]\n\t\t set type load\n\t\t} else {\n\t\t source $f"
|
||||
"ile\n\t\t set type source\n\t\t}\n\t\tforeach i [info commands] {\n\t\t "
|
||||
" set cmds($i) 1\n\t\t}\n\t\tforeach i $origCmds {\n\t\t catch {unset cm"
|
||||
"ds($i)}\n\t\t}\n\t\tforeach i [package names] {\n\t\t if {([string comp"
|
||||
"are [package provide $i] \"\"] != 0)\n\t\t\t && ([string compare $i "
|
||||
"Tcl] != 0)\n\t\t\t && ([string compare $i Tk] != 0)} {\n\t\t\tlappend "
|
||||
"pkgs [list $i [package provide $i]]\n\t\t }\n\t\t}\n\t }\n\t} msg] {\n"
|
||||
"\t puts \"error while loading or sourcing $file: $msg\"\n\t}\n\tforea"
|
||||
"ch pkg [$c eval set pkgs] {\n\t lappend files($pkg) [list $file "
|
||||
"[$c eval set type] \\\n\t\t [lsort [$c eval array names cmds]]]\n\t}"
|
||||
"\n\tinterp delete $c\n }\n foreach pkg [lsort [array names file"
|
||||
"s]] {\n\tappend index \"\\npackage ifneeded $pkg\\\n\t\t\\[list tclPkgSetu"
|
||||
"p \\$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\\\n\t\t[list $files($pkg)"
|
||||
"]\\]\"\n }\n set f [open pkgIndex.tcl w]\n puts $f $index\n "
|
||||
" close $f\n cd $oldDir\n}\n\n# tclPkgSetup --\n# This is a utility "
|
||||
"procedure use by pkgIndex.tcl files. It is invoked\n# as part of "
|
||||
"a \"package ifneeded\" script. It calls \"package provide\"\n# to ind"
|
||||
"icate that a package is available, then sets entries in the\n# aut"
|
||||
"o_index array so that the package's files will be auto-loaded whe"
|
||||
"n\n# the commands are used.\n#\n# Arguments:\n# dir -\t\t\tDirectory con"
|
||||
"taining all the files for this package.\n# pkg -\t\t\tName of the pac"
|
||||
"kage (no version number).\n# version -\t\tVersion number for the pac"
|
||||
"kage, such as 2.1.3.\n# files -\t\tList of files that constitute the"
|
||||
" package. Each\n#\t\t\telement is a sub-list with three elements. T"
|
||||
"he first\n#\t\t\tis the name of a file relative to $dir, the second i"
|
||||
"s\n#\t\t\t\"load\" or \"source\", indicating whether the file is a\n#\t\t\tlo"
|
||||
"adable binary or a script to source, and the third\n#\t\t\tis a list "
|
||||
"of commands defined by this file.\n\nproc tclPkgSetup {dir pkg vers"
|
||||
"ion files} {\n global auto_index\n\n package provide $pkg $ver"
|
||||
"sion\n foreach fileInfo $files {\n\tset f [lindex $fileInfo 0]\n\ts"
|
||||
"et type [lindex $fileInfo 1]\n\tforeach cmd [lindex $fileInfo 2] {\n"
|
||||
"\t if {$type == \"load\"} {\n\t\tset auto_index($cmd) [list load [fi"
|
||||
"le join $dir $f] $pkg]\n\t } else {\n\t\tset auto_index($cmd) [list"
|
||||
" source [file join $dir $f]]\n\t } \n\t}\n }\n}\n\n# tclMacPkgSearc"
|
||||
"h --\n# The procedure is used on the Macintosh to search a given d"
|
||||
"irectory for files\n# with a TEXT resource named \"pkgIndex\". If i"
|
||||
"t exists it is sourced in to the\n# interpreter to setup the packa"
|
||||
"ge database.\n\nproc tclMacPkgSearch {dir} {\n foreach x [glob -n"
|
||||
"ocomplain [file join $dir *.shlb]] {\n\tif [file isfile $x] {\n\t "
|
||||
"set res [resource open $x]\n\t foreach y [resource list TEXT $re"
|
||||
"s] {\n\t\tif {$y == \"pkgIndex\"} {source -rsrc pkgIndex}\n\t }\n\t "
|
||||
"resource close $res\n\t}\n }\n}\n\n# tclPkgUnknown --\n# This procedu"
|
||||
"re provides the default for the \"package unknown\" function.\n# It "
|
||||
"is invoked when a package that's needed can't be found. It scans"
|
||||
"\n# the auto_path directories and their immediate children looking"
|
||||
" for\n# pkgIndex.tcl files and sources any such files that are fou"
|
||||
"nd to setup\n# the package database. (On the Macintosh we also se"
|
||||
"arch for pkgIndex\n# TEXT resources in all files.)\n#\n# Arguments:\n"
|
||||
"# name -\t\tName of desired package. Not used.\n# version -\t\tVersio"
|
||||
"n of desired package. Not used.\n# exact -\t\tEither \"-exact\" or om"
|
||||
"itted. Not used.\n\nproc tclPkgUnknown {name version {exact {}}} {"
|
||||
"\n global auto_path tcl_platform env\n\n if ![info exists auto"
|
||||
"_path] {\n\treturn\n }\n for {set i [expr [llength $auto_path] "
|
||||
"- 1]} {$i >= 0} {incr i -1} {\n\tset dir [lindex $auto_path $i]\n\tse"
|
||||
"t file [file join $dir pkgIndex.tcl]\n\tif [file readable $file] {\n"
|
||||
"\t source $file\n\t}\n\tforeach file [glob -nocomplain [file join $"
|
||||
"dir * pkgIndex.tcl]] {\n\t if [file readable $file] {\n\t\tset dir "
|
||||
"[file dirname $file]\n\t\tsource $file\n\t }\n\t}\n\t# On the Macintosh"
|
||||
" we also look in the resource fork \n\t# of shared libraries\n\tif {$"
|
||||
"tcl_platform(platform) == \"macintosh\"} {\n\t set dir [lindex $au"
|
||||
"to_path $i]\n\t tclMacPkgSearch $dir\n\t foreach x [glob -nocom"
|
||||
"plain [file join $dir *]] {\n\t\tif [file isdirectory $x] {\n\t\t se"
|
||||
"t dir $x\n\t\t tclMacPkgSearch $dir\n\t\t}\n\t }\n\t}\n }\n}\n"
|
||||
;
|
||||
int initcl_Init(Tcl_Interp* interp)
|
||||
{
|
||||
Tcl_SetVar(interp, "package_name", "initcl", TCL_GLOBAL_ONLY);
|
||||
if (Tcl_GlobalEval(interp, init_tcl) != TCL_OK) return TCL_ERROR;
|
||||
Tcl_UnsetVar(interp, "package_name", TCL_GLOBAL_ONLY);
|
||||
return TCL_OK;
|
||||
}
|
||||
540
tcl/obtcl.tcl
540
tcl/obtcl.tcl
@ -1,540 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# -- 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}:${self}:$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}:\$_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}:\$_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}:\$_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}:\${self}:\$_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}:\${self}:\$_obTcl_i \$_obTcl_i
|
||||
}"
|
||||
}
|
||||
}
|
||||
|
||||
# Renamed Instance variable. Specific to instances.
|
||||
proc renamed_instvar { normal_name new_name } {
|
||||
uplevel 1 "upvar #0 _oIV_\${class}:\${self}:$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::initialize}
|
||||
eval {$iclass::init} $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::\$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::\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
|
||||
} else {
|
||||
return \$val
|
||||
}
|
||||
"
|
||||
set self $obj
|
||||
eval {$iclass::initialize}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# 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_*:${self}:*\]"}
|
||||
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 *:* $class] {
|
||||
puts stderr "class: Fatal Error:"
|
||||
puts stderr " class name `$class'\
|
||||
contains reserved character `:'"
|
||||
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::new \$cmd} \$args }
|
||||
new { eval {$class::new} \$args }
|
||||
method { eval {otMkMethod N $class} \$args}
|
||||
inherit { eval {otInherit $class} \$args}
|
||||
destroy { eval {otClassDestroy $class} \$args }
|
||||
init { return -code error \
|
||||
-errorinfo \"$obj: Error: classes may not be init'ed!\" \
|
||||
\"$obj: Error: classes may not be init'ed!\"
|
||||
}
|
||||
default {
|
||||
if \[catch {eval {$iclass::\$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}:*\] {
|
||||
unset \$_iii
|
||||
}
|
||||
foreach _iii \[info vars _oDCV_${class}:*\] {
|
||||
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::$name $params \
|
||||
"otGetSelf
|
||||
set class $class
|
||||
$method
|
||||
$body"
|
||||
if ![string compare "S" $mode] {
|
||||
global _obTcl_SysMethod
|
||||
set _obTcl_SysMethod($class::$name) 1
|
||||
}
|
||||
}
|
||||
|
||||
proc otRmMethod { class name } {
|
||||
global _obTcl_SysMethod
|
||||
|
||||
if [string compare "unknown" "$name"] {
|
||||
otInvalidateCaches 0 $class $name
|
||||
} else {
|
||||
otInvalidateCaches 0 $class *
|
||||
}
|
||||
rename $class::$name {}
|
||||
catch {unset _obTcl_SysMethod($class::$name)}
|
||||
}
|
||||
|
||||
proc otDelAllMethods class {
|
||||
global _obTcl_Cached
|
||||
foreach i [info procs $class::*] {
|
||||
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}::$method)] { return }
|
||||
if [catch {set b [info body ${class}::$method]} ret] {
|
||||
return -code error \
|
||||
-errorinfo "info body: Method '$method' not defined in class $class" \
|
||||
"info body: 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}::$method)] { return }
|
||||
if [catch {set b [info args ${class}::$method]} ret] {
|
||||
return -code error \
|
||||
-errorinfo "info args: Method '$method' not defined in class $class" \
|
||||
"info args: Method '$method' not defined in class $class"
|
||||
} else {
|
||||
return $b
|
||||
}
|
||||
}
|
||||
proc otClassInfoMethods+Cached class {
|
||||
global _obTcl_Objclass _obTcl_SysMethod
|
||||
set l [info procs ${class}::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class}::(.*)" $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}::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
if [info exists _obTcl_Cached($i)] { continue }
|
||||
if [info exists _obTcl_SysMethod($i)] { continue }
|
||||
regsub "${class}::(.*)" $i {\1} tmp
|
||||
lappend all $tmp
|
||||
}
|
||||
return $all
|
||||
}
|
||||
proc otClassInfoSysMethods class {
|
||||
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
|
||||
set l [info procs ${class}::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
if [info exists _obTcl_Cached($i)] { continue }
|
||||
if ![info exists _obTcl_SysMethod($i)] { continue }
|
||||
regsub "${class}::(.*)" $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::*]
|
||||
set all {}
|
||||
foreach i $l {
|
||||
regsub "${class}::(.*)" $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
|
||||
}
|
||||
|
||||
540
tcl/obtcl8.tcl
540
tcl/obtcl8.tcl
@ -1,540 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# -- 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 {$iclassVVinitialize}
|
||||
eval {$iclassVVinit} $args
|
||||
}
|
||||
|
||||
if ![string compare [info commands otProc] ""] {
|
||||
proc otProc { iclass obj } {
|
||||
proc $obj { cmd args } "
|
||||
set self $obj
|
||||
set iclass $iclass
|
||||
|
||||
if \[catch {eval {$iclassVV\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$objV \$val\" \"$objV \$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 {$iclassVV\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$objV \$val\" \"$objV \$val\"
|
||||
} else {
|
||||
return \$val
|
||||
}
|
||||
"
|
||||
set self $obj
|
||||
eval {$iclassVVinitialize}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# 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 {$classVVnew \$cmd} \$args }
|
||||
new { eval {$classVVnew} \$args }
|
||||
method { eval {otMkMethod N $class} \$args}
|
||||
inherit { eval {otInherit $class} \$args}
|
||||
destroy { eval {otClassDestroy $class} \$args }
|
||||
init { return -code error \
|
||||
-errorinfo \"$objV ErrorV classes may not be init'ed!\" \
|
||||
\"$objV ErrorV classes may not be init'ed!\"
|
||||
}
|
||||
default {
|
||||
if \[catch {eval {$iclassVV\$cmd} \$args} val\] {
|
||||
return -code error \
|
||||
-errorinfo \"$objV \$val\" \"$objV \$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 $classVV$name $params \
|
||||
"otGetSelf
|
||||
set class $class
|
||||
$method
|
||||
$body"
|
||||
if ![string compare "S" $mode] {
|
||||
global _obTcl_SysMethod
|
||||
set _obTcl_SysMethod($classVV$name) 1
|
||||
}
|
||||
}
|
||||
|
||||
proc otRmMethod { class name } {
|
||||
global _obTcl_SysMethod
|
||||
|
||||
if [string compare "unknown" "$name"] {
|
||||
otInvalidateCaches 0 $class $name
|
||||
} else {
|
||||
otInvalidateCaches 0 $class *
|
||||
}
|
||||
rename $classVV$name {}
|
||||
catch {unset _obTcl_SysMethod($classVV$name)}
|
||||
}
|
||||
|
||||
proc otDelAllMethods class {
|
||||
global _obTcl_Cached
|
||||
foreach i [info procs $classVV*] {
|
||||
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 $classVV*]
|
||||
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
|
||||
}
|
||||
|
||||
@ -1,9 +0,0 @@
|
||||
#!/bin/sh
|
||||
# the next line restarts using tclsh7.4 \
|
||||
exec tclsh7.6 "$0" "$@"
|
||||
|
||||
lappend auto_path [file dirname [info script]]
|
||||
foreach i "." {
|
||||
obtcl_mkindex $i *.tcl
|
||||
}
|
||||
|
||||
490
tcl/scancom.tcl
Normal file
490
tcl/scancom.tcl
Normal file
@ -0,0 +1,490 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# general scan command wrappers for TOPSI and the like.
|
||||
# New version using the object.tcl system from sntl instead of obTcl which
|
||||
# caused a lot of trouble with tcl8.0
|
||||
#
|
||||
# Requires the built in scan command xxxscan.
|
||||
#
|
||||
# Mark Koennecke, February 2000
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
#---------- adapt to the local settings
|
||||
set home /data/koenneck/src
|
||||
|
||||
source $home/sics/object.tcl
|
||||
|
||||
set datapath $home/tmp
|
||||
set recoverfil $home/tmp/recover.bin
|
||||
|
||||
#-------------------------- 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]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
|
||||
#************** Definition of scan class **********************************
|
||||
|
||||
object_class ScanCommand {
|
||||
member Mode Monitor
|
||||
member NP 1
|
||||
member counter counter
|
||||
member NoVar 0
|
||||
member Preset 10000
|
||||
member File default.dat
|
||||
member pinterest ""
|
||||
member Channel 0
|
||||
member Active 0
|
||||
member Recover 0
|
||||
member scanvars
|
||||
member scanstart
|
||||
member scanstep
|
||||
member pinterest
|
||||
|
||||
method var {name start step} {
|
||||
# check for activity
|
||||
if {$slot(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 $slot(NoVar)
|
||||
incr slot(NoVar)
|
||||
lappend slot(scanvars) $name
|
||||
lappend slot(scanstart) $start
|
||||
lappend slot(scanstep) $step
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method info {} {
|
||||
if { $slot(NoVar) < 1 } {
|
||||
return "0,1,NONE,0.,0.,default.dat"
|
||||
}
|
||||
append result $slot(NP) "," $slot(NoVar)
|
||||
for {set i 0} { $i < $slot(NoVar) } { incr i} {
|
||||
append result "," [lindex $slot(scanvars) $i]
|
||||
}
|
||||
append result "," [lindex $slot(scanstart) 0] "," \
|
||||
[lindex $slot(scanstep) 0]
|
||||
set r1 [xxxscan getfile]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return $result
|
||||
}
|
||||
|
||||
method getvars {} {
|
||||
set list ""
|
||||
lappend list $slot(scanvars)
|
||||
return [format "scan.Vars = %s -END-" $list]
|
||||
}
|
||||
|
||||
method xaxis {} {
|
||||
if { $slot(NoVar) <= 0} {
|
||||
#---- default Answer
|
||||
set t [format "%s.xaxis = %f %f" $self 0 1]
|
||||
} else {
|
||||
set t [format "%s.xaxis = %f %f" $self [lindex $slot(scanstart) 0] \
|
||||
[lindex $slot(scanstep) 0] ]
|
||||
}
|
||||
ClientPut $t
|
||||
}
|
||||
|
||||
method cinterest {} {
|
||||
xxxscan interest
|
||||
}
|
||||
|
||||
method uuinterest {} {
|
||||
xxxscan uuinterest
|
||||
}
|
||||
|
||||
method pinterest {} {
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend $slot(pinterest) $nam
|
||||
}
|
||||
|
||||
method SendInterest { type text } {
|
||||
#------ check list first
|
||||
set l1 $slot($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 slot($type) $l2
|
||||
foreach e $l2 {
|
||||
set b [string trim $e]
|
||||
$b put $text
|
||||
}
|
||||
}
|
||||
|
||||
method mode { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set tmp [string tolower $NewVal]
|
||||
set NewVal $tmp
|
||||
if { ([string compare $NewVal "timer"] == 0) || \
|
||||
([string compare $NewVal monitor] ==0) } {
|
||||
set slot(Mode) $NewVal
|
||||
ClientPut OK
|
||||
} else {
|
||||
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method np { { NewVal NULL } } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(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 slot(NP) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method preset { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(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 slot(Preset) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method file {} {
|
||||
return [xxxscan file]
|
||||
}
|
||||
|
||||
method setchannel {num} {
|
||||
set ret [catch {xxxscan setchannel $num} msg]
|
||||
if { $ret == 0} {
|
||||
set slot(Channel) $num
|
||||
} else {
|
||||
return $msg
|
||||
}
|
||||
}
|
||||
|
||||
method list { } {
|
||||
ClientPut [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut [format "%s.File = %s" $self $slot(File)]
|
||||
ClientPut [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut [format "%s.Channel = %d" $self $slot(Channel)]
|
||||
ClientPut "ScanVariables:"
|
||||
for { set i 0 } {$i < $slot(NoVar) } { incr i } {
|
||||
ClientPut [format " %s %f %f" [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] \
|
||||
[lindex $slot(scanstep) $i] ]
|
||||
}
|
||||
}
|
||||
|
||||
method clear {} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot clear running scan" error
|
||||
return
|
||||
}
|
||||
|
||||
set slot(NP) 0
|
||||
set slot(NoVar) 0
|
||||
set slot(scanvars) ""
|
||||
set slot(scanstart) ""
|
||||
set slot(scanstep) ""
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
xxxscan clear
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method getcounts {} {
|
||||
return [xxxscan getcounts]
|
||||
}
|
||||
|
||||
method run { } {
|
||||
# start with error checking
|
||||
if { $slot(NP) < 1 } {
|
||||
ClientPut "ERROR: Insufficient Number of ScanPoints"
|
||||
return
|
||||
}
|
||||
if { $slot(NoVar) < 1 } {
|
||||
ClientPut "ERROR: No variables to scan given!"
|
||||
return
|
||||
}
|
||||
#------- check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: Scan already in progress" error
|
||||
return
|
||||
}
|
||||
set slot(Active) 1
|
||||
xxxscan clear
|
||||
for {set i 0 } { $i < $slot(NoVar)} {incr i} {
|
||||
set ret [catch {xxxscan add [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] [lindex $slot(scanstep) $i]} msg]
|
||||
if {$ret != 0} {
|
||||
set slot(Active) 0
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
set ret [catch \
|
||||
{xxxscan run $slot(NP) $slot(Mode) $slot(Preset)} msg]
|
||||
set slot(Active) 0
|
||||
if {$ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
return "Scan Finished"
|
||||
}
|
||||
}
|
||||
|
||||
method recover {} {
|
||||
set slot(Active) 1
|
||||
catch {xxxscan recover} msg
|
||||
set slot(Active) 0
|
||||
return "Scan Finished"
|
||||
}
|
||||
}
|
||||
#---- end of ScanCommand definition
|
||||
|
||||
#********************** initialisation of module commands to SICS **********
|
||||
|
||||
set ret [catch {scan list} msg]
|
||||
if {$ret != 0} {
|
||||
object_new ScanCommand scan
|
||||
Publish scan Spy
|
||||
VarMake lastscancommand Text User
|
||||
Publish scancounts Spy
|
||||
Publish textstatus Spy
|
||||
Publish cscan User
|
||||
Publish sscan User
|
||||
Publish sftime Spy
|
||||
Publish scaninfo Spy
|
||||
}
|
||||
|
||||
#*************************************************************************
|
||||
|
||||
#===================== Helper commands for status display work ============
|
||||
# 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]]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
# Utility function which gives scan parameters as an easily parsable
|
||||
# comma separated list for java status client
|
||||
proc scaninfo {} {
|
||||
set result [scan info]
|
||||
set r1 [sample]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
append result "," [sicstime]
|
||||
set r1 [lastscancommand]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return [format "scaninfo = %s" $result]
|
||||
}
|
||||
|
||||
#===================== Syntactical sugar around scan ===================
|
||||
# center scan. A convenience scan for the one and only Daniel Clemens
|
||||
# at TOPSI. Scans around a given ceter point. Requires the scan command
|
||||
# for TOPSI to work.
|
||||
#
|
||||
# another convenience scan:
|
||||
# sscan var1 start end var1 start end .... np preset
|
||||
# scans var1, var2 from start to end with np steps and a preset of preset
|
||||
#
|
||||
# Mark Koennecke, August, 22, 1997
|
||||
#-----------------------------------------------------------------------------
|
||||
proc cscan { var center delta np preset } {
|
||||
#------ start with some argument checking
|
||||
set t [SICSType $var]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is NOT drivable!" $var]
|
||||
return
|
||||
}
|
||||
set t [SICSType $center]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $center]
|
||||
return
|
||||
}
|
||||
set t [SICSType $delta]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $delta]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $np]
|
||||
return
|
||||
}
|
||||
set t [SICSType $preset]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $preset]
|
||||
return
|
||||
}
|
||||
#-------- store command in lastscancommand
|
||||
set txt [format "cscan %s %s %s %s %s" $var $center \
|
||||
$delta $np $preset]
|
||||
catch {lastscancommand $txt}
|
||||
#-------- set standard parameters
|
||||
scan clear
|
||||
scan preset $preset
|
||||
scan np [expr $np*2 + 1]
|
||||
#--------- calculate start
|
||||
set start [expr $center - $np * $delta]
|
||||
set ret [catch {scan var $var $start $delta} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
#---------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc sscan args {
|
||||
scan clear
|
||||
#------- check arguments: the last two must be preset and np!
|
||||
set l [llength $args]
|
||||
if { $l < 5} {
|
||||
ClientPut "ERROR: Insufficient number of arguments to sscan"
|
||||
return
|
||||
}
|
||||
set preset [lindex $args [expr $l - 1]]
|
||||
set np [lindex $args [expr $l - 2]]
|
||||
set t [SICSType $preset]
|
||||
ClientPut $t
|
||||
ClientPut [string first $t "NUM"]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for preset, got %s" \
|
||||
$preset]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for np, got %s" \
|
||||
$np]
|
||||
return
|
||||
}
|
||||
scan preset $preset
|
||||
scan np $np
|
||||
#--------- do variables
|
||||
set nvar [expr ($l - 2) / 3]
|
||||
for { set i 0 } { $i < $nvar} { incr i } {
|
||||
set var [lindex $args [expr $i * 3]]
|
||||
set t [SICSType $var]
|
||||
if {[string compare $t DRIV] != 0} {
|
||||
ClientPut [format "ERROR: %s is not drivable" $var]
|
||||
return
|
||||
}
|
||||
set start [lindex $args [expr ($i * 3) + 1]]
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for start, got %s" \
|
||||
$start]
|
||||
return
|
||||
}
|
||||
set end [lindex $args [expr ($i * 3) + 2]]
|
||||
set t [SICSType $end]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for end, got %s" \
|
||||
$end]
|
||||
return
|
||||
}
|
||||
#--------- do scan parameters
|
||||
set step [expr double($end - $start)/double($np)]
|
||||
set ret [catch {scan var $var $start $step} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
}
|
||||
#------------- set lastcommand text
|
||||
set txt [format "sscan %s" [join $args]]
|
||||
catch {lastscancommand $txt}
|
||||
#------------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -1,791 +0,0 @@
|
||||
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
|
||||
}
|
||||
|
||||
@ -1,297 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# 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"
|
||||
}
|
||||
|
||||
@ -1,617 +0,0 @@
|
||||
# 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
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -1,540 +0,0 @@
|
||||
#----------------------------------------------------------------------
|
||||
# -- 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
|
||||
}
|
||||
|
||||
@ -1,112 +0,0 @@
|
||||
# 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"
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,771 +0,0 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# 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]]
|
||||
}
|
||||
@ -1,398 +0,0 @@
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# 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
|
||||
|
||||
|
||||
116
tcl/tclIndex
116
tcl/tclIndex
@ -1,116 +0,0 @@
|
||||
# Tcl autoload index file, version 2.0
|
||||
# This file is generated by the "obtcl_mkindex" command
|
||||
# and sourced to set up indexing information for one or
|
||||
# more commands/classes. Typically each line is a command/class that
|
||||
# sets an element in the auto_index array, where the
|
||||
# element name is the name of a command/class and the value is
|
||||
# a script that loads the command/class.
|
||||
|
||||
set auto_index(unknown) "source $dir/init.tcl"
|
||||
set auto_index(auto_load) "source $dir/init.tcl"
|
||||
set auto_index(auto_execok) "source $dir/init.tcl"
|
||||
set auto_index(auto_execok) "source $dir/init.tcl"
|
||||
set auto_index(auto_reset) "source $dir/init.tcl"
|
||||
set auto_index(auto_mkindex) "source $dir/init.tcl"
|
||||
set auto_index(pkg_mkIndex) "source $dir/init.tcl"
|
||||
set auto_index(tclPkgSetup) "source $dir/init.tcl"
|
||||
set auto_index(tclMacPkgSearch) "source $dir/init.tcl"
|
||||
set auto_index(tclPkgUnknown) "source $dir/init.tcl"
|
||||
set auto_index(tclLdAout) "source $dir/ldAout.tcl"
|
||||
set auto_index(parray) "source $dir/parray.tcl"
|
||||
set auto_index(Base) "source $dir/base.tcl"
|
||||
set auto_index(AnonInst) "source $dir/base.tcl"
|
||||
set auto_index(otMkSectMethod) "source $dir/base.tcl"
|
||||
set auto_index(otMkOptHandl) "source $dir/base.tcl"
|
||||
set auto_index(Widget) "source $dir/base.tcl"
|
||||
set auto_index(otPrInherits) "source $dir/inherit.tcl"
|
||||
set auto_index(otInherit) "source $dir/inherit.tcl"
|
||||
set auto_index(otInvalidateCaches) "source $dir/inherit.tcl"
|
||||
set auto_index(otDoInvalidate) "source $dir/inherit.tcl"
|
||||
set auto_index(otResolve) "source $dir/inherit.tcl"
|
||||
set auto_index(unknown) "source $dir/inherit.tcl"
|
||||
set auto_index(otChkCall) "source $dir/inherit.tcl"
|
||||
set auto_index(otNextPrepare) "source $dir/inherit.tcl"
|
||||
set auto_index(next) "source $dir/inherit.tcl"
|
||||
set auto_index(otGetNextFunc) "source $dir/inherit.tcl"
|
||||
set auto_index(otGetFunc) "source $dir/inherit.tcl"
|
||||
set auto_index(otGetFuncErr) "source $dir/inherit.tcl"
|
||||
set auto_index(otGetFuncMissingClass) "source $dir/inherit.tcl"
|
||||
set auto_index(instvar2global) "source $dir/obtcl.tcl"
|
||||
set auto_index(classvar) "source $dir/obtcl.tcl"
|
||||
set auto_index(classvar_of_class) "source $dir/obtcl.tcl"
|
||||
set auto_index(iclassvar) "source $dir/obtcl.tcl"
|
||||
set auto_index(instvar_of_class) "source $dir/obtcl.tcl"
|
||||
set auto_index(instvar) "source $dir/obtcl.tcl"
|
||||
set auto_index(renamed_instvar) "source $dir/obtcl.tcl"
|
||||
set auto_index(is_object) "source $dir/obtcl.tcl"
|
||||
set auto_index(is_class) "source $dir/obtcl.tcl"
|
||||
set auto_index(otNew) "source $dir/obtcl.tcl"
|
||||
set auto_index(otProc) "source $dir/obtcl.tcl"
|
||||
set auto_index(otInstance) "source $dir/obtcl.tcl"
|
||||
set auto_index(otFreeObj) "source $dir/obtcl.tcl"
|
||||
set auto_index(class) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassDestroy) "source $dir/obtcl.tcl"
|
||||
set auto_index(otGetSelf) "source $dir/obtcl.tcl"
|
||||
set auto_index(otMkMethod) "source $dir/obtcl.tcl"
|
||||
set auto_index(otRmMethod) "source $dir/obtcl.tcl"
|
||||
set auto_index(otDelAllMethods) "source $dir/obtcl.tcl"
|
||||
set auto_index(otObjInfoVars) "source $dir/obtcl.tcl"
|
||||
set auto_index(otObjInfoObjects) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassInfoBody) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassInfoArgs) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassInfoMethods+Cached) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassInfoMethods) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassInfoSysMethods) "source $dir/obtcl.tcl"
|
||||
set auto_index(otClassInfoCached) "source $dir/obtcl.tcl"
|
||||
set auto_index(obtcl_mkindex) "source $dir/obtcl.tcl"
|
||||
set auto_index(cmt) "source $dir/utils.tcl"
|
||||
set auto_index(Nop) "source $dir/utils.tcl"
|
||||
set auto_index(setIfNew) "source $dir/utils.tcl"
|
||||
set auto_index(crunch_skip) "source $dir/utils.tcl"
|
||||
set auto_index(o_push) "source $dir/utils.tcl"
|
||||
set auto_index(o_pop) "source $dir/utils.tcl"
|
||||
set auto_index(o_peek) "source $dir/utils.tcl"
|
||||
set auto_index(lappendUniq) "source $dir/utils.tcl"
|
||||
set auto_index(listMinus) "source $dir/utils.tcl"
|
||||
set auto_index(otTkScrollButtonDown) "source $dir/utils.tcl"
|
||||
set auto_index(StrictMotif) "source $dir/utils.tcl"
|
||||
set auto_index(dbputs) "source $dir/utils.tcl"
|
||||
set auto_index(DOC) "source $dir/utils.tcl"
|
||||
set auto_index(DOC_get_list) "source $dir/utils.tcl"
|
||||
set auto_index(db_debug) "source $dir/utils.tcl"
|
||||
set auto_index(dbputs) "source $dir/utils.tcl"
|
||||
set auto_index(DOC_get_list) "source $dir/utils.tcl"
|
||||
set auto_index(DOC) "source $dir/utils.tcl"
|
||||
set auto_index(PrDOCS) "source $dir/utils.tcl"
|
||||
set auto_index(GetDOCS) "source $dir/utils.tcl"
|
||||
set auto_index(GetDOC) "source $dir/utils.tcl"
|
||||
set auto_index(help) "source $dir/utils.tcl"
|
||||
set auto_index(bpGetHelp) "source $dir/utils.tcl"
|
||||
set auto_index(bpOn) "source $dir/utils.tcl"
|
||||
set auto_index(bpID) "source $dir/utils.tcl"
|
||||
set auto_index(bpOff) "source $dir/utils.tcl"
|
||||
set auto_index(bp) "source $dir/utils.tcl"
|
||||
set auto_index(bpPrVar) "source $dir/utils.tcl"
|
||||
set auto_index(bpBody) "source $dir/utils.tcl"
|
||||
set auto_index(bpVisibleVars) "source $dir/utils.tcl"
|
||||
set auto_index(bpLocalVars) "source $dir/utils.tcl"
|
||||
set auto_index(bpGlobalVars) "source $dir/utils.tcl"
|
||||
set auto_index(bpTraceCalls) "source $dir/utils.tcl"
|
||||
set auto_index(bpShow) "source $dir/utils.tcl"
|
||||
set auto_index(MC) "source $dir/topsicom.tcl"
|
||||
set auto_index(GetNum) "source $dir/topsicom.tcl"
|
||||
set auto_index(DataSet) "source $dir/topsicom.tcl"
|
||||
set auto_index(ScanCommand) "source $dir/topsicom.tcl"
|
||||
set auto_index(LeftAlign) "source $dir/topsicom.tcl"
|
||||
set auto_index(massage) "source $dir/document.tcl"
|
||||
set auto_index(document_proc) "source $dir/document.tcl"
|
||||
set auto_index(document_title) "source $dir/document.tcl"
|
||||
set auto_index(document_program) "source $dir/document.tcl"
|
||||
set auto_index(document_section) "source $dir/document.tcl"
|
||||
set auto_index(document_example) "source $dir/document.tcl"
|
||||
set auto_index(document_widget) "source $dir/document.tcl"
|
||||
set auto_index(document_param) "source $dir/document.tcl"
|
||||
set auto_index(document_method) "source $dir/document.tcl"
|
||||
set auto_index(describe_self) "source $dir/document.tcl"
|
||||
set auto_index(get_rcsid) "source $dir/document.tcl"
|
||||
394
tcl/topsicom.tcl
394
tcl/topsicom.tcl
@ -1,394 +0,0 @@
|
||||
#----------------------------------------------------------------------------
|
||||
# Scan command implementation for TOPSI
|
||||
# Test version, Mark Koennecke, February 1997
|
||||
# Revised to use the built in Scan command
|
||||
# Mark Koennecke, October 1997
|
||||
# Requires a sics scan command called xxxscan
|
||||
#----------------------------------------------------------------------------
|
||||
set home /data/koenneck/src/sics/tcl
|
||||
set datapath /data/koenneck/src/tmp
|
||||
set recoverfil /data/koenneck/src/tmp/recover.bin
|
||||
|
||||
|
||||
source $home/utils.tcl
|
||||
source $home/obtcl.tcl
|
||||
source $home/base.tcl
|
||||
source $home/inherit.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]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# scan class initialization
|
||||
class ScanCommand
|
||||
|
||||
ScanCommand method init { counter } {
|
||||
instvar ScanData
|
||||
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(pinterest) " "
|
||||
set ScanData(Channel) 0
|
||||
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
|
||||
}
|
||||
ScanCommand method info {} {
|
||||
instvar ScanData ScanVar
|
||||
if { $ScanData(NoVar) < 1 } {
|
||||
return "0,1,NONE,0.,0.,default.dat"
|
||||
}
|
||||
append result $ScanData(NP) "," $ScanData(NoVar)
|
||||
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
|
||||
append result "," $ScanVar($i,Var)
|
||||
}
|
||||
append result "," $ScanVar(0,Start) "," $ScanVar(0,Step)
|
||||
set r1 [xxxscan getfile]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return $result
|
||||
}
|
||||
#---------------------- 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 {} {
|
||||
xxxscan interest
|
||||
}
|
||||
#----------------- interests ----------------------------------------------
|
||||
ScanCommand method uuinterest {} {
|
||||
xxxscan uuinterest
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
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
|
||||
}
|
||||
set tmp [string tolower $NewVal]
|
||||
set NewVal $tmp
|
||||
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 { } {
|
||||
return [xxxscan getfile]
|
||||
}
|
||||
#-------------------------------- channel --------------------------------
|
||||
ScanCommand method setchannel {num} {
|
||||
instvar ScanData
|
||||
set ret [catch {xxxscan setchannel $num} msg]
|
||||
if { $ret == 0} {
|
||||
set ScanData(Channel) $num
|
||||
} else {
|
||||
return $msg
|
||||
}
|
||||
}
|
||||
#-------------------------- 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 [format "%s.Channel = %d" $self $ScanData(Channel)]
|
||||
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) " "
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
xxxscan clear
|
||||
ClientPut OK
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method getcounts { } {
|
||||
return [xxxscan getcounts]
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method run { } {
|
||||
instvar ScanData
|
||||
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
|
||||
}
|
||||
set Active 1
|
||||
xxxscan clear
|
||||
for {set i 0 } { $i < $ScanData(NoVar)} {incr i} {
|
||||
set ret [catch {xxxscan add $ScanVar($i,Var) \
|
||||
$ScanVar($i,Start) $ScanVar($i,Step)} msg]
|
||||
if {$ret != 0} {
|
||||
set Active 0
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
set ret [catch \
|
||||
{xxxscan run $ScanData(NP) $ScanData(Mode) $ScanData(Preset)}\
|
||||
msg]
|
||||
set Active 0
|
||||
if {$ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
return "Scan Finished"
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
ScanCommand method recover { } {
|
||||
instvar Active
|
||||
|
||||
set Active 1
|
||||
catch {xxxscan recover} msg
|
||||
set Active 0
|
||||
return "Scan Finished"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# 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]]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
# Utility function which gives scan parameters as an easily parsable
|
||||
# comma separated list for java status client
|
||||
proc scaninfo {} {
|
||||
set result [scan info]
|
||||
set r1 [sample]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
append result "," [sicstime]
|
||||
set r1 [lastscancommand]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return [format "scaninfo = %s" $result]
|
||||
}
|
||||
398
tcl/utils.tcl
398
tcl/utils.tcl
@ -1,398 +0,0 @@
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# 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
|
||||
|
||||
|
||||
21
test.tcl
21
test.tcl
@ -49,7 +49,7 @@ ServerOption TelnetPort 1301
|
||||
ServerOption TelWord sicslogin
|
||||
|
||||
ServerOption DefaultTclDirectory $shome/sics/tcl
|
||||
ServerOption DefaultCommandFile topsicom.tcl
|
||||
ServerOption DefaultCommandFile ""
|
||||
|
||||
#------ a port for broadcasting UDP messages
|
||||
#ServerOption QuieckPort 2108
|
||||
@ -86,8 +86,6 @@ Title "TopsiTupsiTapsi"
|
||||
VarMake User Text User
|
||||
User "Daniel_the_Clementine"
|
||||
|
||||
VarMake lastscancommand Text User
|
||||
|
||||
VarMake detectordist Float Mugger
|
||||
detectordist 2500
|
||||
detectordist lock
|
||||
@ -180,10 +178,6 @@ source tcl/log.tcl
|
||||
|
||||
MakeDrive
|
||||
SicsAlias drive dr
|
||||
Publish scan Spy
|
||||
Publish ScanCounts Spy
|
||||
Publish TextStatus Spy
|
||||
Publish otUnknown Spy
|
||||
Publish LogBook Spy
|
||||
MakeRuenBuffer
|
||||
#---------------- TestVariables for Storage
|
||||
@ -227,14 +221,10 @@ banana CountMode Timer
|
||||
#banana configure Counter counter
|
||||
banana init
|
||||
ClientPut "HM initialized"
|
||||
source $shome/sics/tcl/topsicom.tcl
|
||||
source $shome/sics/tcl/scancom.tcl
|
||||
source $shome/sics/countf.tcl
|
||||
Publish count User
|
||||
Publish repeat user
|
||||
source $shome/sics/tcl/cscan.tcl
|
||||
Publish cscan User
|
||||
Publish sscan User
|
||||
Publish sftime Spy
|
||||
source $shome/sics/tcl/fit.tcl
|
||||
Publish fit Spy
|
||||
SerialInit
|
||||
@ -288,9 +278,6 @@ SicsAlias phi ph
|
||||
source tcl/reflist.tcl
|
||||
Publish rliste User
|
||||
|
||||
source tcl/susca.tcl
|
||||
Publish susca User
|
||||
MakeMaximize counter
|
||||
|
||||
source fcircle.tcl
|
||||
fcircleinit
|
||||
@ -302,7 +289,6 @@ ClientPut "Installed 4-circle stuff"
|
||||
|
||||
source transact.tcl
|
||||
Publish transact Spy
|
||||
Publish scaninfo Spy
|
||||
#MakeSPS suff lnsp26.psi.ch 4000 7
|
||||
|
||||
#source beamdt.tcl
|
||||
@ -373,3 +359,6 @@ source autofile.tcl
|
||||
autofilepath $shome/tmp/auto
|
||||
|
||||
MakeXYTable omth
|
||||
|
||||
Publish info user
|
||||
MakeLin2Ang a5l a5
|
||||
|
||||
398
utils.tcl
398
utils.tcl
@ -1,398 +0,0 @@
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# 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