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

Initial revision

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

791
tcl/base.tcl Normal file
View File

@ -0,0 +1,791 @@
crunch_skip begin
DOC "class Base" {
NAME
Base - The basic class inherited by all obTcl objects
SYNOPSIS
Base new <obj>
- Creates an object of the simplest possible class.
DESCRIPTION
All classes inherits the Base class automatically. The Base class
provides methods that are essential for manipulating obTcl-objects,
such as `info' and `destroy'.
METHODS
Base provides the following generic methods to all objects:
new - EXPERIMENTAL! Arranges to create a new object of
the class of the invoking object.
instance - EXPERIMENTAL! Arranges to create a new object of
the class of the invoking object. This method
differs from `new' by NOT automatically invoking
the `init' method of the new object.
One possible usage: Create a replacement for the
normal class object -a replacement which has no
hard-coded methods (this will need careful design
though).
init - Does nothing. The init method is automatically
invoked whenever an object is created with `new'.
destroy - Frees all instance variables of the object, and
the object itself.
class - Returns the class of the object.
set name ?value?
- Sets the instance variable `name' to value.
If no value is specified, the current value is
returned. Mainly used for debugging purposes.
info <cmd> - Returns information about the object. See INFO
below.
eval <script> - Evaluates `script' in the context of the object.
Useful for debugging purposes. Not meant to be
used for other purposes (create a method instead).
One useful trick (if you use the Tcl-debugger in
this package) is to enter:
obj eval bp
to be able to examine `obj's view of the world
(breakpoints must be enabled, of course).
unknown <method> <args>
- Automatically invoked when unknown methods are
invoked. the Base class defines this method to
print an error message, but this can be overridden
by derived classes.
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
- Define an option handler.
See OPTION HANDLER below for a description.
conf_verify <args>
conf_init <args>
- Set options. <args> are option-value pairs.
See OPTION HANDLER below for a description.
configure <args>
- Set options. <args> are option-value pairs.
See OPTION HANDLER below for a description.
cget <opt> - Get option value.
See OPTION HANDLER below for a description.
verify_unknown <args>
init_unknown <args>
configure_unknown <args>
cget_unknown <opt>
- These methods are automatically invoked when a requested
option has not been defined.
See OPTION HANDLER below for a description.
INFO
The method `info' can be used to inspect an object. In the list below
(I) means the command is only applicable to object instances, whereas
(C) means that the command can be applied either to the class object, or
to the object instance, if that is more convenient.
Existing commands:
instvars - (I) Returns the names of all existing instance variables.
iclassvars - (I) List instance class variables
classvars - (C) List class variables.
objects - (C) List objects of this class.
methods - (C) List methods defined in this class.
sysmethods - (C) List system methods defined in this class.
cached - (C) List cached methods for this class.
body <method> - (C) List the body of a method.
args <method> - (C) List formal parameters for a method.
options - (I) List the current option values in the format
"option-value pairs".
defaults - (C) List the current default values in the format
"option-value pairs". These values are the initial
values each new object will be given.
OPTION HANDLER
The method `option' is used to define options. It should be used on
the class-object, which serves as a repository for default values
and for code sections to run to verify and make use of new default values.
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
Define an option for this class.
Defining an option results in an instance variable
of the same name (with the leading '-' stripped)
being defined. This variable will be initiated
with the value <default>.
The sections `verify', `init' and `configure' can be defined.
`verify' is used to verify new parameters without affecting
the object. It is typically called by an object's init method
before all parts of the object have been created.
`init' is used for rare situations where some action should be taken
just after the object has been fully created. I.e when setting
the option variable via `verify' was not sufficient.
The `configure' section is invoked when the configure method is
called to re-configure an object.
Example usage:
class Graph
Graph inherit Widget
Graph option {-width} 300 verify {
if { $width >= 600 } {
error "width must be less than 600"
}
} configure {
$self.grf configure -width $width
}
Note 1: The `verify' section should never attempt
to access structures in the object (i.e widgets), since
it is supposed to be callable before they exist!
Use the `configure' section to manipulate the object.
Note 2: Using "break" or "error" in the verify section results
in the newly specified option value being rejected.
conf_verify <args>
Invoke all "verify" sections for options-value pairs
specified in <args>.
conf_init <args>
Invoke all "init" sections for options-value pairs
specified in <args>.
Example usage:
Graph method init { args } {
instvar width
# Set any option variables from $args
#
eval $self conf_verify $args ;# Set params
next -width $width ;# Get frame
CreateRestOfObject ;# Bogus
# Option handlers that wish to affect the
# object during init may declare an "init"
# section. Run any such sections now:
#
eval $self conf_init $args
}
Graph .graph -width 400 ;# Set width initially
configure <args>
Invoke all "configure" sections for options-value pairs
specified in <args>.
Example usage:
# First create object
#
Graph .graph -width 300
# Use `configure' to configure the object
#
.graph configure -width 200
cget <opt>
Returns the current value of option <opt>.
Example usage:
.graph cget -width
<sect>_unknown <args>
These methods are called when attempting to invoke sections
for unknown options. In this way a class may define methods
to catch usage of "configure", "cget", etc. for undefined
options.
Example:
Graph method configure_unknown { opt args } {
eval {$self-cmd configure $opt} $args
}
See the definitions of the Base and Widget classes for their
usage of these methods.
}
crunch_skip end
#----------------------------------------------------------------------
# Define the Base class. This class provides introspection etc.
#
# It also provides "set", which gives access to object
# internal variables, and 'eval' which lets you run arbitrary scripts in
# the objects context. You may wish to remove those methods if you
# want to disallow this.
class Base
Base method init args {}
Base method destroy args {
otFreeObj $self
}
Base method class args {
return $iclass
}
# Note: The `set' method takes on the class of the caller, so
# instvars will use the callers scope.
#
Base method set args {
set class $iclass
# instvar [lindex $args 0]
set var [lindex $args 0]
regexp -- {^([^(]*)\(.*\)$} $var m var
instvar $var
return [eval set $args]
}
Base method eval l {
return [eval $l]
}
Base method info { cmd args } {
switch $cmd {
"instvars" {return [eval {otObjInfoVars\
_oIV_${iclass}:${self}: _oIV_${iclass}:${self}:} $args]}
"iclassvars" {otObjInfoVars _oICV_${iclass}: _oICV_${iclass}: $args}
"classvars" {otObjInfoVars _oDCV_${iclass}: _oDCV_${iclass}: $args}
"objects" {otObjInfoObjects $iclass}
"methods" {otClassInfoMethods $iclass}
"sysmethods" {otClassInfoSysMethods $iclass}
"cached" {otClassInfoCached $iclass}
"body" {otClassInfoBody $iclass $args}
"args" {otClassInfoArgs $iclass $args}
"options" {$iclass::collectOptions values ret
return [array get ret] }
"defaults" {$iclass::collectOptions defaults ret
return [array get ret] }
default {
return -code error \
-errorinfo "Undefined command 'info $cmd'" \
"Undefined command 'info $cmd'"
}
}
}
Base method unknown args {
return -code error \
-errorinfo "Undefined method '$method' invoked" \
"Undefined method '$method' invoked"
}
#------- START EXPERIMENTAL
Base method new { obj args } {
eval {otNew $iclass $obj} $args
}
Base method instance { obj args } {
eval {otInstance $iclass $obj} $args
}
Base method sys_method args {
eval {otMkMethod S $iclass} $args
}
Base method method args {
eval {otMkMethod N $iclass} $args
}
Base method del_method args {
eval {otRmMethod $iclass} $args
}
Base method inherit args {
eval {otInherit $iclass} $args
}
# class AnonInst - inherit from this class to be able to generate
# anonymous objects. Example:
#
# class Foo
# Foo inherit AnonInst
# set obj [Foo new]
#
# NOTE: EXPERIMENTAL!!!
class AnonInst
AnonInst method anonPrefix p {
iclassvar _prefix
set _prefix $p
}
AnonInst method new {{obj {}} args} {
iclassvar _count _prefix
if ![info exists _count] {
set _count 0
}
if ![info exists _prefix] {
set _prefix "$iclass"
}
if ![string compare "" $obj] {
set obj $_prefix[incr _count]
}
eval next {$obj} $args
return $obj
}
#------- END EXPERIMENTAL
#----------------------------------------------------------------------
# Configure stuff
#----------------------------------------------------------------------
# The configuaration stuff is, for various reasons, probably the most
# change-prone part of obTcl.
#
# After fiddling around with various methods for handling options,
# this is what I came up with. It uses one method for each class and option,
# plus one dispatch-method for each of "conf_init", "conf_verify", "configure"
# and "cget" per class. Any extra sections in the `option' handler
# results in another dispatch-method being created.
# Attempts at handling undefined options are redirected to
#
# <section_name>_unknown
#
# Note:
# Every new object is initialized by a call to `initialize'.
# This is done in the proc "new", before `init' is called, to guarantee
# that initial defaults are set before usage. `initialize' calls "next", so
# all inherited classes are given a chance to set their initial defaults.
#
# Sections and their used (by convention):
#
# verify - Called at beginning of object initialization to verify
# specified options.
# init - Called at end of the class' `init' method.
# Use for special configuration.
# configure
# - This section should use the new value to configure
# the object.
#
# MkSectMethod - Define a method which does:
# For each option specified, call the handler for the specified section
# and option. If this fails, call the <section>_unknown handler.
# If this fails too, return an error.
# Note that the normal call of the method `unknown' is avoided by
# telling the unknown handler to avoid this (by means of the global array
# "_obTcl_unknBarred").
#
proc otMkSectMethod { class name sect } {
$class sys_method $name args "
array set Opts \$args
foreach i \[array names Opts\] {
global _obTcl_unknBarred
set _obTcl_unknBarred(\$class::${sect}:\$i) 1
if \[catch {\$class::$sect:\$i \$Opts(\$i)} err\] {
if \[catch {\$class::${sect}_unknown\
\$i \$Opts(\$i)}\] {
unset _obTcl_unknBarred(\$class::${sect}:\$i)
error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
\t\$err
\"
}
}
unset _obTcl_unknBarred(\$class::${sect}:\$i)
}
"
}
# Note: MkOptHandl is really a part of `option' below.
#
proc otMkOptHandl {} {
uplevel 1 {
$iclass sys_method "cget" opt "
classvar classOptions
if \[catch {$iclass::cget:\$opt} ret\] {
if \[catch {\$class::cget_unknown \$opt} ret\] {
error \"Unable to do 'cget \$opt'\"
}
}
return \$ret
"
otMkSectMethod $iclass conf_init init
$iclass sys_method initialize {} {
next
classvar optDefaults
eval instvar [array names optDefaults]
foreach i [array names optDefaults] {
set $i $optDefaults($i)
}
}
# arr - Out-param
#
$iclass sys_method collectOptions { mode arr } {
classvar classOptions optDefaults
upvar 1 $arr ret
next $mode ret
eval instvar [array names optDefaults]
foreach i [array names optDefaults] {
if [string compare "defaults" $mode] {
set ret(-$i) [set $classOptions(-$i)]
} else {
set ret(-$i) $optDefaults($i)
}
}
}
otMkSectMethod $iclass conf_verify verify
otMkSectMethod $iclass configure configure
set _optPriv(section,cget) 1
set _optPriv(section,init) 1
set _optPriv(section,initialize) 1
set _optPriv(section,verify) 1
set _optPriv(section,configure) 1
}
}
otMkSectMethod Base configure configure
# _optPriv is used for internal option handling house keeping
# Note: checking for existence of a proc is not always a good idea,
# since it may simply be a cached pointer to a inherited method.
#
Base method option { opt dflt args } {
classvar_of_class $iclass optDefaults classOptions _optPriv
set var [string range $opt 1 end]
set optDefaults($var) $dflt
set classOptions($opt) $var
array set tmp $args
if ![info exists _optPriv(initialize)] {
otMkOptHandl
set _optPriv(initialize) 1
}
foreach i [array names tmp] {
if ![info exists _optPriv(section,$i)] {
otMkSectMethod $iclass $i $i
set _optPriv(section,$i) 1
}
$iclass sys_method "$i:$opt" _val "
instvar $var
set _old_val \$[set var]
set $var \$_val
set ret \[catch {$tmp($i)} res\]
if {\$ret != 0 && \$ret != 2 } {
set $var \$_old_val
return -code \$ret -errorinfo \$res \$res
}
return \$res
"
set _optPriv($i:$opt) 1
}
if ![info exists _optPriv(cget:$opt)] {
$iclass sys_method "cget:$opt" {} "
instvar $var
return \$[set var]
"
set _optPriv(cget:$opt) 1
}
if ![info exists tmp(verify)] {
$iclass sys_method "verify:$opt" _val "
instvar $var
set $var \$_val
"
set _optPriv(verify:$opt) 1
}
if ![info exists tmp(configure)] {
$iclass sys_method "configure:$opt" _val "
instvar $var
set $var \$_val
"
set _optPriv(configure:$opt) 1
}
if ![info exists tmp(init)] {
$iclass sys_method "init:$opt" _val {}
set _optPriv(init:$opt) 1
}
}
# Default methods for non-compulsory
# standard sections in an option definition:
#
Base sys_method init_unknown { opt val } {}
Base sys_method verify_unknown { opt val } {}
# Catch initialize for classes which have no option handlers:
#
Base sys_method initialize {} {}
# Catch conf_init in case no option handlers have been defined.
#
Base sys_method conf_init {} {}
crunch_skip begin
#----------------------------------------------------------------------
#
# class Widget
# Base class for obTcl's Tk-widgets.
#
DOC "class Widget (Tk) base class for widgets" {
NAME
Widget - A base class for mega-widgets
SYNOPSIS
Widget new <obj> ?tk_widget_type? ?config options?
Widget <obj> ?tk_widget_type? ?config options?
DESCRIPTION
The widget class provides a base class for Tk-objects.
This class knows about widget naming conventions, so, for example,
destroying a Widget object will destroy any descendants of this object.
The `new' method need not be specified if the object name starts with a
leading ".". Thus giving syntactical compatibility with Tk for
creating widgets.
If `tk_widget_type' is not specified, the widget will be created as
a `frame'. If the type is specified it must be one of the existing
Tk-widget types, for example: button, radiobutton, text, etc.
See the Tk documentation for available widget types.
The normal case is to use a frame as the base for a mega-widget.
This is also the recommended way, since it results in the Tk class-name
of the frame being automatically set to the objects class name -thus
resulting in "winfo class <obj>" returning the mega-widget's class
name.
In order to create mega-widgets, derive new classes from this class.
METHODS
The following methods are defined in Widget:
init ?<args>? - Creates a frame widget, and configures it if any
configuration options are present. Automatically
invoked by the creation process, so there is no
need to call it (provided that you use 'next' in
the init-method of the derived class).
destroy - Destroys the object and associated tk-widget.
For Tk-compatibility, the function `destroy' can be
used instead, example:
destroy <obj>
Note: If you plan to mix Tk-widgets transparently
with mega-widgets, you should use the _function_
`destroy'.
Any descendant objects of <obj> will also be
destroyed (this goes for both Tk-widgets and
mega-widgets).
set - Overrides the `set' method of the Base class to
allow objects of type `scrollbar' to work correctly.
unknown - Overrides the `unknown' method of the Base class.
Directs any unknown methods to the main frame of
the Widget object.
unknown_opt - Overrides the same method from the Base class.
Automatically called from the option handling system.
Directs any unknown options to the main frame of the
Widget object.
In addition, all non-shadowed methods from the Base class can be used.
Any method that cannot be resolved is passed on to the associated
Tk-widget. This behaviour can be altered for any derived classes
by defining a new `unknown' method (thus shadowing Widget's own
`unknown' method). The same technique can be used to override
the `unknown_opt' method.
EXAMPLES
A simple example of deriving a class MegaButton which consists of
a button widget initiated with the text "MEGA" (yes, I know, it's
silly).
class MegaButton
MegaButton inherit Widget
MegaButton method init { args } {
#
# Allow the Widget class to create a button for us
# (we need to specify widget type `button')
#
eval next button $args
$self configure -text "MEGA"
}
frame .f
MegaButton .f.b -background red -foreground white
pack .f .f.b
This example shows how to specify a Tk-widget type (button), although
I advice against specifying anything (thus using a frame).
See DESCRIPTION above for the reasoning behind this. Also note that
`eval' is used to split $args into separate arguments for passing to
the init method of the Widget class.
A more realistic example:
class ScrolledText
ScrolledText inherit Widget
ScrolledText method init { args } {
next
text $self.t -yscrollcommand "$self.sb set"
scrollbar $self.sb -command "$self.t yview"
pack $self.sb -side right -fill y
pack $self.t -side left
eval $self configure $args
}
ScrolledText method unknown { args } {
eval {$self.t $method} $args
}
ScrolledText .st
.st insert end [exec cat /etc/passwd]
pack .st
This creates a new class, ScrolledText, containing a text window
and a vertical scrollbar. It arranges for all unknown methods to
be directed to the text widget; thus allowing `.st insert' to work
normally (along with any other text methods).
NOTES
Widget binds the "destroy" method to the <Destroy> event of
the holding window, so be careful not to remove this binding
inadvertently.
}
crunch_skip end
class Widget
# init Create a tk-widget of specified type (or frame if not specified).
# If the corresponding Tk-widget already exists, it will be used.
# Otherwise the Tk-widget will be created.
# The tk-widget will be named $self if $self has a leading ".",
# otherwise a "." is prepended to $self to form the wigdet name.
# The instvar `win' will contain the widgets window name, and
# the instvar `wincmd' will contain the name of the widget's associated
# command.
Widget method init args {
instvar win wincmd
next
set first "[lindex $args 0]"
set c1 "[string index $first 0]"
if { ![string compare "" "$c1"] || ![string compare "-" "$c1"] } {
set type frame
set cl "-class $iclass"
} else {
set type $first
set args [lrange $args 1 end]
set cl ""
}
if [string compare "" [info commands $self-cmd]] {
set win $self
set wincmd $self-cmd
} else {
if ![string compare "." [string index $self 0]] {
rename $self _ooTmp
eval $type $self $cl $args
rename $self $self-cmd
rename _ooTmp $self
set win $self
set wincmd $self-cmd
} else {
eval $type .$self $cl $args
set win .$self
#set wincmd .$self-cmd
set wincmd .$self
}
}
bind $win <Destroy> "\
if { !\[string compare \"%W\" \"$self\"\] && !\[catch {info args $self}\] } {
$self destroy -obj_only }"
return $self
}
# Just for the case when there are no option-handlers defined:
#
Widget sys_method configure args {
instvar wincmd
eval {$wincmd configure} $args
}
Widget sys_method cget opt {
instvar wincmd
eval {$wincmd cget} $opt
}
Widget sys_method configure_unknown { opt args } {
instvar wincmd
eval {$wincmd configure $opt} $args
}
Widget sys_method cget_unknown opt {
instvar wincmd
$wincmd cget $opt
}
Widget sys_method init_unknown { opt val } {
puts "init_unknown: $opt $val (iclass=$iclass class=$class)"
}
Widget sys_method unknown args {
instvar wincmd
eval {$wincmd $method} $args
}
# Note: no "next" used! Does the `Base::destroy' stuff here for performance.
#
Widget method destroy args {
instvar win wincmd
# Must copy vars since they are destroyed by `otFreeObj'
set wp $win
set w $wincmd
otFreeObj $self
catch {bind $w <Destroy> {}}
if [string compare "-obj_only" $args] {
if [string compare $w $wp] {
rename $w $wp
}
if [string compare "-keepwin" $args] {
destroy $wp
}
}
}
# The method `set' defined here shadows the `set' method from Base.
# This allows wrapper objects around Tk-scrollbars to work correctly.
#
Widget sys_method set args {
instvar wincmd
eval {$wincmd set} $args
}
Widget sys_method base_set args {
eval Base::set $args
}

791
tcl/base8.tcl Normal file
View File

@ -0,0 +1,791 @@
crunch_skip begin
DOC "class Base" {
NAME
Base - The basic class inherited by all obTcl objects
SYNOPSIS
Base new <obj>
- Creates an object of the simplest possible class.
DESCRIPTION
All classes inherits the Base class automatically. The Base class
provides methods that are essential for manipulating obTcl-objects,
such as `info' and `destroy'.
METHODS
Base provides the following generic methods to all objects:
new - EXPERIMENTAL! Arranges to create a new object of
the class of the invoking object.
instance - EXPERIMENTAL! Arranges to create a new object of
the class of the invoking object. This method
differs from `new' by NOT automatically invoking
the `init' method of the new object.
One possible usage: Create a replacement for the
normal class object -a replacement which has no
hard-coded methods (this will need careful design
though).
init - Does nothing. The init method is automatically
invoked whenever an object is created with `new'.
destroy - Frees all instance variables of the object, and
the object itself.
class - Returns the class of the object.
set name ?value?
- Sets the instance variable `name' to value.
If no value is specified, the current value is
returned. Mainly used for debugging purposes.
info <cmd> - Returns information about the object. See INFO
below.
eval <script> - Evaluates `script' in the context of the object.
Useful for debugging purposes. Not meant to be
used for other purposes (create a method instead).
One useful trick (if you use the Tcl-debugger in
this package) is to enter:
obj eval bp
to be able to examine `obj's view of the world
(breakpoints must be enabled, of course).
unknown <method> <args>
- Automatically invoked when unknown methods are
invoked. the Base class defines this method to
print an error message, but this can be overridden
by derived classes.
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
- Define an option handler.
See OPTION HANDLER below for a description.
conf_verify <args>
conf_init <args>
- Set options. <args> are option-value pairs.
See OPTION HANDLER below for a description.
configure <args>
- Set options. <args> are option-value pairs.
See OPTION HANDLER below for a description.
cget <opt> - Get option value.
See OPTION HANDLER below for a description.
verify_unknown <args>
init_unknown <args>
configure_unknown <args>
cget_unknown <opt>
- These methods are automatically invoked when a requested
option has not been defined.
See OPTION HANDLER below for a description.
INFO
The method `info' can be used to inspect an object. In the list below
(I) means the command is only applicable to object instances, whereas
(C) means that the command can be applied either to the class object, or
to the object instance, if that is more convenient.
Existing commands:
instvars - (I) Returns the names of all existing instance variables.
iclassvars - (I) List instance class variables
classvars - (C) List class variables.
objects - (C) List objects of this class.
methods - (C) List methods defined in this class.
sysmethods - (C) List system methods defined in this class.
cached - (C) List cached methods for this class.
body <method> - (C) List the body of a method.
args <method> - (C) List formal parameters for a method.
options - (I) List the current option values in the format
"option-value pairs".
defaults - (C) List the current default values in the format
"option-value pairs". These values are the initial
values each new object will be given.
OPTION HANDLER
The method `option' is used to define options. It should be used on
the class-object, which serves as a repository for default values
and for code sections to run to verify and make use of new default values.
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
Define an option for this class.
Defining an option results in an instance variable
of the same name (with the leading '-' stripped)
being defined. This variable will be initiated
with the value <default>.
The sections `verify', `init' and `configure' can be defined.
`verify' is used to verify new parameters without affecting
the object. It is typically called by an object's init method
before all parts of the object have been created.
`init' is used for rare situations where some action should be taken
just after the object has been fully created. I.e when setting
the option variable via `verify' was not sufficient.
The `configure' section is invoked when the configure method is
called to re-configure an object.
Example usage:
class Graph
Graph inherit Widget
Graph option {-width} 300 verify {
if { $width >= 600 } {
error "width must be less than 600"
}
} configure {
$self.grf configure -width $width
}
Note 1: The `verify' section should never attempt
to access structures in the object (i.e widgets), since
it is supposed to be callable before they exist!
Use the `configure' section to manipulate the object.
Note 2: Using "break" or "error" in the verify section results
in the newly specified option value being rejected.
conf_verify <args>
Invoke all "verify" sections for options-value pairs
specified in <args>.
conf_init <args>
Invoke all "init" sections for options-value pairs
specified in <args>.
Example usage:
Graph method init { args } {
instvar width
# Set any option variables from $args
#
eval $self conf_verify $args ;# Set params
next -width $width ;# Get frame
CreateRestOfObject ;# Bogus
# Option handlers that wish to affect the
# object during init may declare an "init"
# section. Run any such sections now:
#
eval $self conf_init $args
}
Graph .graph -width 400 ;# Set width initially
configure <args>
Invoke all "configure" sections for options-value pairs
specified in <args>.
Example usage:
# First create object
#
Graph .graph -width 300
# Use `configure' to configure the object
#
.graph configure -width 200
cget <opt>
Returns the current value of option <opt>.
Example usage:
.graph cget -width
<sect>_unknown <args>
These methods are called when attempting to invoke sections
for unknown options. In this way a class may define methods
to catch usage of "configure", "cget", etc. for undefined
options.
Example:
Graph method configure_unknown { opt args } {
eval {$self-cmd configure $opt} $args
}
See the definitions of the Base and Widget classes for their
usage of these methods.
}
crunch_skip end
#----------------------------------------------------------------------
# Define the Base class. This class provides introspection etc.
#
# It also provides "set", which gives access to object
# internal variables, and 'eval' which lets you run arbitrary scripts in
# the objects context. You may wish to remove those methods if you
# want to disallow this.
class Base
Base method init args {}
Base method destroy args {
otFreeObj $self
}
Base method class args {
return $iclass
}
# Note: The `set' method takes on the class of the caller, so
# instvars will use the callers scope.
#
Base method set args {
set class $iclass
# instvar [lindex $args 0]
set var [lindex $args 0]
regexp -- {^([^(]*)\(.*\)$} $var m var
instvar $var
return [eval set $args]
}
Base method eval l {
return [eval $l]
}
Base method info { cmd args } {
switch $cmd {
"instvars" {return [eval {otObjInfoVars\
_oIV_${iclass}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
}

8
tcl/bgerror.tcl Executable file
View File

@ -0,0 +1,8 @@
proc bgerror err {
global errorInfo
set info $errorInfo
puts stdout $err
puts stdout "------------------------- StackTrace ---------------------"
puts $info
}

151
tcl/client.tcl Executable file
View File

@ -0,0 +1,151 @@
#!/data/koenneck/bin/tclsh
#----------------------------------------------------------------------------
# A command line client for SICS, written in plain Tcl.
# Just sends and reads commands from the SICServer
#
# Mark Koennecke, September 1996
#----------------------------------------------------------------------------
#---------- Data section
set sdata(test,host) lnsa06.psi.ch
set sdata(test,port) 2910
set sdata(dmc,host) lnsa05.psi.ch
set sdata(dmc,port) 3006
set sdata(topsi,host) lnsa03.psi.ch
set sdata(topsi,port) 9708
set sdata(sans,host) lnsa07.psi.ch
set sdata(sans,port) 2915
set sdata(user) Spy
set sdata(passwd) 007
set mysocket stdout
#--------------------------------------------------------------------------
proc bgerror err {
global errorInfo
set info $errorInfo
puts stdout $err
puts stdout "------------------------- StackTrace ---------------------"
puts $info
}
#--------------------------------- procedures section -----------------------
# Setting up the connection to the Server
proc StartConnection {host port} {
global mysocket
global sdata
# start main connection
set mysocket [socket $host $port]
puts $mysocket [format "%s %s" $sdata(user) $sdata(passwd)]
set ret [catch {flush $mysocket} msg]
if { $ret != 0} {
error "Server NOT running!"
}
fconfigure $mysocket -blocking 0
fconfigure $mysocket -buffering none
fileevent $mysocket readable GetData
after 5000
}
#----------------------------------------------------------------------------
proc GetData { } {
global mysocket
global b
if { [eof $mysocket] } {
puts stdout "Connection to server lost"
close $mysocket
set b 1
return
}
set buf [read $mysocket]
set buf [string trim $buf]
set list [split $buf \n]
foreach teil $list {
set teil [string trimright $teil]
puts stdout $teil
}
puts -nonewline stdout "SICS> "
flush stdout
}
#---------------------------------------------------------------------------
proc SendCommand { text} {
global mysocket
global b
if { [eof $mysocket] } {
puts stdout "Connection to server lost"
set b 1
}
puts $mysocket $text
flush $mysocket
}
#----------------------------------------------------------------------------
proc readProgA {pid} {
global readProgADone;
global b
global mysocket
# read outputs of schemdb
set tmpbuf [gets $pid];
if {[string first quit $tmpbuf] > -1 } {
close $mysocket
puts stdout "Closing connection to SICS server on your request..."
puts stdout "Bye, bye, have a nice day!"
set b 1
} elseif { [string first stop $tmpbuf] > -1} {
SendCommand "INT1712 3"
} else {
SendCommand $tmpbuf
}
set readProgADone [eof $pid];
if {$readProgADone} {
puts "closing...";
catch [close $pid] aa;
if {$aa != ""} {
puts "HERE1: Error on closing";
exit 1;
}
}
}
#-------------------------- 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 PrintHeader { } {
global instrument
puts stdout [format "%s Welcome to SICS! %s" [MC " " 30] [MC " " 30]]
puts stdout [format "%s You are connected to: %s" [MC " " 29] [MC " " 29]]
puts stdout [format "%s %s %s" [MC " " 35] $instrument [MC " " 35]]
puts stdout "SICS> "
flush stdout
}
#-------------------------------- "MAIN" -----------------------------------
if {$argc < 1} {
puts stdout "Usage: client instrumentname"
exit 0
}
#----------------- StartConnection
set instrument [lindex $argv 0]
set ret [catch {StartConnection $sdata($instrument,host) \
$sdata($instrument,port)} msg ]
if {$ret != 0} {
puts stdout $msg
exit 1
}
#----------------- print header
PrintHeader
# set the "read" event
fileevent stdin readable {readProgA stdin};
#---loop till exit
set b 0
vwait b
exit 0

45
tcl/count.tcl Normal file
View File

@ -0,0 +1,45 @@
#--------------------------------------------------------------------------
# A count command for DMC
# All arguments are optional. The current values will be used if not
# specified
# Dr. Mark Koennecke, Juli 1997
#--------------------------------------------------------------------------
proc SplitReply { text } {
set l [split $text =]
return [lindex $l 1]
}
#--------------------------------------------------------------------------
proc count { {mode NULL } { preset NULL } } {
#----- deal with mode
set mode2 [string toupper $mode]
set mode3 [string trim $mode2]
set mc [string index $mode2 0]
if { [string compare $mc T] == 0 } {
banana CountMode Timer
} elseif { [string compare $mc M] == 0 } {
banana CountMode Monitor
}
#------ deal with preset
if { [string compare $preset NULL] != 0 } {
banana preset $preset
}
#------ prepare a count message
set a [banana preset]
set aa [SplitReply $a]
set b [banana CountMode]
set bb [SplitReply $b]
ClientPut [format " Starting counting in %s mode with a preset of %s" \
$bb $aa]
#------- count
banana InitVal 0
banana count
Success
#------- StoreData
# ClientPut [StoreData]
}
#---------------- Repeat -----------------------------------------------
proc repeat { num {mode NULL} {preset NULL} } {
for { set i 0 } { $i < $num } { incr i } {
count $mode $preset
}
}

126
tcl/cscan.tcl Normal file
View File

@ -0,0 +1,126 @@
#----------------------------------------------------------------------------
# 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
}
}

3
tcl/d.tcl Normal file
View File

@ -0,0 +1,3 @@
set home /data/koenneck/src/sics/tcl
set datapath /data/koenneck/src/sics/tmp
set recoverfil /data/koenneck/src/sics/recover.dat

52
tcl/fit.tcl Normal file
View File

@ -0,0 +1,52 @@
#-----------------------------------------------------------------------------
# This is an implementation for a fit command for SICS. It uses a separate
# fit program retrieved from the vast spaces of the net for this purpose.
# The scheme is as follows: Data is written to a file, the fit program is
# executed and the data retrieved at need.
#
# Mark Koennecke, October 1997
#----------------------------------------------------------------------------
#----- Initialise this to match your setup
set fithome /data/koenneck/src/sics/fit
set scancom xxxscan
set IIcentervar ""
proc fit__run { } {
global fithome
global scancom
global IIcentervar
#---------------
set cp [$scancom getcounts]
set cp2 [split $cp =]
set Counts [lindex $cp2 1]
set fp [$scancom getvardata 0]
set fp2 [split $fp = ]
set fitpar [lindex $fp2 1]
#----- set center variable
set bg [lindex $fp2 1]
set bg2 [split $bg .]
set IIcentervar [lindex $bg2 1]
unset cp
unset cp2
unset fp
unset fp2
unset bg
unset bg2
#---- write fit input file
set fd [open $fithome/sicsin.dat w]
set length [llength $Counts]
for {set i 0 } { $i < $length } { incr i} {
puts $fd [format " %f %d" [lindex $fitpar $i] \
[lindex $Counts $i] ]
}
close $fd
}
proc fit args {
set l [llength $args]
if { $l < 1} {
fit__run
}
}

5
tcl/g.tcl Normal file
View File

@ -0,0 +1,5 @@
#--------------------------------------------------------------------------
proc GetNum { text } {
set list [split $text =]
return [lindex $list 1]
}

297
tcl/inherit.tcl Normal file
View File

@ -0,0 +1,297 @@
#----------------------------------------------------------------------
# Method resolution and caching
#
proc otPrInherits {} {
global _obTcl_Classes
foreach i [array names _obTcl_Classes]\
{puts "$i inherits from: [$i inherit]"}
}
proc otInherit { class args } {
global _obTcl_Inherits
if ![string compare "" $args] {
return [set _obTcl_Inherits($class)]
}
if { [string compare "Base" $class] && [lsearch $args "Base"] == -1 } {
set args [concat $args "Base"]
}
if [info exists _obTcl_Inherits($class)] {
#
# This class is not new, invalidate caches
#
otInvalidateCaches 0 $class [otClassInfoCached ${class}]
} else {
set _obTcl_Inherits($class) {}
}
set _obTcl_Inherits($class) $args
}
proc otInvalidateCaches { level class methods } {
global _obTcl_CacheStop
foreach i $methods {
if ![string compare "unknown" $i] { set i "*" }
set _obTcl_CacheStop($i) 1
}
if [array exists _obTcl_CacheStop] { otDoInvalidate }
}
# There is a catch on rename and unset since current build of tmp
# does not guarantee that each element is unique.
proc otDoInvalidate {} {
global _obTcl_CacheStop _obTcl_Cached
if ![array exists _obTcl_Cached] {
unset _obTcl_CacheStop
return
}
if [info exists _obTcl_CacheStop(*)] {
set stoplist "*"
} else {
set stoplist [array names _obTcl_CacheStop]
}
foreach i $stoplist {
set tmp [array names _obTcl_Cached *::$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 Normal file
View File

@ -0,0 +1,297 @@
#----------------------------------------------------------------------
# Method resolution and caching
#
proc otPrInherits {} {
global _obTcl_Classes
foreach i [array names _obTcl_Classes]\
{puts "$i inherits from: [$i inherit]"}
}
proc otInherit { class args } {
global _obTcl_Inherits
if ![string compare "" $args] {
return [set _obTcl_Inherits($class)]
}
if { [string compare "Base" $class] && [lsearch $args "Base"] == -1 } {
set args [concat $args "Base"]
}
if [info exists _obTcl_Inherits($class)] {
#
# This class is not new, invalidate caches
#
otInvalidateCaches 0 $class [otClassInfoCached ${class}]
} else {
set _obTcl_Inherits($class) {}
}
set _obTcl_Inherits($class) $args
}
proc otInvalidateCaches { level class methods } {
global _obTcl_CacheStop
foreach i $methods {
if ![string compare "unknown" $i] { set i "*" }
set _obTcl_CacheStop($i) 1
}
if [array exists _obTcl_CacheStop] { otDoInvalidate }
}
# There is a catch on rename and unset since current build of tmp
# does not guarantee that each element is unique.
proc otDoInvalidate {} {
global _obTcl_CacheStop _obTcl_Cached
if ![array exists _obTcl_Cached] {
unset _obTcl_CacheStop
return
}
if [info exists _obTcl_CacheStop(*)] {
set stoplist "*"
} else {
set stoplist [array names _obTcl_CacheStop]
}
foreach i $stoplist {
set tmp [array names _obTcl_Cached *VV$i]
eval lappend tmp [array names _obTcl_Cached *VV${i}_next]
foreach k $tmp {
catch {
rename $k {}
unset _obTcl_Cached($k)
}
}
}
if ![array size _obTcl_Cached] {
unset _obTcl_Cached
}
unset _obTcl_CacheStop
}
if ![string compare "" [info procs otUnknown]] {
rename unknown otUnknown
}
proc otResolve { class func } {
return [otGetFunc 0 $class $func]
}
#----------------------------------------------------------------------
#
# `unknown' and `next' both create cache methods.
#
#----------------------------------------------------------------------
#
# unknown -
# A missing function was found. See if it can be resolved
# from inheritance.
#
# If function name does not follow the *VV* pattern, call the normal
# unknown handler.
#
# Umethod is for use by the "unknown" method. If the method is named
# `unknown' it will have $method set to $Umethod (the invokers method
# name).
#
setIfNew _obTcl_unknBarred() ""
proc unknown args {
global _obTcl_unknBarred
# Resolve inherited function calls
#
set name [lindex $args 0]
if [string match *VV* $name] {
set tmp [split $name V]
set class [lindex $tmp 0]
set func [join [lrange $tmp 2 end] V]
set flist [otGetFunc 0 $class $func]
if ![string compare "" $flist] {
if [info exists _obTcl_unknBarred($name)] { return -code error }
set flist [otGetFunc 0 $class "unknown"]
}
if [string compare "" $flist] {
proc $name args "otGetSelf
set Umethod $func
eval [lindex $flist 0] \$args"
} else {
proc $name args "
return -code error\
-errorinfo \"Undefined method '$func' invoked\" \
\"Undefined method '$func' invoked\"
"
}
global _obTcl_Cached
set _obTcl_Cached(${class}VV$func) $class
# Code below borrowed from init.tcl (tcl7.4)
#
global errorCode errorInfo
set code [catch {uplevel $args} msg]
if { $code == 1 } {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
} else {
uplevel [concat otUnknown $args]
}
}
setIfNew _obTcl_Cnt 0
# 6/11/95 Added _obTcl_nextRet to allow propagation of return-values
# from `next' calls. I.e doing `return [next $args]' will
# be meaningful. It is only in simple cases that the return
# value is shure to make sense. With multiple inheritance
# it may be impossible to rely on!
#
# NOTE: This support is experimental and likely to be removed!!!
#
# Improved for lower overhead with big args-lists
# NOTE: It is understood that `args' is initialized from the `next'
# procedure.
#
proc otChkCall { cmd } {
global _obTcl_Trace _obTcl_Cnt _obTcl_nextRet
if ![info exists _obTcl_Trace($cmd)] {
set _obTcl_Trace($cmd) 1
catch {uplevel 1 "uplevel 1 \"$cmd \$args\""} _obTcl_nextRet
}
return $_obTcl_nextRet
}
# otNextPrepare is really just a part of proc `next' below.
#
proc otNextPrepare {} {
uplevel 1 {
set all [otGetNextFunc $class $method]
foreach i $all {
# Note: args is the literal _name_ of var to use, hence
# no $-sign!
append tmp "otChkCall $i\n"
}
if [info exists tmp] {
proc $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 Normal file
View File

@ -0,0 +1,616 @@
# 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 Normal file
View File

@ -0,0 +1,293 @@
#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 Normal file
View File

@ -0,0 +1,617 @@
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#----------------------------------------------------------------------------
#
# Modified by Mark Koennecke in order to redirect unknown into the Sics
# mechanism. Thereby disabling command shortcuts and execution of shell
# commands for security reasons.
#
# February 1997
# Hacked for Tcl 8.0 September 1997, bad hack if problems start anew
#
#---------------------------------------------------------------------------
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.0
#if [catch {set auto_path $env(TCLLIBPATH)}] {
# set auto_path ""
#}
if {[lsearch -exact $auto_path [info library]] < 0} {
lappend auto_path [info library]
}
catch {
foreach dir $tcl_pkgPath {
if {[lsearch -exact $auto_path $dir] < 0} {
lappend auto_path $dir
}
}
unset dir
}
package unknown tclPkgUnknown
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
# exec hereby disabled for Security reasons! MK
set auto_noexec 1
set errorCode ""
set errorInfo ""
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
# command available:
#
# 1. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 2. If the command was invoked interactively at top-level:
# (a) see if the command exists as an executable UNIX program.
# If so, "exec" the command.
# (b) see if the command requests csh-like history substitution
# in one of the common forms !!, !<number>, or ^old^new. If
# so, emulate csh's history substitution.
# (c) see if the command is a unique abbreviation for another
# command. If so, invoke the command.
#
# Arguments:
# args - A list whose elements are the words of the original
# command, including the command name.
proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if ![info exists auto_noload] {
#
# Make sure we're not trying to load the same proc twice.
#
if [info exists unknown_pending($name)] {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
set ret [catch {auto_load $name} msg]
unset unknown_pending($name);
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error while autoloading \"$name\": $msg"
}
if ![array size unknown_pending] {
unset unknown_pending
}
if $msg {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel $args} msg]
if {$code == 1} {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
}
}
# Try running SICS for a change
set ret [catch {uplevel #0 SicsUnknown $args} msg]
if {$ret == 1} {
return -code error $msg
} else {
return -code ok $msg
}
}
# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them. If so, it sources the appropriate
# library file to create the procedure. Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments:
# cmd - Name of the command to find and load.
proc auto_load cmd {
global auto_index auto_oldpath auto_path env errorInfo errorCode
if [info exists auto_index($cmd)] {
uplevel #0 $auto_index($cmd)
return [expr {[info commands $cmd] != ""}]
}
if ![info exists auto_path] {
return 0
}
if [info exists auto_oldpath] {
if {$auto_oldpath == $auto_path} {
return 0
}
}
set auto_oldpath $auto_path
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set f ""
if [catch {set f [open [file join $dir tclIndex]]}] {
continue
}
set error [catch {
set id [gets $f]
if {$id == "# Tcl autoload index file, version 2.0"} {
eval [read $f]
} elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
if {([string index $line 0] == "#")
|| ([llength $line] != 2)} {
continue
}
set name [lindex $line 0]
set auto_index($name) \
"source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg]
if {$f != ""} {
close $f
}
if $error {
error $msg $errorInfo $errorCode
}
}
if [info exists auto_index($cmd)] {
uplevel #0 $auto_index($cmd)
if {[info commands $cmd] != ""} {
return 1
}
}
return 0
}
if {[string compare $tcl_platform(platform) windows] == 0} {
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions. Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
global auto_execs env tcl_platform
if [info exists auto_execs($name)] {
return $auto_execs($name)
}
set auto_execs($name) ""
if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename
ren rmdir rd time type ver vol} $name] != -1} {
if {[info exists env(COMSPEC)]} {
set comspec $env(COMSPEC)
} elseif {[info exists env(ComSpec)]} {
set comspec $env(ComSpec)
} elseif {$tcl_platform(os) == "Windows NT"} {
set comspec "cmd.exe"
} else {
set comspec "command.com"
}
return [set auto_execs($name) [list $comspec /c $name]]
}
if {[llength [file split $name]] != 1} {
foreach ext {{} .com .exe .bat} {
set file ${name}${ext}
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) $file]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
} elseif {[info exists env(windir)]} {
set windir $env(windir)
}
if {[info exists windir]} {
if {$tcl_platform(os) == "Windows NT"} {
append path "$windir/system32;"
}
append path "$windir/system;$windir;"
}
if {! [info exists env(PATH)]} {
if [info exists env(Path)] {
append path $env(Path)
} else {
return ""
}
} else {
append path $env(PATH)
}
foreach dir [split $path {;}] {
if {$dir == ""} {
set dir .
}
foreach ext {{} .com .exe .bat} {
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) $file]
}
}
}
return ""
}
} else {
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to an executable in the path. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
# Unix version.
#
proc auto_execok name {
global auto_execs env
if [info exists auto_execs($name)] {
return $auto_execs($name)
}
set auto_execs($name) ""
if {[llength [file split $name]] != 1} {
if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) $name
}
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
if {$dir == ""} {
set dir .
}
set file [file join $dir $name]
if {[file executable $file] && ![file isdirectory $file]} {
set auto_execs($name) $file
return $file
}
}
return ""
}
}
# auto_reset --
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments:
# None.
proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tclPkgUnknown} $p] < 0)} {
rename $p {}
}
}
catch {unset auto_execs}
catch {unset auto_index}
catch {unset auto_oldpath}
}
# auto_mkindex --
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
# locate all of the relevant files.
#
# Arguments:
# dir - Name of the directory in which to create an index.
# args - Any number of additional arguments giving the
# names of files within dir. If no additional
# are given auto_mkindex will look for *.tcl.
proc auto_mkindex {dir args} {
global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {$args == ""} {
set args *.tcl
}
foreach file [eval glob $args] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if [regexp {^proc[ ]+([^ ]*)} $line match procName] {
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg]
if $error {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts $f $index nonewline
close $f
cd $oldDir
} msg]
if $error {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
# pkg_mkIndex --
# This procedure creates a package index in a given directory. The
# package index consists of a "pkgIndex.tcl" file whose contents are
# a Tcl script that sets up package information with "package require"
# commands. The commands describe all of the packages defined by the
# files given as arguments.
#
# Arguments:
# dir - Name of the directory in which to create the index.
# args - Any number of additional arguments, each giving
# a glob pattern that matches the names of one or
# more shared libraries or Tcl script files in
# dir.
proc pkg_mkIndex {dir args} {
global errorCode errorInfo
append index "# Tcl package index file, version 1.0\n"
append index "# This file is generated by the \"pkg_mkIndex\" command\n"
append index "# and sourced either when an application starts up or\n"
append index "# by a \"package unknown\" script. It invokes the\n"
append index "# \"package ifneeded\" command to set up package-related\n"
append index "# information so that packages will be loaded automatically\n"
append index "# in response to \"package require\" commands. When this\n"
append index "# script is sourced, the variable \$dir must contain the\n"
append index "# full path name of this file's directory.\n"
set oldDir [pwd]
cd $dir
foreach file [eval glob $args] {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
# interpreter, and get a list of the new commands and packages
# that are defined. Define an empty "package unknown" script so
# that there are no recursive package inclusions.
set c [interp create]
# If Tk is loaded in the parent interpreter, load it into the
# child also, in case the extension depends on it.
foreach pkg [info loaded] {
if {[lindex $pkg 1] == "Tk"} {
$c eval {set argv {-geometry +0+0}}
load [lindex $pkg 0] Tk $c
break
}
}
$c eval [list set file $file]
if [catch {
$c eval {
proc dummy args {}
package unknown dummy
set origCmds [info commands]
set dir "" ;# in case file is pkgIndex.tcl
set pkgs ""
# Try to load the file if it has the shared library extension,
# otherwise source it. It's important not to try to load
# files that aren't shared libraries, because on some systems
# (like SunOS) the loader will abort the whole application
# when it gets an error.
if {[string compare [file extension $file] \
[info sharedlibextension]] == 0} {
# The "file join ." command below is necessary. Without
# it, if the file name has no \'s and we're on UNIX, the
# load command will invoke the LD_LIBRARY_PATH search
# mechanism, which could cause the wrong file to be used.
load [file join . $file]
set type load
} else {
source $file
set type source
}
foreach i [info commands] {
set cmds($i) 1
}
foreach i $origCmds {
catch {unset cmds($i)}
}
foreach i [package names] {
if {([string compare [package provide $i] ""] != 0)
&& ([string compare $i Tcl] != 0)
&& ([string compare $i Tk] != 0)} {
lappend pkgs [list $i [package provide $i]]
}
}
}
} msg] {
puts "error while loading or sourcing $file: $msg"
}
foreach pkg [$c eval set pkgs] {
lappend files($pkg) [list $file [$c eval set type] \
[lsort [$c eval array names cmds]]]
}
interp delete $c
}
foreach pkg [lsort [array names files]] {
append index "\npackage ifneeded $pkg\
\[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
[list $files($pkg)]\]"
}
set f [open pkgIndex.tcl w]
puts $f $index
close $f
cd $oldDir
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked
# as part of a "package ifneeded" script. It calls "package provide"
# to indicate that a package is available, then sets entries in the
# auto_index array so that the package's files will be auto-loaded when
# the commands are used.
#
# Arguments:
# dir - Directory containing all the files for this package.
# pkg - Name of the package (no version number).
# version - Version number for the package, such as 2.1.3.
# files - List of files that constitute the package. Each
# element is a sub-list with three elements. The first
# is the name of a file relative to $dir, the second is
# "load" or "source", indicating whether the file is a
# loadable binary or a script to source, and the third
# is a list of commands defined by this file.
proc tclPkgSetup {dir pkg version files} {
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {$type == "load"} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
# tclMacPkgSearch --
# The procedure is used on the Macintosh to search a given directory for files
# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the
# interpreter to setup the package database.
proc tclMacPkgSearch {dir} {
foreach x [glob -nocomplain [file join $dir *.shlb]] {
if [file isfile $x] {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {$y == "pkgIndex"} {source -rsrc pkgIndex}
}
resource close $res
}
}
}
# tclPkgUnknown --
# This procedure provides the default for the "package unknown" function.
# It is invoked when a package that's needed can't be found. It scans
# the auto_path directories and their immediate children looking for
# pkgIndex.tcl files and sources any such files that are found to setup
# the package database. (On the Macintosh we also search for pkgIndex
# TEXT resources in all files.)
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name version {exact {}}} {
global auto_path tcl_platform env
if ![info exists auto_path] {
return
}
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set file [file join $dir pkgIndex.tcl]
if [file readable $file] {
source $file
}
foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
if [file readable $file] {
set dir [file dirname $file]
source $file
}
}
# On the Macintosh we also look in the resource fork
# of shared libraries
if {$tcl_platform(platform) == "macintosh"} {
set dir [lindex $auto_path $i]
tclMacPkgSearch $dir
foreach x [glob -nocomplain [file join $dir *]] {
if [file isdirectory $x] {
set dir $x
tclMacPkgSearch $dir
}
}
}
}
}

292
tcl/initcl.c Normal file
View File

@ -0,0 +1,292 @@
#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;
}

228
tcl/ldAout.tcl Normal file
View File

@ -0,0 +1,228 @@
# ldAout.tcl --
#
# This "tclldAout" procedure in this script acts as a replacement
# for the "ld" command when linking an object file that will be
# loaded dynamically into Tcl or Tk using pseudo-static linking.
#
# Parameters:
# The arguments to the script are the command line options for
# an "ld" command.
#
# Results:
# The "ld" command is parsed, and the "-o" option determines the
# module name. ".a" and ".o" options are accumulated.
# The input archives and object files are examined with the "nm"
# command to determine whether the modules initialization
# entry and safe initialization entry are present. A trivial
# C function that locates the entries is composed, compiled, and
# its .o file placed before all others in the command; then
# "ld" is executed to bind the objects together.
#
# SCCS: @(#) ldAout.tcl 1.11 96/09/17 09:02:20
#
# Copyright (c) 1995, by General Electric Company. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This work was supported in part by the ARPA Manufacturing Automation
# and Design Engineering (MADE) Initiative through ARPA contract
# F33615-94-C-4400.
proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
global env
global argv
if {$cc==""} {
set cc $env(CC)
}
# if only two parameters are supplied there is assumed that the
# only shlib_suffix is missing. This parameter is anyway available
# as "info sharedlibextension" too, so there is no need to transfer
# 3 parameters to the function tclLdAout. For compatibility, this
# function now accepts both 2 and 3 parameters.
if {$shlib_suffix==""} {
set shlib_suffix $env(SHLIB_SUFFIX)
set shlib_cflags $env(SHLIB_CFLAGS)
} else {
if {$shlib_cflags=="none"} {
set shlib_cflags $shlib_suffix
set shlib_suffix [info sharedlibextension]
}
}
# seenDotO is nonzero if a .o or .a file has been seen
set seenDotO 0
# minusO is nonzero if the last command line argument was "-o".
set minusO 0
# head has command line arguments up to but not including the first
# .o or .a file. tail has the rest of the arguments.
set head {}
set tail {}
# nmCommand is the "nm" command that lists global symbols from the
# object files.
set nmCommand {|nm -g}
# entryProtos is the table of _Init and _SafeInit prototypes found in the
# module.
set entryProtos {}
# entryPoints is the table of _Init and _SafeInit entries found in the
# module.
set entryPoints {}
# libraries is the list of -L and -l flags to the linker.
set libraries {}
set libdirs {}
# Process command line arguments
foreach a $argv {
if {!$minusO && [regexp {\.[ao]$} $a]} {
set seenDotO 1
lappend nmCommand $a
}
if {$minusO} {
set outputFile $a
set minusO 0
} elseif {![string compare $a -o]} {
set minusO 1
}
if [regexp {^-[lL]} $a] {
lappend libraries $a
if [regexp {^-L} $a] {
lappend libdirs [string range $a 2 end]
}
} elseif {$seenDotO} {
lappend tail $a
} else {
lappend head $a
}
}
lappend libdirs /lib /usr/lib
# MIPS -- If there are corresponding G0 libraries, replace the
# ordinary ones with the G0 ones.
set libs {}
foreach lib $libraries {
if [regexp {^-l} $lib] {
set lname [string range $lib 2 end]
foreach dir $libdirs {
if [file exists [file join $dir lib${lname}_G0.a]] {
set lname ${lname}_G0
break
}
}
lappend libs -l$lname
} else {
lappend libs $lib
}
}
set libraries $libs
# Extract the module name from the "-o" option
if {![info exists outputFile]} {
error "-o option must be supplied to link a Tcl load module"
}
set m [file tail $outputFile]
set l [expr [string length $m] - [string length $shlib_suffix]]
if [string compare [string range $m $l end] $shlib_suffix] {
error "Output file does not appear to have a $shlib_suffix suffix"
}
set modName [string tolower [string range $m 0 [expr $l-1]]]
if [regexp {^lib} $modName] {
set modName [string range $modName 3 end]
}
if [regexp {[0-9\.]*(_g0)?$} $modName match] {
set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]]
}
set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
# Catalog initialization entry points found in the module
set f [open $nmCommand r]
while {[gets $f l] >= 0} {
if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] {
if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
set s $symbol
}
append entryProtos {extern int } $symbol { (); } \n
append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
}
}
close $f
if {$entryPoints==""} {
error "No entry point found in objects"
}
# Compose a C function that resolves the initialization entry points and
# embeds the required libraries in the object code.
set C {#include <string.h>}
append C \n
append C {char TclLoadLibraries_} $modName { [] =} \n
append C { "@LIBS: } $libraries {";} \n
append C $entryProtos
append C {static struct } \{ \n
append C { char * name;} \n
append C { int (*value)();} \n
append C \} {dictionary [] = } \{ \n
append C $entryPoints
append C { 0, 0 } \n \} \; \n
append C {typedef struct Tcl_Interp Tcl_Interp;} \n
append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
append C {Tcl_PackageInitProc *} \n
append C TclLoadDictionary_ $modName { (symbol)} \n
append C { char * symbol;} \n
append C {{
int i;
for (i = 0; dictionary [i] . name != 0; ++i) {
if (!strcmp (symbol, dictionary [i] . name)) {
return dictionary [i].value;
}
}
return 0;
}} \n
# Write the C module and compile it
set cFile tcl$modName.c
set f [open $cFile w]
puts -nonewline $f $C
close $f
set ccCommand "$cc -c $shlib_cflags $cFile"
puts stderr $ccCommand
eval exec $ccCommand
# Now compose and execute the ld command that packages the module
set ldCommand ld
foreach item $head {
lappend ldCommand $item
}
lappend ldCommand tcl$modName.o
foreach item $tail {
lappend ldCommand $item
}
puts stderr $ldCommand
eval exec $ldCommand
# Clean up working files
exec /bin/rm $cFile [file rootname $cFile].o
}

84
tcl/log.tcl Normal file
View File

@ -0,0 +1,84 @@
#-----------------------------------------------------------------------------
# This file implements a LogBook facility for SICS.
# Usage:
# LogBook - lists the current status
# LogBook filename - sets the logbook file name
# LogBook on - starts logging, creates new file
# LogBook off - closes log file
#
# Mark Koennecke, June 1997, initially developed for SANS
# works using one procedure and an array for data. All internal procedures
# start with cli
#----------------------------------------------------------------------------
set cliArray(file) default.log
set cliArray(status) off
set cliArray(number) 0
#---------------------------------------------------------------------------
proc cliList { } {
global cliArray
# ClientPut [format " LogBook file: %s\n" $cliArray(file)]
# ClientPut [format " Logging: %s " $cliArray(status)] ]
append res [format " LogBook file: %s\n" $cliArray(file)] \
[format " Logging: %s " $cliArray(status)]
return $res
}
#-------------------------------------------------------------------------
proc cliLogOn { } {
global cliArray
set cmd [list config File $cliArray(file)]
set ret [catch {eval $cmd} msg]
if { $ret != 0 } {
error $msg
} else {
set l [ split $msg = ]
set cliArray(number) [lindex $l 1]
set cliArray(status) on
}
}
#--------------------------------------------------------------------------
proc cliLogOff { } {
global cliArray
set cmd [list config close $cliArray(number)]
set ret [catch {eval $cmd} msg]
if { $ret != 0 } {
error $msg
} else {
set cliArray(status) off
}
}
#-------------------------------------------------------------------------
proc logbook args {
global cliArray
#---- first case: a listing
if { [llength $args] == 0} {
return [cliList]
}
#---- there must be an argument
set argument [lindex $args 0]
#---- on/ off
if {[string compare "on" $argument] == 0} {
set ret [catch {cliLogOn} msg]
if { $ret != 0 } {
error $msg
} else {
ClientPut OK
}
} elseif {[string compare "off" $argument] == 0} {
set ret [catch {cliLogOff} msg]
if { $ret != 0 } {
error $msg
} else {
ClientPut OK
}
} elseif {[string compare "file" $argument] >= 0} {
if {[llength $args] < 1} {
error "ERROR: nor filename specified for LogBook"
}
set cliArray(file) [lindex $args 1]
} elseif {[string compare "no" $argument] == 0} {
ClientPut $cliArray(number)
} else {
error [format "ERROR: unknown argument %s to LogBook" $argument]
}
}

540
tcl/obtcl.tcl Normal file
View File

@ -0,0 +1,540 @@
#----------------------------------------------------------------------
# -- obTcl --
#
# `obTcl' is a Tcl-only object- and Megawidget-extension.
#
# The system supports multiple inheritance, three new storage classes,
# and fully transparent Tk-megawidgets.
#
# Efficiency is obtained through method-resolution caching.
# obTcl provides real instance variables and class variables
# (they may be arrays). Two types of class variables are provided:
# definition-class scoped, and instance-class scoped.
#
# The mega-widget support allows creation of mega-widgets which handle
# like ordinary Tk-widgets; i.e can be "packed", "deleted", "placed" etc,
# intermixed with ordinary Tk-widgets.
# The transparency of the mega-widget extension has been tested by
# wrapping all normal Tk-widgets into objects and running the standard
# "widget" demo provided with Tk4.0.
#
# To try out obTcl, just start `wish' (Tk4.0 or later) and do "source demo".
# Alternatively run "demo" directly (requires that wish can be located
# by demo).
#
# If you run `wish' interactively and source `obtcl', you will be able to
# type "help" to access a simple help system.
#
# Pronunciation: `obTcl' sounds like "optical".
#
# See COPYRIGHT for copyright information.
#
# Please direct comments, ideas, complaints, etc. to:
#
# patrik@dynas.se
#
# Patrik Floding
# DynaSoft AB
#
#----------------------------------------------------------------------
# For convenience you may either append the installation directory of
# obTcl to your auto_path variable (the recommended method), or source
# `obtcl.tcl' into your script. Either way everything should work.
#
set OBTCL_LIBRARY [file dirname [info script]]
if { [lsearch -exact $auto_path $OBTCL_LIBRARY] == -1 } {
lappend auto_path $OBTCL_LIBRARY
}
set obtcl_version "0.56"
crunch_skip begin
cmt {
Public procs:
- Std. features
classvar
iclassvar
instvar
class
obtcl_mkindex
next
- Subj. to changes
instvar2global
classvar_of_class
instvar_of_class
import
renamed_instvar
is_object
is_class
Non public:
Old name New name (as of 0.54)
-------- ----------------------
new otNew
instance otInstance
freeObj otFreeObj
classDestroy otClassDestroy
getSelf otGetSelf
mkMethod otMkMethod
rmMethod otRmMethod
delAllMethods otDelAllMethods
objinfoVars otObjInfoVars
objinfoObjects otObjInfoObjects
classInfoBody otClassInfoBody
classInfoArgs otClassInfoArgs
classInfoMethods+Cached otClassInfoMethods+Cached
classInfoMethods otClassInfoMethods
classInfoSysMethods otClassInfoSysMethods
classInfoCached otClassInfoCached
inherit otInherit
InvalidateCaches otInvalidateCaches
chkCall otChkCall
GetNextFunc otGetNextFunc
GetFunc otGetFunc
GetFuncErr otGetFuncErr
GetFuncMissingClass otGetFuncMissingClass
}
crunch_skip end
proc instvar2global name {
upvar 1 class class self self
return _oIV_${class}:${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 Normal file
View File

@ -0,0 +1,540 @@
#----------------------------------------------------------------------
# -- obTcl --
#
# `obTcl' is a Tcl-only object- and Megawidget-extension.
#
# The system supports multiple inheritance, three new storage classes,
# and fully transparent Tk-megawidgets.
#
# Efficiency is obtained through method-resolution caching.
# obTcl provides real instance variables and class variables
# (they may be arrays). Two types of class variables are provided:
# definition-class scoped, and instance-class scoped.
#
# The mega-widget support allows creation of mega-widgets which handle
# like ordinary Tk-widgets; i.e can be "packed", "deleted", "placed" etc,
# intermixed with ordinary Tk-widgets.
# The transparency of the mega-widget extension has been tested by
# wrapping all normal Tk-widgets into objects and running the standard
# "widget" demo provided with Tk4.0.
#
# To try out obTcl, just start `wish' (Tk4.0 or later) and do "source demo".
# Alternatively run "demo" directly (requires that wish can be located
# by demo).
#
# If you run `wish' interactively and source `obtcl', you will be able to
# type "help" to access a simple help system.
#
# Pronunciation: `obTcl' sounds like "optical".
#
# See COPYRIGHT for copyright information.
#
# Please direct comments, ideas, complaints, etc. to:
#
# patrik@dynas.se
#
# Patrik Floding
# DynaSoft AB
#
#----------------------------------------------------------------------
# For convenience you may either append the installation directory of
# obTcl to your auto_path variable (the recommended method), or source
# `obtcl.tcl' into your script. Either way everything should work.
#
set OBTCL_LIBRARY [file dirname [info script]]
if { [lsearch -exact $auto_path $OBTCL_LIBRARY] == -1 } {
lappend auto_path $OBTCL_LIBRARY
}
set obtcl_version "0.56"
crunch_skip begin
cmt {
Public procs:
- Std. features
classvar
iclassvar
instvar
class
obtcl_mkindex
next
- Subj. to changes
instvar2global
classvar_of_class
instvar_of_class
import
renamed_instvar
is_object
is_class
Non public:
Old name New name (as of 0.54)
-------- ----------------------
new otNew
instance otInstance
freeObj otFreeObj
classDestroy otClassDestroy
getSelf otGetSelf
mkMethod otMkMethod
rmMethod otRmMethod
delAllMethods otDelAllMethods
objinfoVars otObjInfoVars
objinfoObjects otObjInfoObjects
classInfoBody otClassInfoBody
classInfoArgs otClassInfoArgs
classInfoMethods+Cached otClassInfoMethods+Cached
classInfoMethods otClassInfoMethods
classInfoSysMethods otClassInfoSysMethods
classInfoCached otClassInfoCached
inherit otInherit
InvalidateCaches otInvalidateCaches
chkCall otChkCall
GetNextFunc otGetNextFunc
GetFunc otGetFunc
GetFuncErr otGetFuncErr
GetFuncMissingClass otGetFuncMissingClass
}
crunch_skip end
proc instvar2global name {
upvar 1 class class self self
return _oIV_${class}V${self}V$name
}
# Class variables of definition class
if ![string compare [info commands classvar] ""] {
proc classvar args {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oDCV_\${class}V\$_obTcl_i \$_obTcl_i
}"
}
}
# Class variables of specified class
proc classvar_of_class { class args } {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oDCV_${class}V\$_obTcl_i \$_obTcl_i
}"
}
# Class variables of instance class
if ![string compare [info commands iclassvar] ""] {
proc iclassvar args {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oICV_\${iclass}V\$_obTcl_i \$_obTcl_i
}"
}
}
# Instance variables. Specific to instances.
# Make instvar from `class' available
# Use with caution! I might put these variables in a separate category
# which must be "exported" vaiables (as opposed to "instvars").
#
proc instvar_of_class { class args } {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oIV_${class}V\${self}V\$_obTcl_i \$_obTcl_i
}"
}
# Instance variables. Specific to instances.
if ![string compare [info commands instvar] ""] {
proc instvar args {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oIV_\${class}V\${self}V\$_obTcl_i \$_obTcl_i
}"
}
}
# Renamed Instance variable. Specific to instances.
proc renamed_instvar { normal_name new_name } {
uplevel 1 "upvar #0 _oIV_\${class}V\${self}V$normal_name $new_name"
}
# Check if an object exists
#
proc is_object name {
global _obTcl_Objects
if [info exists _obTcl_Objects($name)] {
return 1
} else {
return 0
}
}
# Check if a class exists
#
proc is_class name {
global _obTcl_Classes
if [info exists _obTcl_Classes($name)] {
return 1
} else {
return 0
}
}
#----------------------------------------------------------------------
# new Creates a new object. Creation involves creating a proc with
# the name of the object, initializing some house-keeping data,
# call `initialize' to set init any option-variables,
# and finally calling the `init' method for the newly created object.
#
# 951024. Added rename of any existing command to facilitate wrapping
# of existing widgets/commands. Only one-level wrapping is supported.
proc otNew { iclass obj args } {
global _obTcl_Objclass _obTcl_Objects
set _obTcl_Objclass($iclass,$obj) $obj
if ![info exists _obTcl_Objects($obj)] {
catch {rename $obj ${obj}-cmd}
}
set _obTcl_Objects($obj) 1
otProc $iclass $obj
set self $obj
eval {$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
}

9
tcl/obtcl_mkindex Executable file
View File

@ -0,0 +1,9 @@
#!/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
}

29
tcl/parray.tcl Normal file
View File

@ -0,0 +1,29 @@
# parray:
# Print the contents of a global array on stdout.
#
# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc parray {a {pattern *}} {
upvar 1 $a array
if ![array exists array] {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}

79
tcl/reflist.tcl Normal file
View File

@ -0,0 +1,79 @@
#---------------------------------------------------------------------------
# The first step when doing a four circle experiment is to search
# reflections manually. When some have been found a UB-matrix calculation
# can be tried. In between it is necessary to keep a list of peak positons
# found and to write them to file. This is exactly what this is for.
#
# Mark Koennecke, October 1998
#---------------------------------------------------------------------------
#----- where data files shall go by default
set prefix ./
#--------------------------------------------------------------------------
proc iiGetNum { text } {
set list [split $text =]
return [lindex $list 1]
}
#------------ clear everything
proc iiinit {} {
global iiref
set iiref(np) 0
set iiref(OM) ""
set iiref(TH) ""
set iiref(CH) ""
set iiref(PH) ""
set iiref(title) ""
}
#------- run this once when loading in order to empty space
iiinit
#------------------- store
proc iistore {} {
global iiref
incr iiref(np)
lappend iiref(OM) [iiGetNum [OM]]
lappend iiref(TH) [iiGetNum [TH]]
lappend iiref(CH) [iiGetNum [CH]]
lappend iiref(PH) [iiGetNum [PH]]
lappend iiref(title) [iiGetNum [title]]
}
#------------- write to file
proc iiwrite {fil} {
global iiref
global prefix
set fd [open $prefix/$fil w]
for {set i 0} {$i < $iiref(np)} { incr i } {
set om [lindex $iiref(OM) $i]
set th [lindex $iiref(TH) $i]
set ch [lindex $iiref(CH) $i]
set ph [lindex $iiref(PH) $i]
set tt [lindex $iiref(title) $i]
puts $fd [format "%8.2f %8.2f %8.2f %8.2f %d %s" $th $om $ch $ph $i $tt]
}
close $fd
}
#------------------- the actual control implementation function
proc rliste args {
if {[llength $args] < 1} {
error "ERROR: keyword expected to rliste"
}
switch [lindex $args 0] {
"clear" {
iiinit
return
}
"store" {
iistore
}
"write" {
if { [llength $args] < 2 } {
error "ERROR: expected filename after write"
}
iiwrite [lindex $args 1]
}
default {
error "ERROR: keyword [lindex $args 0] not recognized"
}
}
}

74
tcl/scan.tcl Normal file
View File

@ -0,0 +1,74 @@
#----------------------------------------------------------------------------
# A simple scan command for DMC. This allows scanning a motor against the
# monitors. This is useful for adjusting DMC. No fancy file writing is done.
# This code relies on (and checks for) the LogBook being active.
#
# Mark Koennecke, Juli 1997
#---------------------------------------------------------------------------
#----- internal: check LogBook is on.
proc scan:CheckLog { } {
set text [LogBook]
if { [string match Log*:*on $text] } {
return 1
} else {
return 0
}
}
#------ internal: get Monitor value
proc scan:monitor { num } {
set reply [counter GetMonitor $num]
set l [split $reply =]
return [lindex $l 1]
}
#------ actual scan command
proc scan { motor start step n {mode NULL } { preset NULL } } {
#----- check for existence of LogBook
# set ret [scan:CheckLog]
# if { $ret != 1 } {
# ClientPut "ERROR: logging must be active for scan"
# ClientPut $ret
# return
# }
#----- is motor reallly countable ?
set ret [SICSType $motor]
if { [string compare $ret "DRIV"] != 0 } {
ClientPut [format "ERROR: %s not drivable" $motor]
return
}
#----- deal with mode
set mode2 [string toupper $mode]
set mode3 [string trim $mode2]
set mc [string index $mode2 0]
if { [string compare $mc T] == 0 } {
banana CountMode Timer
} elseif { [string compare $mc M] == 0 } {
banana CountMode Monitor
}
#------ deal with preset
if { [string compare $preset NULL] != 0 } {
banana preset $preset
}
#------- write output header
ClientPut [format "%10.10s Monitor0 Monitor1" $motor]
#------ the scan loop
for { set i 0} { $i < $n } { incr i } {
#--------- drive
set pos [expr $start + $i * $step]
set ret [catch "drive $motor $pos" msg]
if { $ret != 0 } {
ClientPut "ERROR: driving motor"
ClientPut $msg
}
#---------- count
banana count
Success
#---------- create output
set m0 [scan:monitor 0]
set m1 [scan:monitor 1]
ClientPut [format "%10.2f %11.11d %11.11d" $pos $m0 $m1]
}
ClientPut "Scan finished !"
}

23
tcl/stdin.tcl Normal file
View File

@ -0,0 +1,23 @@
proc readProgA {pid} {
global readProgADone;
# read outputs of schemdb
set tmpbuf [gets $pid];
puts "received $tmpbuf\n";
set readProgADone [eof $pid];
if {$readProgADone} {
puts "closing...";
catch [close $pid] aa;
if {$aa != ""} {
puts "HERE1: Error on closing";
exit 1;
}
}
}
# set the "read" event
fileevent stdin readable {readProgA stdin};

62
tcl/susca.tcl Normal file
View File

@ -0,0 +1,62 @@
#----------------------------------------------------------------------------
# suchscan : a very fast scan. A motor is set to run, the counter is started
# and the counter read as fast as possible. Current motor position and
# counts are printed. For quick and dirty location of peaks.
#
# Mark Koennecke, October 1998
#---------------------------------------------------------------------------
proc scGetNum { text } {
set list [split $text =]
return [lindex $list 1]
}
# set the counter name
set ctr counter
#----------- check if var still driving
proc runtest {var } {
set t [listexe]
if {[string first $var $t] >= 0} {
return 1
} else {
return 0
}
}
#-------------------------- the actual susca
proc susca args {
global ctr
if {[llength $args] < 4} {
ClientPut "USAGE: susca var start length time"
error "ERROR: Insufficient number of arguments to susca"
}
#------ drive to start position
set var [lindex $args 0]
set start [lindex $args 1]
set end [lindex $args 2]
set ctime [lindex $args 3]
set ret [catch {drive $var $start} msg]
if {$ret != 0 } {
error "ERROR: $msg"
}
set last 0
#------- start counter
$ctr setmode timer
$ctr countnb $ctime
#-------- start motor
set ret [catch {run $var $end} msg]
if {$ret != 0 } {
error "ERROR: $msg"
}
#------ scan loop
while {[runtest $var] == 1} {
set ct [scGetNum [$ctr getcounts]]
set ncts [expr abs($ct - $last)]
set last $ct
set vp [scGetNum [$var]]
ClientPut [format "%8.2f %12.2f" $vp $ncts]
}
ClientPut "OK"
}

12
tcl/tail.tcl Normal file
View File

@ -0,0 +1,12 @@
#--------------------------------------------------------------------------
# Implementation of the SICS tail command. This uses the unix sicstail
# command which is defined for the instrument user.
#
# Mark Koennecke, June 1999
#-------------------------------------------------------------------------
proc tail { {n 20} } {
set txt [exec sicstail $n]
ClientPut $txt
return
}

791
tcl/tcl8/base8.tcl Normal file
View File

@ -0,0 +1,791 @@
crunch_skip begin
DOC "class Base" {
NAME
Base - The basic class inherited by all obTcl objects
SYNOPSIS
Base new <obj>
- Creates an object of the simplest possible class.
DESCRIPTION
All classes inherits the Base class automatically. The Base class
provides methods that are essential for manipulating obTcl-objects,
such as `info' and `destroy'.
METHODS
Base provides the following generic methods to all objects:
new - EXPERIMENTAL! Arranges to create a new object of
the class of the invoking object.
instance - EXPERIMENTAL! Arranges to create a new object of
the class of the invoking object. This method
differs from `new' by NOT automatically invoking
the `init' method of the new object.
One possible usage: Create a replacement for the
normal class object -a replacement which has no
hard-coded methods (this will need careful design
though).
init - Does nothing. The init method is automatically
invoked whenever an object is created with `new'.
destroy - Frees all instance variables of the object, and
the object itself.
class - Returns the class of the object.
set name ?value?
- Sets the instance variable `name' to value.
If no value is specified, the current value is
returned. Mainly used for debugging purposes.
info <cmd> - Returns information about the object. See INFO
below.
eval <script> - Evaluates `script' in the context of the object.
Useful for debugging purposes. Not meant to be
used for other purposes (create a method instead).
One useful trick (if you use the Tcl-debugger in
this package) is to enter:
obj eval bp
to be able to examine `obj's view of the world
(breakpoints must be enabled, of course).
unknown <method> <args>
- Automatically invoked when unknown methods are
invoked. the Base class defines this method to
print an error message, but this can be overridden
by derived classes.
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
- Define an option handler.
See OPTION HANDLER below for a description.
conf_verify <args>
conf_init <args>
- Set options. <args> are option-value pairs.
See OPTION HANDLER below for a description.
configure <args>
- Set options. <args> are option-value pairs.
See OPTION HANDLER below for a description.
cget <opt> - Get option value.
See OPTION HANDLER below for a description.
verify_unknown <args>
init_unknown <args>
configure_unknown <args>
cget_unknown <opt>
- These methods are automatically invoked when a requested
option has not been defined.
See OPTION HANDLER below for a description.
INFO
The method `info' can be used to inspect an object. In the list below
(I) means the command is only applicable to object instances, whereas
(C) means that the command can be applied either to the class object, or
to the object instance, if that is more convenient.
Existing commands:
instvars - (I) Returns the names of all existing instance variables.
iclassvars - (I) List instance class variables
classvars - (C) List class variables.
objects - (C) List objects of this class.
methods - (C) List methods defined in this class.
sysmethods - (C) List system methods defined in this class.
cached - (C) List cached methods for this class.
body <method> - (C) List the body of a method.
args <method> - (C) List formal parameters for a method.
options - (I) List the current option values in the format
"option-value pairs".
defaults - (C) List the current default values in the format
"option-value pairs". These values are the initial
values each new object will be given.
OPTION HANDLER
The method `option' is used to define options. It should be used on
the class-object, which serves as a repository for default values
and for code sections to run to verify and make use of new default values.
option <opt> <default> ?<section1> <body1>? ?<section2> <body2>?..
Define an option for this class.
Defining an option results in an instance variable
of the same name (with the leading '-' stripped)
being defined. This variable will be initiated
with the value <default>.
The sections `verify', `init' and `configure' can be defined.
`verify' is used to verify new parameters without affecting
the object. It is typically called by an object's init method
before all parts of the object have been created.
`init' is used for rare situations where some action should be taken
just after the object has been fully created. I.e when setting
the option variable via `verify' was not sufficient.
The `configure' section is invoked when the configure method is
called to re-configure an object.
Example usage:
class Graph
Graph inherit Widget
Graph option {-width} 300 verify {
if { $width >= 600 } {
error "width must be less than 600"
}
} configure {
$self.grf configure -width $width
}
Note 1: The `verify' section should never attempt
to access structures in the object (i.e widgets), since
it is supposed to be callable before they exist!
Use the `configure' section to manipulate the object.
Note 2: Using "break" or "error" in the verify section results
in the newly specified option value being rejected.
conf_verify <args>
Invoke all "verify" sections for options-value pairs
specified in <args>.
conf_init <args>
Invoke all "init" sections for options-value pairs
specified in <args>.
Example usage:
Graph method init { args } {
instvar width
# Set any option variables from $args
#
eval $self conf_verify $args ;# Set params
next -width $width ;# Get frame
CreateRestOfObject ;# Bogus
# Option handlers that wish to affect the
# object during init may declare an "init"
# section. Run any such sections now:
#
eval $self conf_init $args
}
Graph .graph -width 400 ;# Set width initially
configure <args>
Invoke all "configure" sections for options-value pairs
specified in <args>.
Example usage:
# First create object
#
Graph .graph -width 300
# Use `configure' to configure the object
#
.graph configure -width 200
cget <opt>
Returns the current value of option <opt>.
Example usage:
.graph cget -width
<sect>_unknown <args>
These methods are called when attempting to invoke sections
for unknown options. In this way a class may define methods
to catch usage of "configure", "cget", etc. for undefined
options.
Example:
Graph method configure_unknown { opt args } {
eval {$self-cmd configure $opt} $args
}
See the definitions of the Base and Widget classes for their
usage of these methods.
}
crunch_skip end
#----------------------------------------------------------------------
# Define the Base class. This class provides introspection etc.
#
# It also provides "set", which gives access to object
# internal variables, and 'eval' which lets you run arbitrary scripts in
# the objects context. You may wish to remove those methods if you
# want to disallow this.
class Base
Base method init args {}
Base method destroy args {
otFreeObj $self
}
Base method class args {
return $iclass
}
# Note: The `set' method takes on the class of the caller, so
# instvars will use the callers scope.
#
Base method set args {
set class $iclass
# instvar [lindex $args 0]
set var [lindex $args 0]
regexp -- {^([^(]*)\(.*\)$} $var m var
instvar $var
return [eval set $args]
}
Base method eval l {
return [eval $l]
}
Base method info { cmd args } {
switch $cmd {
"instvars" {return [eval {otObjInfoVars\
_oIV_${iclass}V${self}V _oIV_${iclass}V${self}V} $args]}
"iclassvars" {otObjInfoVars _oICV_${iclass}V _oICV_${iclass}V $args}
"classvars" {otObjInfoVars _oDCV_${iclass}V _oDCV_${iclass}V $args}
"objects" {otObjInfoObjects $iclass}
"methods" {otClassInfoMethods $iclass}
"sysmethods" {otClassInfoSysMethods $iclass}
"cached" {otClassInfoCached $iclass}
"body" {otClassInfoBody $iclass $args}
"args" {otClassInfoArgs $iclass $args}
"options" {${iclass}VVcollectOptions values ret
return [array get ret] }
"defaults" {${iclass}VVcollectOptions defaults ret
return [array get ret] }
default {
return -code error \
-errorinfo "Undefined command 'info $cmd'" \
"Undefined command 'info $cmd'"
}
}
}
Base method unknown args {
return -code error \
-errorinfo "Undefined method '$method' invoked" \
"Undefined method '$method' invoked"
}
#------- START EXPERIMENTAL
Base method new { obj args } {
eval {otNew $iclass $obj} $args
}
Base method instance { obj args } {
eval {otInstance $iclass $obj} $args
}
Base method sys_method args {
eval {otMkMethod S $iclass} $args
}
Base method method args {
eval {otMkMethod N $iclass} $args
}
Base method del_method args {
eval {otRmMethod $iclass} $args
}
Base method inherit args {
eval {otInherit $iclass} $args
}
# class AnonInst - inherit from this class to be able to generate
# anonymous objects. Example:
#
# class Foo
# Foo inherit AnonInst
# set obj [Foo new]
#
# NOTE: EXPERIMENTAL!!!
class AnonInst
AnonInst method anonPrefix p {
iclassvar _prefix
set _prefix $p
}
AnonInst method new {{obj {}} args} {
iclassvar _count _prefix
if ![info exists _count] {
set _count 0
}
if ![info exists _prefix] {
set _prefix "$iclass"
}
if ![string compare "" $obj] {
set obj $_prefix[incr _count]
}
eval next {$obj} $args
return $obj
}
#------- END EXPERIMENTAL
#----------------------------------------------------------------------
# Configure stuff
#----------------------------------------------------------------------
# The configuaration stuff is, for various reasons, probably the most
# change-prone part of obTcl.
#
# After fiddling around with various methods for handling options,
# this is what I came up with. It uses one method for each class and option,
# plus one dispatch-method for each of "conf_init", "conf_verify", "configure"
# and "cget" per class. Any extra sections in the `option' handler
# results in another dispatch-method being created.
# Attempts at handling undefined options are redirected to
#
# <section_name>_unknown
#
# Note:
# Every new object is initialized by a call to `initialize'.
# This is done in the proc "new", before `init' is called, to guarantee
# that initial defaults are set before usage. `initialize' calls "next", so
# all inherited classes are given a chance to set their initial defaults.
#
# Sections and their used (by convention):
#
# verify - Called at beginning of object initialization to verify
# specified options.
# init - Called at end of the class' `init' method.
# Use for special configuration.
# configure
# - This section should use the new value to configure
# the object.
#
# MkSectMethod - Define a method which does:
# For each option specified, call the handler for the specified section
# and option. If this fails, call the <section>_unknown handler.
# If this fails too, return an error.
# Note that the normal call of the method `unknown' is avoided by
# telling the unknown handler to avoid this (by means of the global array
# "_obTcl_unknBarred").
#
proc otMkSectMethod { class name sect } {
$class sys_method $name args "
array set Opts \$args
foreach i \[array names Opts\] {
global _obTcl_unknBarred
set _obTcl_unknBarred(\${class}VV${sect}V\$i) 1
if \[catch {\${class}VV${sect}V\$i \$Opts(\$i)} err\] {
if \[catch {\${class}VV${sect}_unknown\
\$i \$Opts(\$i)}\] {
unset _obTcl_unknBarred(\${class}VV${sect}V\$i)
error \"Unable to do '$sect \$i \$Opts(\$i)'\n\
\t\$err
\"
}
}
unset _obTcl_unknBarred(\${class}VV${sect}V\$i)
}
"
}
# Note: MkOptHandl is really a part of `option' below.
#
proc otMkOptHandl {} {
uplevel 1 {
$iclass sys_method "cget" opt "
classvar classOptions
if \[catch {${iclass}VVcgetV\$opt} ret\] {
if \[catch {\${class}VVcget_unknown \$opt} ret\] {
error \"Unable to do 'cget \$opt'\"
}
}
return \$ret
"
otMkSectMethod $iclass conf_init init
$iclass sys_method initialize {} {
next
classvar optDefaults
eval instvar [array names optDefaults]
foreach i [array names optDefaults] {
set $i $optDefaults($i)
}
}
# arr - Out-param
#
$iclass sys_method collectOptions { mode arr } {
classvar classOptions optDefaults
upvar 1 $arr ret
next $mode ret
eval instvar [array names optDefaults]
foreach i [array names optDefaults] {
if [string compare "defaults" $mode] {
set ret(-$i) [set $classOptions(-$i)]
} else {
set ret(-$i) $optDefaults($i)
}
}
}
otMkSectMethod $iclass conf_verify verify
otMkSectMethod $iclass configure configure
set _optPriv(section,cget) 1
set _optPriv(section,init) 1
set _optPriv(section,initialize) 1
set _optPriv(section,verify) 1
set _optPriv(section,configure) 1
}
}
otMkSectMethod Base configure configure
# _optPriv is used for internal option handling house keeping
# Note: checking for existence of a proc is not always a good idea,
# since it may simply be a cached pointer to a inherited method.
#
Base method option { opt dflt args } {
classvar_of_class $iclass optDefaults classOptions _optPriv
set var [string range $opt 1 end]
set optDefaults($var) $dflt
set classOptions($opt) $var
array set tmp $args
if ![info exists _optPriv(initialize)] {
otMkOptHandl
set _optPriv(initialize) 1
}
foreach i [array names tmp] {
if ![info exists _optPriv(section,$i)] {
otMkSectMethod $iclass $i $i
set _optPriv(section,$i) 1
}
$iclass sys_method "$iV$opt" _val "
instvar $var
set _old_val \$[set var]
set $var \$_val
set ret \[catch {$tmp($i)} res\]
if {\$ret != 0 && \$ret != 2 } {
set $var \$_old_val
return -code \$ret -errorinfo \$res \$res
}
return \$res
"
set _optPriv($iV$opt) 1
}
if ![info exists _optPriv(cgetV$opt)] {
$iclass sys_method "cgetV$opt" {} "
instvar $var
return \$[set var]
"
set _optPriv(cgetV$opt) 1
}
if ![info exists tmp(verify)] {
$iclass sys_method "verifyV$opt" _val "
instvar $var
set $var \$_val
"
set _optPriv(verifyV$opt) 1
}
if ![info exists tmp(configure)] {
$iclass sys_method "configureV$opt" _val "
instvar $var
set $var \$_val
"
set _optPriv(configureV$opt) 1
}
if ![info exists tmp(init)] {
$iclass sys_method "initV$opt" _val {}
set _optPriv(initV$opt) 1
}
}
# Default methods for non-compulsory
# standard sections in an option definition:
#
Base sys_method init_unknown { opt val } {}
Base sys_method verify_unknown { opt val } {}
# Catch initialize for classes which have no option handlers:
#
Base sys_method initialize {} {}
# Catch conf_init in case no option handlers have been defined.
#
Base sys_method conf_init {} {}
crunch_skip begin
#----------------------------------------------------------------------
#
# class Widget
# Base class for obTcl's Tk-widgets.
#
DOC "class Widget (Tk) base class for widgets" {
NAME
Widget - A base class for mega-widgets
SYNOPSIS
Widget new <obj> ?tk_widget_type? ?config options?
Widget <obj> ?tk_widget_type? ?config options?
DESCRIPTION
The widget class provides a base class for Tk-objects.
This class knows about widget naming conventions, so, for example,
destroying a Widget object will destroy any descendants of this object.
The `new' method need not be specified if the object name starts with a
leading ".". Thus giving syntactical compatibility with Tk for
creating widgets.
If `tk_widget_type' is not specified, the widget will be created as
a `frame'. If the type is specified it must be one of the existing
Tk-widget types, for example: button, radiobutton, text, etc.
See the Tk documentation for available widget types.
The normal case is to use a frame as the base for a mega-widget.
This is also the recommended way, since it results in the Tk class-name
of the frame being automatically set to the objects class name -thus
resulting in "winfo class <obj>" returning the mega-widget's class
name.
In order to create mega-widgets, derive new classes from this class.
METHODS
The following methods are defined in Widget:
init ?<args>? - Creates a frame widget, and configures it if any
configuration options are present. Automatically
invoked by the creation process, so there is no
need to call it (provided that you use 'next' in
the init-method of the derived class).
destroy - Destroys the object and associated tk-widget.
For Tk-compatibility, the function `destroy' can be
used instead, example:
destroy <obj>
Note: If you plan to mix Tk-widgets transparently
with mega-widgets, you should use the _function_
`destroy'.
Any descendant objects of <obj> will also be
destroyed (this goes for both Tk-widgets and
mega-widgets).
set - Overrides the `set' method of the Base class to
allow objects of type `scrollbar' to work correctly.
unknown - Overrides the `unknown' method of the Base class.
Directs any unknown methods to the main frame of
the Widget object.
unknown_opt - Overrides the same method from the Base class.
Automatically called from the option handling system.
Directs any unknown options to the main frame of the
Widget object.
In addition, all non-shadowed methods from the Base class can be used.
Any method that cannot be resolved is passed on to the associated
Tk-widget. This behaviour can be altered for any derived classes
by defining a new `unknown' method (thus shadowing Widget's own
`unknown' method). The same technique can be used to override
the `unknown_opt' method.
EXAMPLES
A simple example of deriving a class MegaButton which consists of
a button widget initiated with the text "MEGA" (yes, I know, it's
silly).
class MegaButton
MegaButton inherit Widget
MegaButton method init { args } {
#
# Allow the Widget class to create a button for us
# (we need to specify widget type `button')
#
eval next button $args
$self configure -text "MEGA"
}
frame .f
MegaButton .f.b -background red -foreground white
pack .f .f.b
This example shows how to specify a Tk-widget type (button), although
I advice against specifying anything (thus using a frame).
See DESCRIPTION above for the reasoning behind this. Also note that
`eval' is used to split $args into separate arguments for passing to
the init method of the Widget class.
A more realistic example:
class ScrolledText
ScrolledText inherit Widget
ScrolledText method init { args } {
next
text $self.t -yscrollcommand "$self.sb set"
scrollbar $self.sb -command "$self.t yview"
pack $self.sb -side right -fill y
pack $self.t -side left
eval $self configure $args
}
ScrolledText method unknown { args } {
eval {$self.t $method} $args
}
ScrolledText .st
.st insert end [exec cat /etc/passwd]
pack .st
This creates a new class, ScrolledText, containing a text window
and a vertical scrollbar. It arranges for all unknown methods to
be directed to the text widget; thus allowing `.st insert' to work
normally (along with any other text methods).
NOTES
Widget binds the "destroy" method to the <Destroy> event of
the holding window, so be careful not to remove this binding
inadvertently.
}
crunch_skip end
class Widget
# init Create a tk-widget of specified type (or frame if not specified).
# If the corresponding Tk-widget already exists, it will be used.
# Otherwise the Tk-widget will be created.
# The tk-widget will be named $self if $self has a leading ".",
# otherwise a "." is prepended to $self to form the wigdet name.
# The instvar `win' will contain the widgets window name, and
# the instvar `wincmd' will contain the name of the widget's associated
# command.
Widget method init args {
instvar win wincmd
next
set first "[lindex $args 0]"
set c1 "[string index $first 0]"
if { ![string compare "" "$c1"] || ![string compare "-" "$c1"] } {
set type frame
set cl "-class $iclass"
} else {
set type $first
set args [lrange $args 1 end]
set cl ""
}
if [string compare "" [info commands $self-cmd]] {
set win $self
set wincmd $self-cmd
} else {
if ![string compare "." [string index $self 0]] {
rename $self _ooTmp
eval $type $self $cl $args
rename $self $self-cmd
rename _ooTmp $self
set win $self
set wincmd $self-cmd
} else {
eval $type .$self $cl $args
set win .$self
#set wincmd .$self-cmd
set wincmd .$self
}
}
bind $win <Destroy> "\
if { !\[string compare \"%W\" \"$self\"\] && !\[catch {info args $self}\] } {
$self destroy -obj_only }"
return $self
}
# Just for the case when there are no option-handlers defined:
#
Widget sys_method configure args {
instvar wincmd
eval {$wincmd configure} $args
}
Widget sys_method cget opt {
instvar wincmd
eval {$wincmd cget} $opt
}
Widget sys_method configure_unknown { opt args } {
instvar wincmd
eval {$wincmd configure $opt} $args
}
Widget sys_method cget_unknown opt {
instvar wincmd
$wincmd cget $opt
}
Widget sys_method init_unknown { opt val } {
puts "init_unknown: $opt $val (iclass=$iclass class=$class)"
}
Widget sys_method unknown args {
instvar wincmd
eval {$wincmd $method} $args
}
# Note: no "next" used! Does the `Base::destroy' stuff here for performance.
#
Widget method destroy args {
instvar win wincmd
# Must copy vars since they are destroyed by `otFreeObj'
set wp $win
set w $wincmd
otFreeObj $self
catch {bind $w <Destroy> {}}
if [string compare "-obj_only" $args] {
if [string compare $w $wp] {
rename $w $wp
}
if [string compare "-keepwin" $args] {
destroy $wp
}
}
}
# The method `set' defined here shadows the `set' method from Base.
# This allows wrapper objects around Tk-scrollbars to work correctly.
#
Widget sys_method set args {
instvar wincmd
eval {$wincmd set} $args
}
Widget sys_method base_set args {
eval BaseVVset $args
}

297
tcl/tcl8/inherit8.tcl Normal file
View File

@ -0,0 +1,297 @@
#----------------------------------------------------------------------
# Method resolution and caching
#
proc otPrInherits {} {
global _obTcl_Classes
foreach i [array names _obTcl_Classes]\
{puts "$i inherits from: [$i inherit]"}
}
proc otInherit { class args } {
global _obTcl_Inherits
if ![string compare "" $args] {
return [set _obTcl_Inherits($class)]
}
if { [string compare "Base" $class] && [lsearch $args "Base"] == -1 } {
set args [concat $args "Base"]
}
if [info exists _obTcl_Inherits($class)] {
#
# This class is not new, invalidate caches
#
otInvalidateCaches 0 $class [otClassInfoCached ${class}]
} else {
set _obTcl_Inherits($class) {}
}
set _obTcl_Inherits($class) $args
}
proc otInvalidateCaches { level class methods } {
global _obTcl_CacheStop
foreach i $methods {
if ![string compare "unknown" $i] { set i "*" }
set _obTcl_CacheStop($i) 1
}
if [array exists _obTcl_CacheStop] { otDoInvalidate }
}
# There is a catch on rename and unset since current build of tmp
# does not guarantee that each element is unique.
proc otDoInvalidate {} {
global _obTcl_CacheStop _obTcl_Cached
if ![array exists _obTcl_Cached] {
unset _obTcl_CacheStop
return
}
if [info exists _obTcl_CacheStop(*)] {
set stoplist "*"
} else {
set stoplist [array names _obTcl_CacheStop]
}
foreach i $stoplist {
set tmp [array names _obTcl_Cached *VV$i]
eval lappend tmp [array names _obTcl_Cached *VV${i}_next]
foreach k $tmp {
catch {
rename $k {}
unset _obTcl_Cached($k)
}
}
}
if ![array size _obTcl_Cached] {
unset _obTcl_Cached
}
unset _obTcl_CacheStop
}
if ![string compare "" [info procs otUnknown]] {
rename unknown otUnknown
}
proc otResolve { class func } {
return [otGetFunc 0 $class $func]
}
#----------------------------------------------------------------------
#
# `unknown' and `next' both create cache methods.
#
#----------------------------------------------------------------------
#
# unknown -
# A missing function was found. See if it can be resolved
# from inheritance.
#
# If function name does not follow the *VV* pattern, call the normal
# unknown handler.
#
# Umethod is for use by the "unknown" method. If the method is named
# `unknown' it will have $method set to $Umethod (the invokers method
# name).
#
setIfNew _obTcl_unknBarred() ""
proc unknown args {
global _obTcl_unknBarred
# Resolve inherited function calls
#
set name [lindex $args 0]
if [string match *VV* $name] {
set tmp [split $name V]
set class [lindex $tmp 0]
set func [join [lrange $tmp 2 end] V]
set flist [otGetFunc 0 $class $func]
if ![string compare "" $flist] {
if [info exists _obTcl_unknBarred($name)] { return -code error }
set flist [otGetFunc 0 $class "unknown"]
}
if [string compare "" $flist] {
proc $name args "otGetSelf
set Umethod $func
eval [lindex $flist 0] \$args"
} else {
proc $name args "
return -code error\
-errorinfo \"Undefined method '$func' invoked\" \
\"Undefined method '$func' invoked\"
"
}
global _obTcl_Cached
set _obTcl_Cached(${class}VV$func) $class
# Code below borrowed from init.tcl (tcl7.4)
#
global errorCode errorInfo
set code [catch {uplevel $args} msg]
if { $code == 1 } {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
} else {
uplevel [concat otUnknown $args]
}
}
setIfNew _obTcl_Cnt 0
# 6/11/95 Added _obTcl_nextRet to allow propagation of return-values
# from `next' calls. I.e doing `return [next $args]' will
# be meaningful. It is only in simple cases that the return
# value is shure to make sense. With multiple inheritance
# it may be impossible to rely on!
#
# NOTE: This support is experimental and likely to be removed!!!
#
# Improved for lower overhead with big args-lists
# NOTE: It is understood that `args' is initialized from the `next'
# procedure.
#
proc otChkCall { cmd } {
global _obTcl_Trace _obTcl_Cnt _obTcl_nextRet
if ![info exists _obTcl_Trace($cmd)] {
set _obTcl_Trace($cmd) 1
catch {uplevel 1 "uplevel 1 \"$cmd \$args\""} _obTcl_nextRet
}
return $_obTcl_nextRet
}
# otNextPrepare is really just a part of proc `next' below.
#
proc otNextPrepare {} {
uplevel 1 {
set all [otGetNextFunc $class $method]
foreach i $all {
# Note: args is the literal _name_ of var to use, hence
# no $-sign!
append tmp "otChkCall $i\n"
}
if [info exists tmp] {
proc ${class}VV${method}_next args $tmp
} else {
proc ${class}VV${method}_next args return
}
set _obTcl_Cached(${class}VV${method}_next) $class
}
}
# next -
# Invoke next shadowed method. Protect against multiple invocation.
# Multiple invocation would occur when several inherited classes inherit
# a common superclass.
#
# Note: I use `info exists' on _obTcl_Cached, rater than `info procs' on
# the corresponding procedure, since checking for a variable seems to be
# about three times faster (Tcl7.4).
#
proc next args {
global _obTcl_Cnt _obTcl_Cached _obTcl_nextRet
# otGetSelf inlined and modified
upvar 1 self self method method class class
if { $_obTcl_Cnt == 0 } {
set _obTcl_nextRet ""
}
if ![info exists _obTcl_Cached(${class}VV${method}_next)] {
otNextPrepare
}
incr _obTcl_Cnt 1
set ret [catch {uplevel 1 {${class}VV${method}_next} $args} val]
incr _obTcl_Cnt -1
if { $_obTcl_Cnt == 0 } {
global _obTcl_Trace
catch {unset _obTcl_Trace}
}
if { $ret != 0 } {
return -code error \
-errorinfo "$self: $val" "$self: $val"
} else {
return $val
}
}
# otGetNextFunc -
# Get a method by searching inherited classes, skipping the local
# class.
#
proc otGetNextFunc { class func } {
global _obTcl_Inherits
set all ""
foreach i [set _obTcl_Inherits($class)] {
foreach k [otGetFunc 0 $i $func] {
lappendUniq all $k
}
}
return $all
}
# otGetFunc -
# Locate a method by searching the inheritance tree.
# Cyclic inheritance is discovered and reported. A list of all
# found methods is returned, with the closest first in the list.
# Cache-methods are skipped, and will hence not figure in the list.
#
# 16/12/95 Added support for autoloading of classes.
#
proc otGetFunc { depth class func } {
global _obTcl_Inherits _obTcl_Cached _obTcl_NoClasses _obTcl_Classes
if { $depth > $_obTcl_NoClasses } {
otGetFuncErr $depth $class $func
return ""
}
incr depth
set all ""
if ![info exists _obTcl_Classes($class)] {
if ![auto_load $class] {
otGetFuncMissingClass $depth $class $func
return ""
}
}
if { [string compare "" [info procs ${class}VV$func]] &&
![info exists _obTcl_Cached(${class}VV$func)] } {
return "${class}VV$func"
}
foreach i [set _obTcl_Inherits($class)] {
set ret [otGetFunc $depth $i $func]
if [string compare "" $ret] {
foreach i $ret {
lappendUniq all $i
}
}
}
return $all
}
# Note: Real error handling should be added here!
# Specifically we need to report which object triggered the error.
proc otGetFuncErr { depth class func } {
puts stderr "GetFunc: depth=$depth, circular dependency!?"
puts stderr " class=$class func=$func"
}
proc otGetFuncMissingClass { depth class func } {
puts stderr "GetFunc: Unable to inherit from $class"
puts stderr " $class not defined (and auto load failed)"
puts stderr " Occurred while looking for ${class}VV$func"
}

617
tcl/tcl8/init8.tcl Normal file
View File

@ -0,0 +1,617 @@
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# SCCS: @(#) init.tcl 1.66 96/10/06 14:29:28
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#----------------------------------------------------------------------------
#
# Modified by Mark Koennecke in order to redirect unknown into the Sics
# mechanism. Thereby disabling command shortcuts and execution of shell
# commands for security reasons.
#
# February 1997
# Hacked for Tcl 8.0 September 1997, bad hack if problems start anew
#
#---------------------------------------------------------------------------
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.0
#if [catch {set auto_path $env(TCLLIBPATH)}] {
# set auto_path ""
#}
if {[lsearch -exact $auto_path [info library]] < 0} {
lappend auto_path [info library]
}
catch {
foreach dir $tcl_pkgPath {
if {[lsearch -exact $auto_path $dir] < 0} {
lappend auto_path $dir
}
}
unset dir
}
package unknown tclPkgUnknown
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
# exec hereby disabled for Security reasons! MK
set auto_noexec 1
set errorCode ""
set errorInfo ""
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
# command available:
#
# 1. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 2. If the command was invoked interactively at top-level:
# (a) see if the command exists as an executable UNIX program.
# If so, "exec" the command.
# (b) see if the command requests csh-like history substitution
# in one of the common forms !!, !<number>, or ^old^new. If
# so, emulate csh's history substitution.
# (c) see if the command is a unique abbreviation for another
# command. If so, invoke the command.
#
# Arguments:
# args - A list whose elements are the words of the original
# command, including the command name.
proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if ![info exists auto_noload] {
#
# Make sure we're not trying to load the same proc twice.
#
if [info exists unknown_pending($name)] {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
set ret [catch {auto_load $name} msg]
unset unknown_pending($name);
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error while autoloading \"$name\": $msg"
}
if ![array size unknown_pending] {
unset unknown_pending
}
if $msg {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel $args} msg]
if {$code == 1} {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
}
}
# Try running SICS for a change
set ret [catch {uplevel #0 SicsUnknown $args} msg]
if {$ret == 1} {
return -code error $msg
} else {
return -code ok $msg
}
}
# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them. If so, it sources the appropriate
# library file to create the procedure. Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments:
# cmd - Name of the command to find and load.
proc auto_load cmd {
global auto_index auto_oldpath auto_path env errorInfo errorCode
if [info exists auto_index($cmd)] {
uplevel #0 $auto_index($cmd)
return [expr {[info commands $cmd] != ""}]
}
if ![info exists auto_path] {
return 0
}
if [info exists auto_oldpath] {
if {$auto_oldpath == $auto_path} {
return 0
}
}
set auto_oldpath $auto_path
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set f ""
if [catch {set f [open [file join $dir tclIndex]]}] {
continue
}
set error [catch {
set id [gets $f]
if {$id == "# Tcl autoload index file, version 2.0"} {
eval [read $f]
} elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
if {([string index $line 0] == "#")
|| ([llength $line] != 2)} {
continue
}
set name [lindex $line 0]
set auto_index($name) \
"source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg]
if {$f != ""} {
close $f
}
if $error {
error $msg $errorInfo $errorCode
}
}
if [info exists auto_index($cmd)] {
uplevel #0 $auto_index($cmd)
if {[info commands $cmd] != ""} {
return 1
}
}
return 0
}
if {[string compare $tcl_platform(platform) windows] == 0} {
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions. Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
global auto_execs env tcl_platform
if [info exists auto_execs($name)] {
return $auto_execs($name)
}
set auto_execs($name) ""
if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename
ren rmdir rd time type ver vol} $name] != -1} {
if {[info exists env(COMSPEC)]} {
set comspec $env(COMSPEC)
} elseif {[info exists env(ComSpec)]} {
set comspec $env(ComSpec)
} elseif {$tcl_platform(os) == "Windows NT"} {
set comspec "cmd.exe"
} else {
set comspec "command.com"
}
return [set auto_execs($name) [list $comspec /c $name]]
}
if {[llength [file split $name]] != 1} {
foreach ext {{} .com .exe .bat} {
set file ${name}${ext}
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) $file]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
} elseif {[info exists env(windir)]} {
set windir $env(windir)
}
if {[info exists windir]} {
if {$tcl_platform(os) == "Windows NT"} {
append path "$windir/system32;"
}
append path "$windir/system;$windir;"
}
if {! [info exists env(PATH)]} {
if [info exists env(Path)] {
append path $env(Path)
} else {
return ""
}
} else {
append path $env(PATH)
}
foreach dir [split $path {;}] {
if {$dir == ""} {
set dir .
}
foreach ext {{} .com .exe .bat} {
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) $file]
}
}
}
return ""
}
} else {
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to an executable in the path. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
# Unix version.
#
proc auto_execok name {
global auto_execs env
if [info exists auto_execs($name)] {
return $auto_execs($name)
}
set auto_execs($name) ""
if {[llength [file split $name]] != 1} {
if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) $name
}
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
if {$dir == ""} {
set dir .
}
set file [file join $dir $name]
if {[file executable $file] && ![file isdirectory $file]} {
set auto_execs($name) $file
return $file
}
}
return ""
}
}
# auto_reset --
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments:
# None.
proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tclPkgUnknown} $p] < 0)} {
rename $p {}
}
}
catch {unset auto_execs}
catch {unset auto_index}
catch {unset auto_oldpath}
}
# auto_mkindex --
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
# locate all of the relevant files.
#
# Arguments:
# dir - Name of the directory in which to create an index.
# args - Any number of additional arguments giving the
# names of files within dir. If no additional
# are given auto_mkindex will look for *.tcl.
proc auto_mkindex {dir args} {
global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {$args == ""} {
set args *.tcl
}
foreach file [eval glob $args] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if [regexp {^proc[ ]+([^ ]*)} $line match procName] {
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg]
if $error {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts $f $index nonewline
close $f
cd $oldDir
} msg]
if $error {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
# pkg_mkIndex --
# This procedure creates a package index in a given directory. The
# package index consists of a "pkgIndex.tcl" file whose contents are
# a Tcl script that sets up package information with "package require"
# commands. The commands describe all of the packages defined by the
# files given as arguments.
#
# Arguments:
# dir - Name of the directory in which to create the index.
# args - Any number of additional arguments, each giving
# a glob pattern that matches the names of one or
# more shared libraries or Tcl script files in
# dir.
proc pkg_mkIndex {dir args} {
global errorCode errorInfo
append index "# Tcl package index file, version 1.0\n"
append index "# This file is generated by the \"pkg_mkIndex\" command\n"
append index "# and sourced either when an application starts up or\n"
append index "# by a \"package unknown\" script. It invokes the\n"
append index "# \"package ifneeded\" command to set up package-related\n"
append index "# information so that packages will be loaded automatically\n"
append index "# in response to \"package require\" commands. When this\n"
append index "# script is sourced, the variable \$dir must contain the\n"
append index "# full path name of this file's directory.\n"
set oldDir [pwd]
cd $dir
foreach file [eval glob $args] {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
# interpreter, and get a list of the new commands and packages
# that are defined. Define an empty "package unknown" script so
# that there are no recursive package inclusions.
set c [interp create]
# If Tk is loaded in the parent interpreter, load it into the
# child also, in case the extension depends on it.
foreach pkg [info loaded] {
if {[lindex $pkg 1] == "Tk"} {
$c eval {set argv {-geometry +0+0}}
load [lindex $pkg 0] Tk $c
break
}
}
$c eval [list set file $file]
if [catch {
$c eval {
proc dummy args {}
package unknown dummy
set origCmds [info commands]
set dir "" ;# in case file is pkgIndex.tcl
set pkgs ""
# Try to load the file if it has the shared library extension,
# otherwise source it. It's important not to try to load
# files that aren't shared libraries, because on some systems
# (like SunOS) the loader will abort the whole application
# when it gets an error.
if {[string compare [file extension $file] \
[info sharedlibextension]] == 0} {
# The "file join ." command below is necessary. Without
# it, if the file name has no \'s and we're on UNIX, the
# load command will invoke the LD_LIBRARY_PATH search
# mechanism, which could cause the wrong file to be used.
load [file join . $file]
set type load
} else {
source $file
set type source
}
foreach i [info commands] {
set cmds($i) 1
}
foreach i $origCmds {
catch {unset cmds($i)}
}
foreach i [package names] {
if {([string compare [package provide $i] ""] != 0)
&& ([string compare $i Tcl] != 0)
&& ([string compare $i Tk] != 0)} {
lappend pkgs [list $i [package provide $i]]
}
}
}
} msg] {
puts "error while loading or sourcing $file: $msg"
}
foreach pkg [$c eval set pkgs] {
lappend files($pkg) [list $file [$c eval set type] \
[lsort [$c eval array names cmds]]]
}
interp delete $c
}
foreach pkg [lsort [array names files]] {
append index "\npackage ifneeded $pkg\
\[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
[list $files($pkg)]\]"
}
set f [open pkgIndex.tcl w]
puts $f $index
close $f
cd $oldDir
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked
# as part of a "package ifneeded" script. It calls "package provide"
# to indicate that a package is available, then sets entries in the
# auto_index array so that the package's files will be auto-loaded when
# the commands are used.
#
# Arguments:
# dir - Directory containing all the files for this package.
# pkg - Name of the package (no version number).
# version - Version number for the package, such as 2.1.3.
# files - List of files that constitute the package. Each
# element is a sub-list with three elements. The first
# is the name of a file relative to $dir, the second is
# "load" or "source", indicating whether the file is a
# loadable binary or a script to source, and the third
# is a list of commands defined by this file.
proc tclPkgSetup {dir pkg version files} {
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {$type == "load"} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
# tclMacPkgSearch --
# The procedure is used on the Macintosh to search a given directory for files
# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the
# interpreter to setup the package database.
proc tclMacPkgSearch {dir} {
foreach x [glob -nocomplain [file join $dir *.shlb]] {
if [file isfile $x] {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {$y == "pkgIndex"} {source -rsrc pkgIndex}
}
resource close $res
}
}
}
# tclPkgUnknown --
# This procedure provides the default for the "package unknown" function.
# It is invoked when a package that's needed can't be found. It scans
# the auto_path directories and their immediate children looking for
# pkgIndex.tcl files and sources any such files that are found to setup
# the package database. (On the Macintosh we also search for pkgIndex
# TEXT resources in all files.)
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name version {exact {}}} {
global auto_path tcl_platform env
if ![info exists auto_path] {
return
}
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set file [file join $dir pkgIndex.tcl]
if [file readable $file] {
source $file
}
foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
if [file readable $file] {
set dir [file dirname $file]
source $file
}
}
# On the Macintosh we also look in the resource fork
# of shared libraries
if {$tcl_platform(platform) == "macintosh"} {
set dir [lindex $auto_path $i]
tclMacPkgSearch $dir
foreach x [glob -nocomplain [file join $dir *]] {
if [file isdirectory $x] {
set dir $x
tclMacPkgSearch $dir
}
}
}
}
}

540
tcl/tcl8/obtcl8.tcl Normal file
View File

@ -0,0 +1,540 @@
#----------------------------------------------------------------------
# -- obTcl --
#
# `obTcl' is a Tcl-only object- and Megawidget-extension.
#
# The system supports multiple inheritance, three new storage classes,
# and fully transparent Tk-megawidgets.
#
# Efficiency is obtained through method-resolution caching.
# obTcl provides real instance variables and class variables
# (they may be arrays). Two types of class variables are provided:
# definition-class scoped, and instance-class scoped.
#
# The mega-widget support allows creation of mega-widgets which handle
# like ordinary Tk-widgets; i.e can be "packed", "deleted", "placed" etc,
# intermixed with ordinary Tk-widgets.
# The transparency of the mega-widget extension has been tested by
# wrapping all normal Tk-widgets into objects and running the standard
# "widget" demo provided with Tk4.0.
#
# To try out obTcl, just start `wish' (Tk4.0 or later) and do "source demo".
# Alternatively run "demo" directly (requires that wish can be located
# by demo).
#
# If you run `wish' interactively and source `obtcl', you will be able to
# type "help" to access a simple help system.
#
# Pronunciation: `obTcl' sounds like "optical".
#
# See COPYRIGHT for copyright information.
#
# Please direct comments, ideas, complaints, etc. to:
#
# patrik@dynas.se
#
# Patrik Floding
# DynaSoft AB
#
#----------------------------------------------------------------------
# For convenience you may either append the installation directory of
# obTcl to your auto_path variable (the recommended method), or source
# `obtcl.tcl' into your script. Either way everything should work.
#
set OBTCL_LIBRARY [file dirname [info script]]
if { [lsearch -exact $auto_path $OBTCL_LIBRARY] == -1 } {
lappend auto_path $OBTCL_LIBRARY
}
set obtcl_version "0.56"
crunch_skip begin
cmt {
Public procs:
- Std. features
classvar
iclassvar
instvar
class
obtcl_mkindex
next
- Subj. to changes
instvar2global
classvar_of_class
instvar_of_class
import
renamed_instvar
is_object
is_class
Non public:
Old name New name (as of 0.54)
-------- ----------------------
new otNew
instance otInstance
freeObj otFreeObj
classDestroy otClassDestroy
getSelf otGetSelf
mkMethod otMkMethod
rmMethod otRmMethod
delAllMethods otDelAllMethods
objinfoVars otObjInfoVars
objinfoObjects otObjInfoObjects
classInfoBody otClassInfoBody
classInfoArgs otClassInfoArgs
classInfoMethods+Cached otClassInfoMethods+Cached
classInfoMethods otClassInfoMethods
classInfoSysMethods otClassInfoSysMethods
classInfoCached otClassInfoCached
inherit otInherit
InvalidateCaches otInvalidateCaches
chkCall otChkCall
GetNextFunc otGetNextFunc
GetFunc otGetFunc
GetFuncErr otGetFuncErr
GetFuncMissingClass otGetFuncMissingClass
}
crunch_skip end
proc instvar2global name {
upvar 1 class class self self
return _oIV_${class}V${self}V$name
}
# Class variables of definition class
if ![string compare [info commands classvar] ""] {
proc classvar args {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oDCV_\${class}V\$_obTcl_i \$_obTcl_i
}"
}
}
# Class variables of specified class
proc classvar_of_class { class args } {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oDCV_${class}V\$_obTcl_i \$_obTcl_i
}"
}
# Class variables of instance class
if ![string compare [info commands iclassvar] ""] {
proc iclassvar args {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oICV_\${iclass}V\$_obTcl_i \$_obTcl_i
}"
}
}
# Instance variables. Specific to instances.
# Make instvar from `class' available
# Use with caution! I might put these variables in a separate category
# which must be "exported" vaiables (as opposed to "instvars").
#
proc instvar_of_class { class args } {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oIV_${class}V\${self}V\$_obTcl_i \$_obTcl_i
}"
}
# Instance variables. Specific to instances.
if ![string compare [info commands instvar] ""] {
proc instvar args {
uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oIV_\${class}V\${self}V\$_obTcl_i \$_obTcl_i
}"
}
}
# Renamed Instance variable. Specific to instances.
proc renamed_instvar { normal_name new_name } {
uplevel 1 "upvar #0 _oIV_\${class}V\${self}V$normal_name $new_name"
}
# Check if an object exists
#
proc is_object name {
global _obTcl_Objects
if [info exists _obTcl_Objects($name)] {
return 1
} else {
return 0
}
}
# Check if a class exists
#
proc is_class name {
global _obTcl_Classes
if [info exists _obTcl_Classes($name)] {
return 1
} else {
return 0
}
}
#----------------------------------------------------------------------
# new Creates a new object. Creation involves creating a proc with
# the name of the object, initializing some house-keeping data,
# call `initialize' to set init any option-variables,
# and finally calling the `init' method for the newly created object.
#
# 951024. Added rename of any existing command to facilitate wrapping
# of existing widgets/commands. Only one-level wrapping is supported.
proc otNew { iclass obj args } {
global _obTcl_Objclass _obTcl_Objects
set _obTcl_Objclass($iclass,$obj) $obj
if ![info exists _obTcl_Objects($obj)] {
catch {rename $obj ${obj}-cmd}
}
set _obTcl_Objects($obj) 1
otProc $iclass $obj
set self $obj
eval {${iclass}VVinitialize}
eval {${iclass}VVinit} $args
}
if ![string compare [info commands otProc] ""] {
proc otProc { iclass obj } {
proc $obj { cmd args } "
set self $obj
set iclass $iclass
if \[catch {eval {${iclass}VV\$cmd} \$args} val\] {
return -code error \
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
} else {
return \$val
}
"
}
}
# otInstance
# Exactly like new, but does not call the 'init' method.
# Useful when creating a class-leader object. Class-leader
# objects are used instead of class names when it is desirable
# to avoid some hard-coded method ins the class proc.
#
proc otInstance { iclass obj args } {
global _obTcl_Objclass _obTcl_Objects
set _obTcl_Objclass($iclass,$obj) $obj
if ![info exists _obTcl_Objects($obj)] {
catch {rename $obj ${obj}-cmd}
}
set _obTcl_Objects($obj) 1
proc $obj { cmd args } "
set self $obj
set iclass $iclass
if \[catch {eval {${iclass}VV\$cmd} \$args} val\] {
return -code error \
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
} else {
return \$val
}
"
set self $obj
eval {${iclass}VVinitialize}
}
#----------------------------------------------------------------------
# otFreeObj
# Unset all instance variables.
#
proc otFreeObj obj {
global _obTcl_Objclass _obTcl_Objects
otGetSelf
catch {uplevel #0 "eval unset _obTcl_Objclass($iclass,$obj) \
_obTcl_Objects($obj) \
\[info vars _oIV_*V${self}V*\]"}
catch {rename $obj {}}
}
setIfNew _obTcl_Classes() ""
setIfNew _obTcl_NoClasses 0
# This new class proc allows overriding of the 'new' method.
# The usage of `new' in the resulting class object is about 10% slower
# than before though..
#
proc class class {
global _obTcl_NoClasses _obTcl_Classes _obTcl_Inherits
if [info exists _obTcl_Classes($class)] {
set self $class
otClassDestroy $class
}
if [string match *V* $class] {
puts stderr "classV Fatal ErrorV"
puts stderr " class name `$class'\
contains reserved character `V'"
return
}
incr _obTcl_NoClasses 1
set _obTcl_Classes($class) 1
set iclass $class; set obj $class;
proc $class { cmd args } "
set self $obj
set iclass $iclass
switch -glob \$cmd {
.* { eval {${class}VVnew \$cmd} \$args }
new { eval {${class}VVnew} \$args }
method { eval {otMkMethod N $class} \$args}
inherit { eval {otInherit $class} \$args}
destroy { eval {otClassDestroy $class} \$args }
init { return -code error \
-errorinfo \"$obj: ErrorV classes may not be init'ed!\" \
\"$obj: ErrorV classes may not be init'ed!\"
}
default {
if \[catch {eval {${iclass}VV\$cmd} \$args} val\] {
return -code error \
-errorinfo \"$obj: \$val\" \"$obj: \$val\"
} else {
return \$val
}
}
}
"
if [string compare "Base" $class] {
$class inherit "Base"
} else {
set _obTcl_Inherits($class) {}
}
return $class
}
proc otClassDestroy class {
global _obTcl_NoClasses _obTcl_Classes ;# _obTcl_CacheStop
otGetSelf
if ![info exists _obTcl_Classes($class)] { return }
otInvalidateCaches 0 $class [otClassInfoMethods $class]
otDelAllMethods $class
rename $class {}
incr _obTcl_NoClasses -1
unset _obTcl_Classes($class)
uplevel #0 "
foreach _iii \[info vars _oICV_${class}V*\] {
unset \$_iii
}
foreach _iii \[info vars _oDCV_${class}V*\] {
unset \$_iii
}
catch {unset _iii}
"
otFreeObj $class
}
# otGetSelf -
# Bring caller's ID into scope. For various reasons
# an "inlined" (copied) version is used in some places. Theses places
# can be located by searching for the word 'otGetSelf', which should occur
# in a comment near the "inlining".
#
if ![string compare [info commands otGetSelf] ""] {
proc otGetSelf {} {
uplevel 1 {upvar 1 self self iclass iclass Umethod method}
}
}
proc otMkMethod { mode class name params body } {
otInvalidateCaches 0 $class $name
if [string compare "unknown" "$name"] {
set method "set method $name"
} else {
set method ""
}
proc ${class}VV$name $params \
"otGetSelf
set class $class
$method
$body"
if ![string compare "S" $mode] {
global _obTcl_SysMethod
set _obTcl_SysMethod(${class}VV$name) 1
}
}
proc otRmMethod { class name } {
global _obTcl_SysMethod
if [string compare "unknown" "$name"] {
otInvalidateCaches 0 $class $name
} else {
otInvalidateCaches 0 $class *
}
rename ${class}VV$name {}
catch {unset _obTcl_SysMethod(${class}VV$name)}
}
proc otDelAllMethods class {
global _obTcl_Cached
foreach i [info procs ${class}VV*] {
if [info exists _obTcl_SysMethod($i)] {
continue
}
if [info exists _obTcl_Cached($i)] {
unset _obTcl_Cached($i)
}
rename $i {}
}
}
proc otObjInfoVars { glob base { match "" } } {
if ![string compare "" $match] { set match * }
set l [info globals ${glob}$match]
set all {}
foreach i $l {
regsub "${base}(.*)" $i {\1} tmp
lappend all $tmp
}
return $all
}
proc otObjInfoObjects class {
global _obTcl_Objclass
set l [array names _obTcl_Objclass $class,*]
set all {}
foreach i $l {
regsub "${class},(.*)" $i {\1} tmp
lappend all $tmp
}
return $all
}
proc otClassInfoBody { class method } {
global _obTcl_Objclass _obTcl_Cached
if [info exists _obTcl_Cached(${class}VV$method)] { return }
if [catch {set b [info body ${class}VV$method]} ret] {
return -code error \
-errorinfo "info bodyV Method '$method' not defined in class $class" \
"info bodyV Method '$method' not defined in class $class"
} else {
return $b
}
}
proc otClassInfoArgs { class method } {
global _obTcl_Objclass _obTcl_Cached
if [info exists _obTcl_Cached(${class}VV$method)] { return }
if [catch {set b [info args ${class}VV$method]} ret] {
return -code error \
-errorinfo "info argsV Method '$method' not defined in class $class" \
"info argsV Method '$method' not defined in class $class"
} else {
return $b
}
}
proc otClassInfoMethods+Cached class {
global _obTcl_Objclass _obTcl_SysMethod
set l [info procs ${class}VV*]
set all {}
foreach i $l {
regsub "${class}VV(.*)" $i {\1} tmp
if [info exists _obTcl_SysMethod($i)] { continue }
lappend all $tmp
}
return $all
}
proc otClassInfoMethods class {
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
set l [info procs ${class}VV*]
set all {}
foreach i $l {
if [info exists _obTcl_Cached($i)] { continue }
if [info exists _obTcl_SysMethod($i)] { continue }
regsub "${class}VV(.*)" $i {\1} tmp
lappend all $tmp
}
return $all
}
proc otClassInfoSysMethods class {
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
set l [info procs ${class}VV*]
set all {}
foreach i $l {
if [info exists _obTcl_Cached($i)] { continue }
if ![info exists _obTcl_SysMethod($i)] { continue }
regsub "${class}VV(.*)" $i {\1} tmp
lappend all $tmp
}
return $all
}
proc otClassInfoCached class {
global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
if ![array exists _obTcl_Cached] {
return
}
set l [array names _obTcl_Cached ${class}VV*]
set all {}
foreach i $l {
regsub "${class}VV(.*)" $i {\1} tmp
if [info exists _obTcl_SysMethod($i)] { continue }
lappend all $tmp
}
return $all
}
# obtcl_mkindex:
# Altered version of tcl7.4's auto_mkindex.
# This version also indexes class definitions.
#
# Original comment:
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# floowed by any number of glob patterns to use in that directory to
# locate all of the relevant files.
proc obtcl_mkindex {dir args} {
global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"obtcl_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands/classes. Typically each line is a command/class that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command/class and the value is\n"
append index "# a script that loads the command/class.\n\n"
foreach file [eval glob $args] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if [regexp {^(proc|class)[ ]+([^ ]*)} $line match dummy entityName] {
append index "set [list auto_index($entityName)]"
append index " \"source \$dir/$file\"\n"
}
}
close $f
} msg]
if $error {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f [open tclIndex w]
puts $f $index nonewline
close $f
cd $oldDir
}

112
tcl/tcl8/test.tst Normal file
View File

@ -0,0 +1,112 @@
# test.tst
# I avoided extension tcl so it won't show up in the tclIndex.
#
# Embryo to the real test-suite.
class I
I method init {} {
instvar Level1
puts "I init"
next
set Level1 0
}
I method Level1 { n } {
instvar Level1
incr Level1 $n
}
class J
J method init {} {
instvar Level2
puts "J init"
next
set Level2 0
}
J method Level2 { n } {
instvar Level2
incr Level2 $n
}
class W
W inherit I J
W method init {} {
instvar Cnt
next
set Cnt 0
}
W method add { n } {
instvar Cnt
incr Cnt $n
}
W new tst
tst Level1 4711
tst Level2 4711
# Now redefine class and see what happens
class W
puts -nonewline stderr "Testing: Redefining class removes methods"
set tmp [W info methods]
if { "$tmp" != "" } {
puts stderr ""
puts stderr "Error: Redefining class does not remove methods"
puts stderr " `W info methods' gave: $tmp"
puts stderr " Should have been empty"
} else {
puts stderr ": OK"
}
puts -nonewline stderr "Testing: Redefining class removes cached methods"
set tmp [W info cached]
if { "$tmp" != "info" } {
puts stderr ""
puts stderr "Error: Redefining class does not flush cache"
puts stderr " `W info cached' gave: $tmp"
puts stderr " Should have been: info"
} else {
puts stderr ": OK"
}
W inherit I
tst Level1 1
W inherit I
puts -nonewline stderr "Testing: Redefining inheritance removes cached methods"
set tmp [W info cached]
if { "$tmp" != "info" } {
puts stderr ""
puts stderr "Error: Redefining inheritance does not flush cache"
puts stderr " `W info cached' gave: $tmp"
puts stderr " Should have been: info"
} else {
puts stderr ": OK"
}
puts -nonewline stderr "Testing: Using inherited proc creates cache-proc"
tst Level1 1
set tmp [W info cached]
if { "$tmp" != "Level1 info" } {
puts stderr ""
puts stderr "Error: `W info cached' gave '$tmp'"
puts stderr " Should have been 'Level1 info'"
} else {
puts stderr ": OK"
}
class I
puts -nonewline stderr "Testing: Redefining inherited class removes cached methods"
set tmp [W info cached]
if { "$tmp" != "info" } {
puts stderr ""
puts stderr "Error: `W info cached' gave '$tmp'"
puts stderr " Should have been 'info'"
} else {
puts stderr ": OK"
}

771
tcl/tcl8/topsicom.tcl Normal file
View File

@ -0,0 +1,771 @@
#----------------------------------------------------------------------------
# Scan command implementation for TOPSI
# Test version, Mark Koennecke, February 1997
#----------------------------------------------------------------------------
set home /data/koenneck/src/sics/tcl/tcl8
set datapath /data/koenneck/src/sics/tmp
set recoverfil /data/koenneck/src/sics/recover.dat
source $home/utils.tcl
source $home/obtcl8.tcl
source $home/inherit8.tcl
source $home/base8.tcl
#-------------------------- some utility functions -------------------------
proc MC { t n } {
set string $t
for { set i 1 } { $i < $n } { incr i } {
set string [format "%s%s" $string $t]
}
return $string
}
#--------------------------------------------------------------------------
proc GetNum { text } {
set list [split $text =]
return [lindex $list 1]
}
#-------------------------- String list for writing ------------------------
class DataSet
DataSet method init { } {
instvar N
instvar Data
next
set Data(0) " Bla"
set N 0
}
DataSet method add { text } {
instvar N
instvar Data
set Data($N) $text
incr N
}
DataSet method ins { text i } {
instvar Data
instvar N
if { $i >= $N } {
set N [expr $i + 1]
} else {
unset Data($i)
}
set Data($i) $text
}
DataSet method put { file } {
instvar Data
instvar N
for { set i 0 } { $i < $N } { incr i } {
puts $file $Data($i)
}
}
DataSet method clear { } {
instvar Data
instvar N
unset Data
set Data(0) "Bla"
set N 0
}
DataSet method GetN { } {
instvar N
return $N
}
#---------------------------------------------------------------------------
# scan class initialization
class ScanCommand
ScanCommand method init { counter } {
instvar ScanData
instvar [DataSet new Data]
instvar Active
instvar Recover
next
set ScanData(Mode) Timer
set ScanData(NP) 1
set ScanData(counter) $counter
set ScanData(NoVar) 0
set ScanData(Preset) 10.
set ScanData(File) Default.dat
set ScanData(Counts) " "
set ScanData(cinterest) " "
set ScanData(pinterest) " "
set Active 0
set Recover 0
}
#-------------add scan variables---------------------------------------------
ScanCommand method var { name start step } {
instvar ScanData
instvar ScanVar
instvar Active
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
# check parameters
set t [SICSType $name]
if { [string compare $t DRIV] != 0 } {
ClientPut [format "ERROR: %s is not drivable" $name] error
return 0
}
set t [SICSType $start]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $start] error
return 0
}
set t [SICSType $step]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $step] error
return 0
}
# install the variable
set i $ScanData(NoVar)
set ScanData(NoVar) [incr ScanData(NoVar)]
set ScanVar($i,Var) $name
set ScanVar($i,Start) $start
set ScanVar($i,Step) $step
set ScanVar($i,Value) " "
$self SendInterest pinterest ScanVarChange
ClientPut OK
}
#---------------------- getvars ------------------------------------------
ScanCommand method getvars {} {
instvar ScanData
instvar ScanVar
set list ""
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
lappend list $ScanVar($i,Var)
}
return [format "scan.Vars = %s -END-" $list]
}
#------------------------------------------------------------------------
ScanCommand method xaxis {} {
instvar ScanData
instvar ScanVar
if { $ScanData(NoVar) <= 0} {
#---- default Answer
set t [format "%s.xaxis = %f %f" $self 0 1]
} else {
set t [format "%s.xaxis = %f %f" $self $ScanVar(0,Start) \
$ScanVar(0,Step)]
}
ClientPut $t
}
#--------------------- modvar --------------------------------------------
ScanCommand method modvar {name start step } {
instvar ScanData
instvar ScanVar
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
if { [string compare $name $ScanVar($i,Var)] == 0} {
set t [SICSType $start]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $start] error
return 0
}
set t [SICSType $step]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $step] error
return 0
}
#-------- do it
set ScanVar($i,Start) $start
set ScanVar($i,Step) $step
return OK
}
}
error [format "Scan Variable %s NOT found" $name]
}
#----------------- interests ----------------------------------------------
ScanCommand method cinterest {} {
instvar ScanData
set nam [GetNum [config MyName]]
lappend ScanData(cinterest) $nam
}
#--------------------------------------------------------------------------
ScanCommand method pinterest {} {
instvar ScanData
set nam [GetNum [config MyName]]
lappend ScanData(pinterest) $nam
}
#-------------------------------------------------------------------------
ScanCommand method SendInterest { type text } {
instvar ScanData
#------ check list first
set l1 $ScanData($type)
set l2 ""
foreach e $l1 {
set b [string trim $e]
set g [string trim $b "{}"]
set ret [SICSType $g]
if { [string first COM $ret] >= 0 } {
lappend l2 $e
}
}
#-------- update scan data and write
set ScanData($type) $l2
foreach e $l2 {
set b [string trim $e]
$b put $text
}
}
#---------------- Change Mode ----------------------------------------------
ScanCommand method Mode { {NewVal NULL } } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%.Mode = %s" $self $ScanData(Mode)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
if { ([string compare $NewVal "Timer"] == 0) || \
([string compare $NewVal Monitor] ==0) } {
set ScanData(Mode) $NewVal
ClientPut OK
} else {
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
}
}
}
#----------------------------- NP -------------------------------------------
ScanCommand method NP { { NewVal NULL } } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.NP = %d" $self $ScanData(NP)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
set t [SICSType $NewVal]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number" $NewVal] error
return
}
set ScanData(NP) $NewVal
ClientPut OK
}
}
#------------------------------ Preset ------------------------------------
ScanCommand method Preset { {NewVal NULL} } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.Preset = %f" $self $ScanData(Preset)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
set ScanData(Preset) $NewVal
set t [SICSType $NewVal]
if { [string compare $t NUM] != 0} {
ClientPut [format "ERROR: %s is no number" $NewVal] error
return
}
ClientPut OK
}
}
#------------------------------ File ------------------------------------
ScanCommand method File { {NewVal NULL} } {
instvar ScanData
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.File = %s" $self $ScanData(File)]
ClientPut $val
return $val
} else {
set ScanData(File) $NewVal
ClientPut OK
}
}
#--------------------------- Count ---------------------------------------
# These and the commands below are for use in recovery only
ScanCommand method RecoCount { val } {
instvar Recover
instvar ScanData
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanData(Counts) $val
}
#--------------------------- monitor -------------------------------------
ScanCommand method RecoMonitor { val } {
instvar Recover
instvar ScanData
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanData(Monitor) $val
}
#--------------------------- var -------------------------------------
ScanCommand method RecoVar { var val } {
instvar Recover
instvar ScanData
instvar ScanVar
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanVar($var,Value) $val
}
#--------------------------- WriteRecover --------------------------------
ScanCommand method WriteRecover { } {
instvar ScanData
instvar ScanVar
global recoverfil
set fd [open $recoverfil w]
puts $fd [format "%s Preset %s " $self $ScanData(Preset)]
puts $fd [format "%s Mode %s " $self $ScanData(Mode)]
puts $fd [format "%s NP %s " $self $ScanData(NP)]
puts $fd [format "%s File %s " $self $ScanData(File)]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
puts $fd [format "%s var %s %s %s" $self $ScanVar($i,Var) \
$ScanVar($i,Start) $ScanVar($i,Step)]
puts $fd [format "%s RecoVar %d %s" $self $i [list $ScanVar($i,Value)]]
}
puts $fd [format "%s RecoCount %s" $self [list $ScanData(Counts)]]
puts $fd [format "%s RecoMonitor %s" $self [list $ScanData(Monitor)]]
close $fd
}
#-------------------------- list ------------------------------------------
ScanCommand method list { } {
instvar ScanData
instvar ScanVar
ClientPut [format "%s.Preset = %f" $self $ScanData(Preset)]
ClientPut [format "%s.Mode = %s" $self $ScanData(Mode)]
ClientPut [format "%s.File = %s" $self $ScanData(File)]
ClientPut [format "%s.NP = %d" $self $ScanData(NP)]
ClientPut "ScanVariables:"
for { set i 0 } {$i < $ScanData(NoVar) } { incr i } {
ClientPut [format " %s %f %f" $ScanVar($i,Var) $ScanVar($i,Start) \
$ScanVar($i,Step)]
}
}
#--------------------------------- clear ---------------------------------
ScanCommand method clear { } {
instvar ScanData
instvar ScanVar
instvar Data
instvar Active
# check for activity
if {$Active} {
ClientPut "ERROR: cannot clear running scan" error
return
}
set ScanData(NP) 0
set ScanData(NoVar) 0
set ScanData(Counts) " "
set ScanData(Monitor) " "
Data clear
$self SendInterest pinterest ScanVarChange
ClientPut OK
}
#--------------------------- Store Initial data -----------------------------
ScanCommand method SaveHeader { } {
instvar Data
instvar ScanData
instvar ScanVar
Data clear
# administrative header
Data add [format "%s TOPSI Data File %s" [MC * 30] \
[MC * 30]]
Data add [Title]
Data add [User]
Data add [format "File created: %s" [sicstime]]
Data add [MC * 75]
Data add [format " %s Setting %s " [MC * 30] [MC * 30]]
# settings of instrument variables
Data add [format "%s Monochromator %s" [MC - 30] [MC - 30]]
Data add [lambda]
Data add [MTL position]
Data add [MTU position]
Data add [MGU position]
# diaphragm should go here
# sample info
Data add [format "%s Sample %s" [MC - 30] [MC - 30]]
Data add [STL position]
Data add [STU position]
Data add [SGL position]
Data add [SGU position]
Data add [MC * 75]
# counter info
Data add [format "CountMode = %s" $ScanData(Mode)]
Data add [format "Count Preset = %s" $ScanData(Preset)]
Data add [MC * 75]
Data add [format "%s DATA %s" [MC * 30] [MC * 30]]
set val "Variables scanned: "
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append val " " $ScanVar($i,Var)
}
Data add "$val"
append t [LeftAlign NP 5]
append t [LeftAlign Counts 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,Var) 10]
}
Data add $t
set ScanData(Ptr) [Data GetN]
}
#-----------------------------------------------------------------------------
ScanCommand method ConfigureDevices { } {
instvar ScanData
$ScanData(counter) SetMode $ScanData(Mode)
$ScanData(counter) SetPreset $ScanData(Preset)
}
#----------------------------------------------------------------------------
ScanCommand method StoreScanPoint { } {
instvar ScanData
instvar Data
instvar ScanVar
lappend ScanData(Counts) [GetNum [$ScanData(counter) GetCounts]]
lappend ScanData(Monitor) [GetNum [$ScanData(counter) GetMonitor 1]]
#------------ get Scan Var Values
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
lappend ScanVar($i,Value) [GetNum [$ScanVar($i,Var) position]]
}
set iFile $ScanData(Ptr)
#------------ write it
set length [llength $ScanData(Counts)]
for { set i 0 } { $i < $length} { incr i} {
set t " "
append t [LeftAlign $i 5]
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii} {
append t [LeftAlign [lindex $ScanVar($ii,Value) $i] 10]
}
Data ins $t $iFile
incr iFile
}
set fd [open $ScanData(File) w]
Data put $fd
close $fd
}
#--------------------------------------------------------------------------
ScanCommand method GetCounts { } {
instvar ScanData
#------- get data available
set length [llength $ScanData(Counts)]
for { set i 0 } { $i < $length } { incr i} {
lappend result [lindex $ScanData(Counts) $i]
}
#------ put zero in those which are not yet measured
if { $length < $ScanData(NP) } {
for { set i $length } { $i < $ScanData(NP) } { incr i } {
lappend result 0
}
}
return "scan.Counts= $result"
}
#---------------------------------------------------------------------------
ScanCommand method EndScan { } {
instvar Data
instvar ScanData
instvar ScanVar
Data add [format "%s End of Data %s" [MC * 30] [MC * 30]]
set fd [open $ScanData(File) w]
Data put $fd
close $fd
}
#-------------------------------------------------------------------------
ScanCommand method EvalInt { } {
set int [GetInt]
ClientPut [format "Interrupt %s detected" $int]
switch -exact $int {
continue {
return OK
}
abortop {
SetInt continue
return SKIP
}
abortscan {
SetInt continue
return ABORT
}
default {
return ABORT
}
}
}
#--------------------------------------------------------------------------
ScanCommand method DriveTo { iNP } {
instvar ScanData
instvar ScanVar
set command "drive "
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
set ScanVar($i,NewVal) [expr $ScanVar($i,Start) + $iNP * \
$ScanVar($i,Step)]
# append ScanVar($i,Value) " " $ScanVar($i,NewVal)
append command " " $ScanVar($i,Var) " " $ScanVar($i,NewVal)
}
set ret [catch {eval $command } msg ]
if { $ret != 0 } {
ClientPut $msg error
return [$self EvalInt]
}
return OK
}
#------------------------------------------------------------------------
ScanCommand method CheckScanBounds { } {
instvar ScanData
instvar ScanVar
for { set i 0} { $i < $ScanData(NP) } { incr i } {
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii } {
set NewVal [expr $ScanVar($ii,Start) + $i*$ScanVar($ii,Step)]
set iRet [catch {SICSBounds $ScanVar($ii,Var) $NewVal} msg]
if { $iRet != 0 } {
ClientPut $msg error
return 0
}
}
}
return 1
}
#-------------------------------------------------------------------------
ScanCommand method Count { } {
instvar ScanData
set command $ScanData(counter)
append command " Count "
append command $ScanData(Preset)
set ret [catch {eval $command } msg ]
if { $ret != 0 } {
ClientPut $msg error
return [$self EvalInt]
}
return OK
}
#-------------------------------------------------------------------------
proc LeftAlign { text iField } {
set item $text
append item [MC " " $iField]
return [string range $item 0 $iField]
}
#-------------------------------------------------------------------------
ScanCommand method ScanStatusHeader { } {
instvar ScanData
instvar ScanVar
append t [LeftAlign NP 5]
append t [LeftAlign Counts 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,Var) 10]
}
ClientPut $t status
}
#------------------------------------------------------------------------
ScanCommand method ProgressReport { i } {
instvar ScanData
instvar ScanVar
$self ScanStatusHeader
append t [LeftAlign $i 5]
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,NewVal) 10]
}
ClientPut $t status
}
#-------------------------------------------------------------------------
ScanCommand method MakeFile { } {
global datapath
instvar ScanData
SicsDataNumber incr
set num1 [SicsDataNumber]
set num [GetNum $num1]
set fil [ format "%s/topsi%4.4d%2.2d.dat" $datapath $num 97]
set ScanData(File) $fil
}
#--------------------------------------------------------------------------
ScanCommand method run { } {
instvar ScanData
instvar Data
instvar ScanVar
instvar Active
# start with error checking
if { $ScanData(NP) < 1 } {
ClientPut "ERROR: Insufficient Number of ScanPoints"
return
}
if { $ScanData(NoVar) < 1 } {
ClientPut "ERROR: No variables to scan given!"
return
}
#------- check for activity
if {$Active} {
ClientPut "ERROR: Scan already in progress" error
return
}
#------- check Bounds
if { [$self CheckScanBounds] != 1 } {
return
}
# clean data space from relicts of previous scans
Data clear
set ScanData(Counts) " "
set ScanData(Monitor) " "
for {set i 0} { $i < $ScanData(NoVar) } { incr i } {
set ScanVar($i,Value) " "
}
# configure and save data header
$self ConfigureDevices
$self MakeFile
$self SaveHeader
ClientPut [format "Writing %s" $ScanData(File)]
# the actual scan loop
SetStatus Scanning
$self SendInterest cinterest NewScan
set Active 1
for { set i 0 } { $i < $ScanData(NP) } { incr i } {
#---- driving
set ret [$self DriveTo $i]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted at drive"
SetStatus Eager
set Active 0
error "Abort"
}
}
#---- counting
set ret [$self Count]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted at counting"
SetStatus Eager
set Active 0
error "Abort"
}
}
#--- save data
$self StoreScanPoint
$self WriteRecover
#--- invoke interests
$self SendInterest cinterest [$self GetCounts]
#--- Status Report
$self ProgressReport $i
}
#---- final processing
$self EndScan
ClientPut "OK"
SetStatus Eager
set Active 0
}
#--------------------------------------------------------------------------
ScanCommand method Recover { } {
instvar ScanData
instvar Data
instvar ScanVar
instvar Active
instvar Recover
global recoverfil
# ---- read Recover Information
set Recover 1
$self clear
source $recoverfil
# configure and save data header
$self ConfigureDevices
$self SaveHeader
# Write scan start info
$self ScanStatusHeader
# --- figure out where we are
set Recover 0
set pos [llength $ScanData(Counts)]
# ----------------------the actual scan loop
set OldStat [status]
SetStatus Scanning
set Active 1
for { set i $pos } { $i < $ScanData(NP) } { incr i } {
#---- driving
set ret [$self DriveTo $i]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted"
SetStatus $OldStat
set Active 0
return
}
}
#---- counting
set ret [$self Count]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted"
SetStatus $OldStat
set Active 0
return
}
}
#--- save data
$self StoreScanPoint
$self WriteRecover
#--- Status Report
$self ProgressReport $i
}
#---- final processing
$self EndScan
ClientPut "OK"
SetStatus $OldStat
set Active 0
}
#---------------------------------------------------------------------------
# finally initialise the scan command
ScanCommand new scan counter
#---------------------------------------------------------------------------
# a new user command which allows status clients to read the counts in a scan
# This is just to circumvent the user protection on scan
proc ScanCounts { } {
set status [ catch {scan GetCounts} result]
if { $status == 0 } {
return $result
} else {
return "scan.Counts= 0"
}
}
#---------------------------------------------------------------------------
# This is just another utilility function which helps in implementing the
# status display client
proc TextStatus { } {
set text [status]
return [format "Status = %s" $text]
}
#---------------------------------------------------------------------------
# Dumps time in a useful format
proc sftime {} {
return [format "sicstime = %s" [sicstime]]
}

398
tcl/tcl8/utils.tcl Normal file
View File

@ -0,0 +1,398 @@
#----------------------------------------------------------------------
# Some generic utility functions
#
proc cmt args {}
proc Nop {} {}
proc setIfNew { var val } {
global $var
if ![info exists $var] {
set $var $val
}
}
proc crunch_skip args {}
crunch_skip begin
cmt {
proc o_push { v val } {
upvar 1 $v l
lappend l $val
}
proc o_pop v {
upvar 1 $v l
set tmp [lindex $l end]
catch {set l [lreplace $l end end]}
return $tmp
}
proc o_peek v {
upvar 1 $v l
return [lindex $l end]
}
}
crunch_skip end
proc lappendUniq { v val } {
upvar $v var
if { [lsearch $var $val] != -1 } { return }
lappend var $val
}
proc listMinus { a b } {
set ret {}
foreach i $a { set ArrA($i) 1 }
foreach i $b { set ArrB($i) 1 }
foreach i [array names ArrA] {
if ![info exists ArrB($i)] {
lappend ret $i
}
}
return $ret
}
#----------------------------------------------------------------------
#
# StrictMotif: Redefine look-and-feel to be more Motif like.
# This routine disables scrollbar from being pushed in (sunken),
# as well as sets the tk_strictMotif variable.
# `_otReferenceSBD' is only for string comparison with currently used routine.
# DO NOT ALTER IN ANY WAY!
#
set _otReferenceSBD {
global tkPriv
set tkPriv(relief) [$w cget -activerelief]
$w configure -activerelief sunken
set element [$w identify $x $y]
if {$element == "slider"} {
tkScrollStartDrag $w $x $y
} else {
tkScrollSelect $w $element initial
}
}
proc otTkScrollButtonDown {w x y} {
global tkPriv
set tkPriv(relief) [$w cget -activerelief]
set element [$w identify $x $y]
if [string compare "slider" $element] {
$w configure -activerelief sunken
tkScrollSelect $w $element initial
} else {
tkScrollStartDrag $w $x $y
}
}
proc StrictMotif {} {
global tk_version tk_strictMotif _otReferenceSBD
set tk_strictMotif 1
if { $tk_version == 4.0 ||
![string compare [info body tkScrollButtonDown] \
[set _otReferenceSBD]] } {
if [string compare "" [info procs otTkScrollButtonDown]] {
rename tkScrollButtonDown {}
rename otTkScrollButtonDown tkScrollButtonDown
}
}
}
proc dbputs s {}
# Dummy to allow crunched obtcl processing normal obTcl-scripts
proc DOC { name rest } {}
proc DOC_get_list {} {}
crunch_skip begin
setIfNew db_debug 0
proc db_debug {} {
global db_debug
set db_debug [expr !$db_debug]
}
proc dbputs s {
global db_debug
if { $db_debug != 0 } {
puts stderr $s
}
}
#----------------------------------------------------------------------
# DOCS
setIfNew _uPriv_DOCS() ""
proc DOC_get_list {} {
global _uPriv_DOCS
return [array names _uPriv_DOCS]
}
proc DOC { name rest } {
global _uPriv_DOCS
set _uPriv_DOCS($name) $rest
}
proc PrDOCS {} {
global _uPriv_DOCS
set names [lsort [array names _uPriv_DOCS]]
foreach i $names {
puts "$_uPriv_DOCS($i)"
puts "----------------------------------------------------------------------"
}
}
proc GetDOCS {} {
global _uPriv_DOCS
set names [lsort [array names _uPriv_DOCS]]
set all ""
foreach i $names {
append all "$_uPriv_DOCS($i)"
append all "----------------------------------------------------------------------"
}
return $all
}
proc GetDOC name {
global _uPriv_DOCS
return $_uPriv_DOCS($name)
}
proc help args {
global _uPriv_DOCS
set names [lsort [array names _uPriv_DOCS "${args}*"]]
if { [llength $names] > 1 } {
puts "Select one of: "
set n 1
foreach i $names {
puts " ${n}) $i "
incr n 1
}
puts -nonewline ">> "
set answ [gets stdin]
append tmp [lindex $names [expr $answ-1]]
eval help $tmp
}
if { [llength $names] == 1 } {
eval set tmp $names
puts $_uPriv_DOCS($tmp)
}
if { [llength $names] < 1 } {
puts "No help on: $args"
}
}
#----------------------------------------------------------------------
DOC "Tcl-debugger" {
NAME
Tcldb - A Tcl debugger
SYNOPSIS
bp ?ID?
DESCRIPTION
A simple debugger for Tcl-script. Breakpoints are set by calling
`bp' from your Tcl-code. Selecting where to break is done by
string-matching.
USAGE
Use by putting calls to `bp' in the Tcl-code. If `ID' is specified,
it will be displayed when the breakpoint is reached.
Example of using two breakpoints with different IDs:
func say { a } {
bp say_A
puts "You said: $a!"
bp say_B
}
Call `bpOff' to disable all breakpoints, `bpOn' to enable all,
`bpOn <funcname>' to enable breakpoints in functions matching
<funcname>, and finally `bpID <ID>' to enable breakpoints
matching <ID>. Matching is done according to Tcl's `string match'
function.
When in the break-point handler, type "?" for help.
ACKNOWLEDGEMENTS
This simple debugger is based on Stephen Uhler's article
"Debugging Tcl Scripts" from the Oct-95 issue of Linux Journal.
}
proc bpGetHelp {} {
puts stderr \
"------------------------------- Tcldb help ------------------------------------
Set breakpoints by adding calls to `bp' in your Tcl-code. Example:
bp Func1 ;# bp followed by the identifier `Func1'
Commands available when in `bp':
+ Move down in call-stack
- Move up in call stack
. Show current proc name and params
v Show names of variables currently in scope
V Show names and values of variables currently in scope
l Show names of variables that are local (transient)
L Show names and values of variables that are local (transient)
g Show names of variables that are declared global
G Show names and values of variables that are declared global
t Show a call chain trace, terse mode
T Show a call chain trace, verbose mode
b Show body of current proc
c Continue execution
h,? Print this help
You can also enter any Tcl command (even multi-line) and it will be
executed in the currently selected stack frame.
Available at any time:
bpOff Turn off all breakpoints
bpOn Turn on all breakpoints
bpOn <match>
Enable breakpoints in functions with names matching <match>
bpID <match>
Enable breakpoints whose ID matches <match>
"
}
setIfNew _bp_ON 1
setIfNew _bp_ID *
proc bpOn { {func 1} } { global _bp_ON _bp_ID; set _bp_ID *; set _bp_ON $func }
proc bpID id { global _bp_ON _bp_ID; set _bp_ON 1; set _bp_ID $id }
proc bpOff {} { global _bp_ON; set _bp_ON 0 }
proc bp args {
global _bp_ON _bp_ID
if { $_bp_ON == 0 } { return }
set max [expr [info level] - 1]
set current $max
set fName [lindex [info level $current] 0]
if { "$_bp_ON" == "1" || "$fName" == "$_bp_ON" || \
("$_bp_ON" == "top" && $current == 0) || \
[string match $_bp_ON $fName] } {
if ![string match $_bp_ID $args] {
return
}
} else {
return
}
bpShow VERBOSE $current
while {1} {
if { "$args" != "" } { puts "bp: $args" }
puts -nonewline stderr "#${current}:"
gets stdin line
while {![info complete $line]} {
puts -nonewline "> "
append line "\n[gets stdin]"
}
switch -- $line {
"+" {if {$current < $max} {bpShow VERBOSE [incr current]}}
"-" {if {$current > 0} {bpShow VERBOSE [incr current -1]}}
"b" {bpBody $current}
"c" {puts stderr "Continuing"; return}
"v" {bpVisibleVars NAMES $current}
"V" {bpVisibleVars VALUES $current}
"l" {bpLocalVars NAMES $current}
"L" {bpLocalVars VALUES $current}
"g" {bpGlobalVars NAMES $current}
"G" {bpGlobalVars VALUES $current}
"t" {bpTraceCalls TERSE $current}
"T" {bpTraceCalls VERBOSE $current}
"." {bpShow VERBOSE $current}
"h" -
"?" {bpGetHelp}
default {
catch {uplevel #$current $line } result
puts stderr $result
}
}
}
}
proc bpPrVar { level mode name } {
upvar #$level $name var
if { $mode == "NAMES" } {
puts " $name"
return
}
if { [array exists var] == 1 } {
puts " Array ${name} :"
foreach i [array names var] {
puts " ${name}($i) = [set var($i)]"
}
} else {
if {[info exists var] != 1 } {
puts " $name : Declared but uninitialized"
} else {
puts " $name = $var"
}
}
}
proc bpBody current {
uplevel #$current {
catch {puts [info body [lindex [info level [info level]] 0]]}
}
}
proc bpVisibleVars { mode curr } {
puts "#$curr visible vars:"
foreach i [uplevel #$curr {lsort [info vars]}] {
bpPrVar $curr $mode $i
}
}
proc bpLocalVars { mode curr } {
puts "#$curr local vars:"
foreach i [uplevel #$curr {lsort [info locals]}] {
bpPrVar $curr $mode $i
}
}
proc bpGlobalVars { mode curr } {
puts "#$curr global visible vars:"
set Vis [uplevel #$curr {info vars}]
set Loc [uplevel #$curr {info locals}]
foreach i [lsort [listMinus $Vis $Loc]] {
bpPrVar 0 $mode $i
}
}
proc bpTraceCalls { mode curr } {
for {set i 1} {$i <= $curr} {incr i} {
bpShow $mode $i
}
}
proc bpShow { mode curr } {
if { $curr > 0 } {
set info [info level $curr]
set proc [lindex $info 0]
if {"$mode" == "TERSE"} {
puts stderr "$curr: $proc [lrange $info 1 end]"
return
}
puts stderr "$curr: Proc= $proc \
{[info args $proc]}"
set idx 0
foreach arg [info args $proc] {
if { "$arg" == "args" } {
puts stderr "\t$arg = [lrange $info [incr idx] end]"
break;
} else {
puts stderr "\t$arg = [lindex $info [incr idx]]"
}
}
} else {
puts stderr "Top level"
}
}
crunch_skip end

116
tcl/tclIndex Normal file
View File

@ -0,0 +1,116 @@
# 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 Normal file
View File

@ -0,0 +1,394 @@
#----------------------------------------------------------------------------
# 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/tmp
set recoverfil /data/koenneck/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]
}

772
tcl/topsiold.tcl Normal file
View File

@ -0,0 +1,772 @@
#----------------------------------------------------------------------------
# Scan command implementation for TOPSI
# Test version, Mark Koennecke, February 1997
#----------------------------------------------------------------------------
set home /data/koenneck/src/sics/tcl
set datapath /data/koenneck/src/sics/tmp
set recoverfil /data/koenneck/src/sics/recover.dat
bpOn
source $home/utils.tcl
source $home/base.tcl
source $home/inherit.tcl
source $home/obtcl.tcl
#-------------------------- some utility functions -------------------------
proc MC { t n } {
set string $t
for { set i 1 } { $i < $n } { incr i } {
set string [format "%s%s" $string $t]
}
return $string
}
#--------------------------------------------------------------------------
proc GetNum { text } {
set list [split $text =]
return [lindex $list 1]
}
#-------------------------- String list for writing ------------------------
class DataSet
DataSet method init { } {
instvar N
instvar Data
next
set Data(0) " Bla"
set N 0
}
DataSet method add { text } {
instvar N
instvar Data
set Data($N) $text
incr N
}
DataSet method ins { text i } {
instvar Data
instvar N
if { $i >= $N } {
set N [expr $i + 1]
} else {
unset Data($i)
}
set Data($i) $text
}
DataSet method put { file } {
instvar Data
instvar N
for { set i 0 } { $i < $N } { incr i } {
puts $file $Data($i)
}
}
DataSet method clear { } {
instvar Data
instvar N
unset Data
set Data(0) "Bla"
set N 0
}
DataSet method GetN { } {
instvar N
return $N
}
#---------------------------------------------------------------------------
# scan class initialization
class ScanCommand
ScanCommand method init { counter } {
instvar ScanData
instvar [DataSet new Data]
instvar Active
instvar Recover
next
set ScanData(Mode) Timer
set ScanData(NP) 1
set ScanData(counter) $counter
set ScanData(NoVar) 0
set ScanData(Preset) 10.
set ScanData(File) Default.dat
set ScanData(Counts) " "
set ScanData(cinterest) " "
set ScanData(pinterest) " "
set Active 0
set Recover 0
}
#-------------add scan variables---------------------------------------------
ScanCommand method var { name start step } {
instvar ScanData
instvar ScanVar
instvar Active
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
# check parameters
set t [SICSType $name]
if { [string compare $t DRIV] != 0 } {
ClientPut [format "ERROR: %s is not drivable" $name] error
return 0
}
set t [SICSType $start]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $start] error
return 0
}
set t [SICSType $step]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $step] error
return 0
}
# install the variable
set i $ScanData(NoVar)
set ScanData(NoVar) [incr ScanData(NoVar)]
set ScanVar($i,Var) $name
set ScanVar($i,Start) $start
set ScanVar($i,Step) $step
set ScanVar($i,Value) " "
$self SendInterest pinterest ScanVarChange
ClientPut OK
}
#---------------------- getvars ------------------------------------------
ScanCommand method getvars {} {
instvar ScanData
instvar ScanVar
set list ""
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
lappend list $ScanVar($i,Var)
}
return [format "scan.Vars = %s -END-" $list]
}
#------------------------------------------------------------------------
ScanCommand method xaxis {} {
instvar ScanData
instvar ScanVar
if { $ScanData(NoVar) <= 0} {
#---- default Answer
set t [format "%s.xaxis = %f %f" $self 0 1]
} else {
set t [format "%s.xaxis = %f %f" $self $ScanVar(0,Start) \
$ScanVar(0,Step)]
}
ClientPut $t
}
#--------------------- modvar --------------------------------------------
ScanCommand method modvar {name start step } {
instvar ScanData
instvar ScanVar
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
if { [string compare $name $ScanVar($i,Var)] == 0} {
set t [SICSType $start]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $start] error
return 0
}
set t [SICSType $step]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number!" $step] error
return 0
}
#-------- do it
set ScanVar($i,Start) $start
set ScanVar($i,Step) $step
return OK
}
}
error [format "Scan Variable %s NOT found" $name]
}
#----------------- interests ----------------------------------------------
ScanCommand method cinterest {} {
instvar ScanData
set nam [GetNum [config MyName]]
lappend ScanData(cinterest) $nam
}
#--------------------------------------------------------------------------
ScanCommand method pinterest {} {
instvar ScanData
set nam [GetNum [config MyName]]
lappend ScanData(pinterest) $nam
}
#-------------------------------------------------------------------------
ScanCommand method SendInterest { type text } {
instvar ScanData
#------ check list first
set l1 $ScanData($type)
set l2 ""
foreach e $l1 {
set b [string trim $e]
set g [string trim $b "{}"]
set ret [SICSType $g]
if { [string first COM $ret] >= 0 } {
lappend l2 $e
}
}
#-------- update scan data and write
set ScanData($type) $l2
foreach e $l2 {
set b [string trim $e]
$b put $text
}
}
#---------------- Change Mode ----------------------------------------------
ScanCommand method Mode { {NewVal NULL } } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%.Mode = %s" $self $ScanData(Mode)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
if { ([string compare $NewVal "Timer"] == 0) || \
([string compare $NewVal Monitor] ==0) } {
set ScanData(Mode) $NewVal
ClientPut OK
} else {
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
}
}
}
#----------------------------- NP -------------------------------------------
ScanCommand method NP { { NewVal NULL } } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.NP = %d" $self $ScanData(NP)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
set t [SICSType $NewVal]
if { [string compare $t NUM] != 0 } {
ClientPut [format "ERROR: %s is no number" $NewVal] error
return
}
set ScanData(NP) $NewVal
ClientPut OK
}
}
#------------------------------ Preset ------------------------------------
ScanCommand method Preset { {NewVal NULL} } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.Preset = %f" $self $ScanData(Preset)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
set ScanData(Preset) $NewVal
set t [SICSType $NewVal]
if { [string compare $t NUM] != 0} {
ClientPut [format "ERROR: %s is no number" $NewVal] error
return
}
ClientPut OK
}
}
#------------------------------ File ------------------------------------
ScanCommand method File { {NewVal NULL} } {
instvar ScanData
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.File = %s" $self $ScanData(File)]
ClientPut $val
return $val
} else {
set ScanData(File) $NewVal
ClientPut OK
}
}
#--------------------------- Count ---------------------------------------
# These and the commands below are for use in recovery only
ScanCommand method RecoCount { val } {
instvar Recover
instvar ScanData
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanData(Counts) $val
}
#--------------------------- monitor -------------------------------------
ScanCommand method RecoMonitor { val } {
instvar Recover
instvar ScanData
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanData(Monitor) $val
}
#--------------------------- var -------------------------------------
ScanCommand method RecoVar { var val } {
instvar Recover
instvar ScanData
instvar ScanVar
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanVar($var,Value) $val
}
#--------------------------- WriteRecover --------------------------------
ScanCommand method WriteRecover { } {
instvar ScanData
instvar ScanVar
global recoverfil
set fd [open $recoverfil w]
puts $fd [format "%s Preset %s " $self $ScanData(Preset)]
puts $fd [format "%s Mode %s " $self $ScanData(Mode)]
puts $fd [format "%s NP %s " $self $ScanData(NP)]
puts $fd [format "%s File %s " $self $ScanData(File)]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
puts $fd [format "%s var %s %s %s" $self $ScanVar($i,Var) \
$ScanVar($i,Start) $ScanVar($i,Step)]
puts $fd [format "%s RecoVar %d %s" $self $i [list $ScanVar($i,Value)]]
}
puts $fd [format "%s RecoCount %s" $self [list $ScanData(Counts)]]
puts $fd [format "%s RecoMonitor %s" $self [list $ScanData(Monitor)]]
close $fd
}
#-------------------------- list ------------------------------------------
ScanCommand method list { } {
instvar ScanData
instvar ScanVar
ClientPut [format "%s.Preset = %f" $self $ScanData(Preset)]
ClientPut [format "%s.Mode = %s" $self $ScanData(Mode)]
ClientPut [format "%s.File = %s" $self $ScanData(File)]
ClientPut [format "%s.NP = %d" $self $ScanData(NP)]
ClientPut "ScanVariables:"
for { set i 0 } {$i < $ScanData(NoVar) } { incr i } {
ClientPut [format " %s %f %f" $ScanVar($i,Var) $ScanVar($i,Start) \
$ScanVar($i,Step)]
}
}
#--------------------------------- clear ---------------------------------
ScanCommand method clear { } {
instvar ScanData
instvar ScanVar
instvar Data
instvar Active
# check for activity
if {$Active} {
ClientPut "ERROR: cannot clear running scan" error
return
}
set ScanData(NP) 0
set ScanData(NoVar) 0
set ScanData(Counts) " "
set ScanData(Monitor) " "
Data clear
$self SendInterest pinterest ScanVarChange
ClientPut OK
}
#--------------------------- Store Initial data -----------------------------
ScanCommand method SaveHeader { } {
instvar Data
instvar ScanData
instvar ScanVar
Data clear
# administrative header
Data add [format "%s TOPSI Data File %s" [MC * 30] \
[MC * 30]]
Data add [Title]
Data add [User]
Data add [format "File created: %s" [sicstime]]
Data add [MC * 75]
Data add [format " %s Setting %s " [MC * 30] [MC * 30]]
# settings of instrument variables
Data add [format "%s Monochromator %s" [MC - 30] [MC - 30]]
Data add [lambda]
Data add [MTL position]
Data add [MTU position]
Data add [MGU position]
# diaphragm should go here
# sample info
Data add [format "%s Sample %s" [MC - 30] [MC - 30]]
Data add [STL position]
Data add [STU position]
Data add [SGL position]
Data add [SGU position]
Data add [MC * 75]
# counter info
Data add [format "CountMode = %s" $ScanData(Mode)]
Data add [format "Count Preset = %s" $ScanData(Preset)]
Data add [MC * 75]
Data add [format "%s DATA %s" [MC * 30] [MC * 30]]
set val "Variables scanned: "
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append val " " $ScanVar($i,Var)
}
Data add "$val"
append t [LeftAlign NP 5]
append t [LeftAlign Counts 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,Var) 10]
}
Data add $t
set ScanData(Ptr) [Data GetN]
}
#-----------------------------------------------------------------------------
ScanCommand method ConfigureDevices { } {
instvar ScanData
$ScanData(counter) SetMode $ScanData(Mode)
$ScanData(counter) SetPreset $ScanData(Preset)
}
#----------------------------------------------------------------------------
ScanCommand method StoreScanPoint { } {
instvar ScanData
instvar Data
instvar ScanVar
lappend ScanData(Counts) [GetNum [$ScanData(counter) GetCounts]]
lappend ScanData(Monitor) [GetNum [$ScanData(counter) GetMonitor 1]]
#------------ get Scan Var Values
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
lappend ScanVar($i,Value) [GetNum [$ScanVar($i,Var) position]]
}
set iFile $ScanData(Ptr)
#------------ write it
set length [llength $ScanData(Counts)]
for { set i 0 } { $i < $length} { incr i} {
set t " "
append t [LeftAlign $i 5]
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii} {
append t [LeftAlign [lindex $ScanVar($ii,Value) $i] 10]
}
Data ins $t $iFile
incr iFile
}
set fd [open $ScanData(File) w]
Data put $fd
close $fd
}
#--------------------------------------------------------------------------
ScanCommand method GetCounts { } {
instvar ScanData
#------- get data available
set length [llength $ScanData(Counts)]
for { set i 0 } { $i < $length } { incr i} {
lappend result [lindex $ScanData(Counts) $i]
}
#------ put zero in those which are not yet measured
if { $length < $ScanData(NP) } {
for { set i $length } { $i < $ScanData(NP) } { incr i } {
lappend result 0
}
}
return "scan.Counts= $result"
}
#---------------------------------------------------------------------------
ScanCommand method EndScan { } {
instvar Data
instvar ScanData
instvar ScanVar
Data add [format "%s End of Data %s" [MC * 30] [MC * 30]]
set fd [open $ScanData(File) w]
Data put $fd
close $fd
}
#-------------------------------------------------------------------------
ScanCommand method EvalInt { } {
set int [GetInt]
ClientPut [format "Interrupt %s detected" $int]
switch -exact $int {
continue {
return OK
}
abortop {
SetInt continue
return SKIP
}
abortscan {
SetInt continue
return ABORT
}
default {
return ABORT
}
}
}
#--------------------------------------------------------------------------
ScanCommand method DriveTo { iNP } {
instvar ScanData
instvar ScanVar
set command "drive "
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
set ScanVar($i,NewVal) [expr $ScanVar($i,Start) + $iNP * \
$ScanVar($i,Step)]
# append ScanVar($i,Value) " " $ScanVar($i,NewVal)
append command " " $ScanVar($i,Var) " " $ScanVar($i,NewVal)
}
set ret [catch {eval $command } msg ]
if { $ret != 0 } {
ClientPut $msg error
return [$self EvalInt]
}
return OK
}
#------------------------------------------------------------------------
ScanCommand method CheckScanBounds { } {
instvar ScanData
instvar ScanVar
for { set i 0} { $i < $ScanData(NP) } { incr i } {
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii } {
set NewVal [expr $ScanVar($ii,Start) + $i*$ScanVar($ii,Step)]
set iRet [catch {SICSBounds $ScanVar($ii,Var) $NewVal} msg]
if { $iRet != 0 } {
ClientPut $msg error
return 0
}
}
}
return 1
}
#-------------------------------------------------------------------------
ScanCommand method Count { } {
instvar ScanData
set command $ScanData(counter)
append command " Count "
append command $ScanData(Preset)
set ret [catch {eval $command } msg ]
if { $ret != 0 } {
ClientPut $msg error
return [$self EvalInt]
}
return OK
}
#-------------------------------------------------------------------------
proc LeftAlign { text iField } {
set item $text
append item [MC " " $iField]
return [string range $item 0 $iField]
}
#-------------------------------------------------------------------------
ScanCommand method ScanStatusHeader { } {
instvar ScanData
instvar ScanVar
append t [LeftAlign NP 5]
append t [LeftAlign Counts 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,Var) 10]
}
ClientPut $t status
}
#------------------------------------------------------------------------
ScanCommand method ProgressReport { i } {
instvar ScanData
instvar ScanVar
$self ScanStatusHeader
append t [LeftAlign $i 5]
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,NewVal) 10]
}
ClientPut $t status
}
#-------------------------------------------------------------------------
ScanCommand method MakeFile { } {
global datapath
instvar ScanData
SicsDataNumber incr
set num1 [SicsDataNumber]
set num [GetNum $num1]
set fil [ format "%s/topsi%4.4d%2.2d.dat" $datapath $num 97]
set ScanData(File) $fil
}
#--------------------------------------------------------------------------
ScanCommand method run { } {
instvar ScanData
instvar Data
instvar ScanVar
instvar Active
# start with error checking
if { $ScanData(NP) < 1 } {
ClientPut "ERROR: Insufficient Number of ScanPoints"
return
}
if { $ScanData(NoVar) < 1 } {
ClientPut "ERROR: No variables to scan given!"
return
}
#------- check for activity
if {$Active} {
ClientPut "ERROR: Scan already in progress" error
return
}
#------- check Bounds
if { [$self CheckScanBounds] != 1 } {
return
}
# clean data space from relicts of previous scans
Data clear
set ScanData(Counts) " "
set ScanData(Monitor) " "
for {set i 0} { $i < $ScanData(NoVar) } { incr i } {
set ScanVar($i,Value) " "
}
# configure and save data header
$self ConfigureDevices
$self MakeFile
$self SaveHeader
ClientPut [format "Writing %s" $ScanData(File)]
# the actual scan loop
SetStatus Scanning
$self SendInterest cinterest NewScan
set Active 1
for { set i 0 } { $i < $ScanData(NP) } { incr i } {
#---- driving
set ret [$self DriveTo $i]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted at drive"
SetStatus Eager
set Active 0
error "Abort"
}
}
#---- counting
set ret [$self Count]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted at counting"
SetStatus Eager
set Active 0
error "Abort"
}
}
#--- save data
$self StoreScanPoint
$self WriteRecover
#--- invoke interests
$self SendInterest cinterest [$self GetCounts]
#--- Status Report
$self ProgressReport $i
}
#---- final processing
$self EndScan
ClientPut "OK"
SetStatus Eager
set Active 0
}
#--------------------------------------------------------------------------
ScanCommand method Recover { } {
instvar ScanData
instvar Data
instvar ScanVar
instvar Active
instvar Recover
global recoverfil
# ---- read Recover Information
set Recover 1
$self clear
source $recoverfil
# configure and save data header
$self ConfigureDevices
$self SaveHeader
# Write scan start info
$self ScanStatusHeader
# --- figure out where we are
set Recover 0
set pos [llength $ScanData(Counts)]
# ----------------------the actual scan loop
set OldStat [status]
SetStatus Scanning
set Active 1
for { set i $pos } { $i < $ScanData(NP) } { incr i } {
#---- driving
set ret [$self DriveTo $i]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted"
SetStatus $OldStat
set Active 0
return
}
}
#---- counting
set ret [$self Count]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted"
SetStatus $OldStat
set Active 0
return
}
}
#--- save data
$self StoreScanPoint
$self WriteRecover
#--- Status Report
$self ProgressReport $i
}
#---- final processing
$self EndScan
ClientPut "OK"
SetStatus $OldStat
set Active 0
}
#---------------------------------------------------------------------------
# finally initialise the scan command
ScanCommand new scan counter
#---------------------------------------------------------------------------
# a new user command which allows status clients to read the counts in a scan
# This is just to circumvent the user protection on scan
proc ScanCounts { } {
set status [ catch {scan GetCounts} result]
if { $status == 0 } {
return $result
} else {
return "scan.Counts= 0"
}
}
#---------------------------------------------------------------------------
# This is just another utilility function which helps in implementing the
# status display client
proc TextStatus { } {
set text [status]
return [format "Status = %s" $text]
}
#---------------------------------------------------------------------------
# Dumps time in a useful format
proc sftime {} {
return [format "sicstime = %s" [sicstime]]
}

398
tcl/utils.tcl Normal file
View File

@ -0,0 +1,398 @@
#----------------------------------------------------------------------
# Some generic utility functions
#
proc cmt args {}
proc Nop {} {}
proc setIfNew { var val } {
global $var
if ![info exists $var] {
set $var $val
}
}
proc crunch_skip args {}
crunch_skip begin
cmt {
proc o_push { v val } {
upvar 1 $v l
lappend l $val
}
proc o_pop v {
upvar 1 $v l
set tmp [lindex $l end]
catch {set l [lreplace $l end end]}
return $tmp
}
proc o_peek v {
upvar 1 $v l
return [lindex $l end]
}
}
crunch_skip end
proc lappendUniq { v val } {
upvar $v var
if { [lsearch $var $val] != -1 } { return }
lappend var $val
}
proc listMinus { a b } {
set ret {}
foreach i $a { set ArrA($i) 1 }
foreach i $b { set ArrB($i) 1 }
foreach i [array names ArrA] {
if ![info exists ArrB($i)] {
lappend ret $i
}
}
return $ret
}
#----------------------------------------------------------------------
#
# StrictMotif: Redefine look-and-feel to be more Motif like.
# This routine disables scrollbar from being pushed in (sunken),
# as well as sets the tk_strictMotif variable.
# `_otReferenceSBD' is only for string comparison with currently used routine.
# DO NOT ALTER IN ANY WAY!
#
set _otReferenceSBD {
global tkPriv
set tkPriv(relief) [$w cget -activerelief]
$w configure -activerelief sunken
set element [$w identify $x $y]
if {$element == "slider"} {
tkScrollStartDrag $w $x $y
} else {
tkScrollSelect $w $element initial
}
}
proc otTkScrollButtonDown {w x y} {
global tkPriv
set tkPriv(relief) [$w cget -activerelief]
set element [$w identify $x $y]
if [string compare "slider" $element] {
$w configure -activerelief sunken
tkScrollSelect $w $element initial
} else {
tkScrollStartDrag $w $x $y
}
}
proc StrictMotif {} {
global tk_version tk_strictMotif _otReferenceSBD
set tk_strictMotif 1
if { $tk_version == 4.0 ||
![string compare [info body tkScrollButtonDown] \
[set _otReferenceSBD]] } {
if [string compare "" [info procs otTkScrollButtonDown]] {
rename tkScrollButtonDown {}
rename otTkScrollButtonDown tkScrollButtonDown
}
}
}
proc dbputs s {}
# Dummy to allow crunched obtcl processing normal obTcl-scripts
proc DOC { name rest } {}
proc DOC_get_list {} {}
crunch_skip begin
setIfNew db_debug 0
proc db_debug {} {
global db_debug
set db_debug [expr !$db_debug]
}
proc dbputs s {
global db_debug
if { $db_debug != 0 } {
puts stderr $s
}
}
#----------------------------------------------------------------------
# DOCS
setIfNew _uPriv_DOCS() ""
proc DOC_get_list {} {
global _uPriv_DOCS
return [array names _uPriv_DOCS]
}
proc DOC { name rest } {
global _uPriv_DOCS
set _uPriv_DOCS($name) $rest
}
proc PrDOCS {} {
global _uPriv_DOCS
set names [lsort [array names _uPriv_DOCS]]
foreach i $names {
puts "$_uPriv_DOCS($i)"
puts "----------------------------------------------------------------------"
}
}
proc GetDOCS {} {
global _uPriv_DOCS
set names [lsort [array names _uPriv_DOCS]]
set all ""
foreach i $names {
append all "$_uPriv_DOCS($i)"
append all "----------------------------------------------------------------------"
}
return $all
}
proc GetDOC name {
global _uPriv_DOCS
return $_uPriv_DOCS($name)
}
proc help args {
global _uPriv_DOCS
set names [lsort [array names _uPriv_DOCS "${args}*"]]
if { [llength $names] > 1 } {
puts "Select one of: "
set n 1
foreach i $names {
puts " ${n}) $i "
incr n 1
}
puts -nonewline ">> "
set answ [gets stdin]
append tmp [lindex $names [expr $answ-1]]
eval help $tmp
}
if { [llength $names] == 1 } {
eval set tmp $names
puts $_uPriv_DOCS($tmp)
}
if { [llength $names] < 1 } {
puts "No help on: $args"
}
}
#----------------------------------------------------------------------
DOC "Tcl-debugger" {
NAME
Tcldb - A Tcl debugger
SYNOPSIS
bp ?ID?
DESCRIPTION
A simple debugger for Tcl-script. Breakpoints are set by calling
`bp' from your Tcl-code. Selecting where to break is done by
string-matching.
USAGE
Use by putting calls to `bp' in the Tcl-code. If `ID' is specified,
it will be displayed when the breakpoint is reached.
Example of using two breakpoints with different IDs:
func say { a } {
bp say_A
puts "You said: $a!"
bp say_B
}
Call `bpOff' to disable all breakpoints, `bpOn' to enable all,
`bpOn <funcname>' to enable breakpoints in functions matching
<funcname>, and finally `bpID <ID>' to enable breakpoints
matching <ID>. Matching is done according to Tcl's `string match'
function.
When in the break-point handler, type "?" for help.
ACKNOWLEDGEMENTS
This simple debugger is based on Stephen Uhler's article
"Debugging Tcl Scripts" from the Oct-95 issue of Linux Journal.
}
proc bpGetHelp {} {
puts stderr \
"------------------------------- Tcldb help ------------------------------------
Set breakpoints by adding calls to `bp' in your Tcl-code. Example:
bp Func1 ;# bp followed by the identifier `Func1'
Commands available when in `bp':
+ Move down in call-stack
- Move up in call stack
. Show current proc name and params
v Show names of variables currently in scope
V Show names and values of variables currently in scope
l Show names of variables that are local (transient)
L Show names and values of variables that are local (transient)
g Show names of variables that are declared global
G Show names and values of variables that are declared global
t Show a call chain trace, terse mode
T Show a call chain trace, verbose mode
b Show body of current proc
c Continue execution
h,? Print this help
You can also enter any Tcl command (even multi-line) and it will be
executed in the currently selected stack frame.
Available at any time:
bpOff Turn off all breakpoints
bpOn Turn on all breakpoints
bpOn <match>
Enable breakpoints in functions with names matching <match>
bpID <match>
Enable breakpoints whose ID matches <match>
"
}
setIfNew _bp_ON 1
setIfNew _bp_ID *
proc bpOn { {func 1} } { global _bp_ON _bp_ID; set _bp_ID *; set _bp_ON $func }
proc bpID id { global _bp_ON _bp_ID; set _bp_ON 1; set _bp_ID $id }
proc bpOff {} { global _bp_ON; set _bp_ON 0 }
proc bp args {
global _bp_ON _bp_ID
if { $_bp_ON == 0 } { return }
set max [expr [info level] - 1]
set current $max
set fName [lindex [info level $current] 0]
if { "$_bp_ON" == "1" || "$fName" == "$_bp_ON" || \
("$_bp_ON" == "top" && $current == 0) || \
[string match $_bp_ON $fName] } {
if ![string match $_bp_ID $args] {
return
}
} else {
return
}
bpShow VERBOSE $current
while {1} {
if { "$args" != "" } { puts "bp: $args" }
puts -nonewline stderr "#${current}:"
gets stdin line
while {![info complete $line]} {
puts -nonewline "> "
append line "\n[gets stdin]"
}
switch -- $line {
"+" {if {$current < $max} {bpShow VERBOSE [incr current]}}
"-" {if {$current > 0} {bpShow VERBOSE [incr current -1]}}
"b" {bpBody $current}
"c" {puts stderr "Continuing"; return}
"v" {bpVisibleVars NAMES $current}
"V" {bpVisibleVars VALUES $current}
"l" {bpLocalVars NAMES $current}
"L" {bpLocalVars VALUES $current}
"g" {bpGlobalVars NAMES $current}
"G" {bpGlobalVars VALUES $current}
"t" {bpTraceCalls TERSE $current}
"T" {bpTraceCalls VERBOSE $current}
"." {bpShow VERBOSE $current}
"h" -
"?" {bpGetHelp}
default {
catch {uplevel #$current $line } result
puts stderr $result
}
}
}
}
proc bpPrVar { level mode name } {
upvar #$level $name var
if { $mode == "NAMES" } {
puts " $name"
return
}
if { [array exists var] == 1 } {
puts " Array ${name} :"
foreach i [array names var] {
puts " ${name}($i) = [set var($i)]"
}
} else {
if {[info exists var] != 1 } {
puts " $name : Declared but uninitialized"
} else {
puts " $name = $var"
}
}
}
proc bpBody current {
uplevel #$current {
catch {puts [info body [lindex [info level [info level]] 0]]}
}
}
proc bpVisibleVars { mode curr } {
puts "#$curr visible vars:"
foreach i [uplevel #$curr {lsort [info vars]}] {
bpPrVar $curr $mode $i
}
}
proc bpLocalVars { mode curr } {
puts "#$curr local vars:"
foreach i [uplevel #$curr {lsort [info locals]}] {
bpPrVar $curr $mode $i
}
}
proc bpGlobalVars { mode curr } {
puts "#$curr global visible vars:"
set Vis [uplevel #$curr {info vars}]
set Loc [uplevel #$curr {info locals}]
foreach i [lsort [listMinus $Vis $Loc]] {
bpPrVar 0 $mode $i
}
}
proc bpTraceCalls { mode curr } {
for {set i 1} {$i <= $curr} {incr i} {
bpShow $mode $i
}
}
proc bpShow { mode curr } {
if { $curr > 0 } {
set info [info level $curr]
set proc [lindex $info 0]
if {"$mode" == "TERSE"} {
puts stderr "$curr: $proc [lrange $info 1 end]"
return
}
puts stderr "$curr: Proc= $proc \
{[info args $proc]}"
set idx 0
foreach arg [info args $proc] {
if { "$arg" == "args" } {
puts stderr "\t$arg = [lrange $info [incr idx] end]"
break;
} else {
puts stderr "\t$arg = [lindex $info [incr idx]]"
}
}
} else {
puts stderr "Top level"
}
}
crunch_skip end

28
tcl/var.lis Normal file
View File

@ -0,0 +1,28 @@
OBTCL_LIBRARY
tcl_rcFileName
tcl_version
argv
argv0
tcl_interactive
obtcl_version
_obTcl_SysMethod
db_debug
auto_oldpath
auto_path
errorCode
errorInfo
_obTcl_Inherits
_obTcl_Classes
auto_index
env
_obTcl_Cached
_otReferenceSBD
tcl_patchLevel
_obTcl_NoClasses
_bp_ID
_bp_ON
_uPriv_DOCS
argc
_obTcl_Cnt
tcl_library
tcl_platform