>$CONFIG_STATUS || ac_write_fail=1
rm -f conf$$subs.awk
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
_ACAWK
cat >>"\$tmp/subs1.awk" <<_ACAWK &&
for (key in S) S_is_set[key] = 1
FS = ""
}
{
line = $ 0
nfields = split(line, field, "@")
substed = 0
len = length(field[1])
for (i = 2; i < nfields; i++) {
key = field[i]
keylen = length(key)
if (S_is_set[key]) {
value = S[key]
line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3)
len += length(value) + length(field[++i])
substed = 1
} else
len += 1 + keylen
}
print line
}
_ACAWK
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then
sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g"
else
cat
fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \
|| { { $as_echo "$as_me:$LINENO: error: could not setup config files machinery" >&5
$as_echo "$as_me: error: could not setup config files machinery" >&2;}
{ (exit 1); exit 1; }; }
_ACEOF
# VPATH may cause trouble with some makes, so we remove $(srcdir),
# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
# trailing colons and then remove the whole line if VPATH becomes empty
# (actually we leave an empty line to preserve line numbers).
if test "x$srcdir" = x.; then
ac_vpsub='/^[ ]*VPATH[ ]*=/{
s/:*\$(srcdir):*/:/
s/:*\${srcdir}:*/:/
s/:*@srcdir@:*/:/
s/^\([^=]*=[ ]*\):*/\1/
s/:*$//
s/^[^=]*=[ ]*$//
}'
fi
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
fi # test -n "$CONFIG_FILES"
eval set X " :F $CONFIG_FILES "
shift
for ac_tag
do
case $ac_tag in
:[FHLC]) ac_mode=$ac_tag; continue;;
esac
case $ac_mode$ac_tag in
:[FHL]*:*);;
:L* | :C*:*) { { $as_echo "$as_me:$LINENO: error: invalid tag $ac_tag" >&5
$as_echo "$as_me: error: invalid tag $ac_tag" >&2;}
{ (exit 1); exit 1; }; };;
:[FH]-) ac_tag=-:-;;
:[FH]*) ac_tag=$ac_tag:$ac_tag.in;;
esac
ac_save_IFS=$IFS
IFS=:
set x $ac_tag
IFS=$ac_save_IFS
shift
ac_file=$1
shift
case $ac_mode in
:L) ac_source=$1;;
:[FH])
ac_file_inputs=
for ac_f
do
case $ac_f in
-) ac_f="$tmp/stdin";;
*) # Look for the file first in the build tree, then in the source tree
# (if the path is not absolute). The absolute path cannot be DOS-style,
# because $ac_f cannot contain `:'.
test -f "$ac_f" ||
case $ac_f in
[\\/$]*) false;;
*) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
esac ||
{ { $as_echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5
$as_echo "$as_me: error: cannot find input file: $ac_f" >&2;}
{ (exit 1); exit 1; }; };;
esac
case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
ac_file_inputs="$ac_file_inputs '$ac_f'"
done
# Let's still pretend it is `configure' which instantiates (i.e., don't
# use $as_me), people would be surprised to read:
# /* config.h. Generated by config.status. */
configure_input='Generated from '`
$as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
`' by configure.'
if test x"$ac_file" != x-; then
configure_input="$ac_file. $configure_input"
{ $as_echo "$as_me:$LINENO: creating $ac_file" >&5
$as_echo "$as_me: creating $ac_file" >&6;}
fi
# Neutralize special characters interpreted by sed in replacement strings.
case $configure_input in #(
*\&* | *\|* | *\\* )
ac_sed_conf_input=`$as_echo "$configure_input" |
sed 's/[\\\\&|]/\\\\&/g'`;; #(
*) ac_sed_conf_input=$configure_input;;
esac
case $ac_tag in
*:-:* | *:-) cat >"$tmp/stdin" \
|| { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5
$as_echo "$as_me: error: could not create $ac_file" >&2;}
{ (exit 1); exit 1; }; } ;;
esac
;;
esac
ac_dir=`$as_dirname -- "$ac_file" ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$ac_file" : 'X\(//\)[^/]' \| \
X"$ac_file" : 'X\(//\)$' \| \
X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
$as_echo X"$ac_file" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
{ as_dir="$ac_dir"
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
*) as_qdir=$as_dir;;
esac
as_dirs="'$as_qdir' $as_dirs"
as_dir=`$as_dirname -- "$as_dir" ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_dir" : 'X\(//\)[^/]' \| \
X"$as_dir" : 'X\(//\)$' \| \
X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
$as_echo X"$as_dir" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'`
test -d "$as_dir" && break
done
test -z "$as_dirs" || eval "mkdir $as_dirs"
} || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5
$as_echo "$as_me: error: cannot create directory $as_dir" >&2;}
{ (exit 1); exit 1; }; }; }
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
case $ac_top_builddir_sub in
"") ac_top_builddir_sub=. ac_top_build_prefix= ;;
*) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
esac ;;
esac
ac_abs_top_builddir=$ac_pwd
ac_abs_builddir=$ac_pwd$ac_dir_suffix
# for backward compatibility:
ac_top_builddir=$ac_top_build_prefix
case $srcdir in
.) # We are building in place.
ac_srcdir=.
ac_top_srcdir=$ac_top_builddir_sub
ac_abs_top_srcdir=$ac_pwd ;;
[\\/]* | ?:[\\/]* ) # Absolute name.
ac_srcdir=$srcdir$ac_dir_suffix;
ac_top_srcdir=$srcdir
ac_abs_top_srcdir=$srcdir ;;
*) # Relative name.
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
case $ac_mode in
:F)
#
# CONFIG_FILE
#
case $INSTALL in
[\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;;
*) ac_INSTALL=$ac_top_build_prefix$INSTALL ;;
esac
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# If the template does not know about datarootdir, expand it.
# FIXME: This hack should be removed a few years after 2.60.
ac_datarootdir_hack=; ac_datarootdir_seen=
ac_sed_dataroot='
/datarootdir/ {
p
q
}
/@datadir@/p
/@docdir@/p
/@infodir@/p
/@localedir@/p
/@mandir@/p
'
case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in
*datarootdir*) ac_datarootdir_seen=yes;;
*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
{ $as_echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_datarootdir_hack='
s&@datadir@&$datadir&g
s&@docdir@&$docdir&g
s&@infodir@&$infodir&g
s&@localedir@&$localedir&g
s&@mandir@&$mandir&g
s&\\\${datarootdir}&$datarootdir&g' ;;
esac
_ACEOF
# Neutralize VPATH when `$srcdir' = `.'.
# Shell code in configure.ac might set extrasub.
# FIXME: do we really want to maintain this feature?
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_sed_extra="$ac_vpsub
$extrasub
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
:t
/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
s|@configure_input@|$ac_sed_conf_input|;t t
s&@top_builddir@&$ac_top_builddir_sub&;t t
s&@top_build_prefix@&$ac_top_build_prefix&;t t
s&@srcdir@&$ac_srcdir&;t t
s&@abs_srcdir@&$ac_abs_srcdir&;t t
s&@top_srcdir@&$ac_top_srcdir&;t t
s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t
s&@builddir@&$ac_builddir&;t t
s&@abs_builddir@&$ac_abs_builddir&;t t
s&@abs_top_builddir@&$ac_abs_top_builddir&;t t
s&@INSTALL@&$ac_INSTALL&;t t
$ac_datarootdir_hack
"
eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \
|| { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5
$as_echo "$as_me: error: could not create $ac_file" >&2;}
{ (exit 1); exit 1; }; }
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } &&
{ $as_echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined." >&5
$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined." >&2;}
rm -f "$tmp/stdin"
case $ac_file in
-) cat "$tmp/out" && rm -f "$tmp/out";;
*) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";;
esac \
|| { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5
$as_echo "$as_me: error: could not create $ac_file" >&2;}
{ (exit 1); exit 1; }; }
;;
esac
done # for ac_tag
{ (exit 0); exit 0; }
_ACEOF
chmod +x $CONFIG_STATUS
ac_clean_files=$ac_clean_files_save
test $ac_write_fail = 0 ||
{ { $as_echo "$as_me:$LINENO: error: write failure creating $CONFIG_STATUS" >&5
$as_echo "$as_me: error: write failure creating $CONFIG_STATUS" >&2;}
{ (exit 1); exit 1; }; }
# configure is writing to config.log, and then calls config.status.
# config.status does its own redirection, appending to config.log.
# Unfortunately, on DOS this fails, as config.log is still kept open
# by configure, so config.status won't be able to write to it; its
# output is simply discarded. So we exec the FD to /dev/null,
# effectively closing config.log, so it can be properly (re)opened and
# appended to by config.status. When coming back to configure, we
# need to make the FD available again.
if test "$no_create" != yes; then
ac_cs_success=:
ac_config_status_args=
test "$silent" = yes &&
ac_config_status_args="$ac_config_status_args --quiet"
exec 5>/dev/null
$SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
exec 5>>config.log
# Use ||, not &&, to avoid exiting from the if with $? = 1, which
# would make configure fail if this is the last instruction.
$ac_cs_success || { (exit 1); exit 1; }
fi
if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
{ $as_echo "$as_me:$LINENO: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
if test ! -d gen ; then
echo "creating ./gen"
mkdir gen
fi
if test ! -d bin ; then
echo "creating ./bin"
mkdir bin
fi
if test -f .devel -o "$enable_devel" = "yes" ; then
make depend
fi
otcl-1.14/configure.in 0000664 0000764 0000766 00000001217 11316705732 013600 0 ustar tomh nsnam AC_INIT(otcl.c)
#XXX
V_PROG="otclsh"
V_ALL="$V_PROG"
V_SHM="-DUSE_SHM"
builtin(include, ./conf/configure.in.fns)
builtin(include, ./conf/configure.in.head)
builtin(include, ./conf/configure.in.tcl)
builtin(include, ./conf/configure.in.tk)
builtin(include, ./conf/configure.in.x11)
# These must follow configure.in.head because they mess
# with $*.
AC_PROG_RANLIB
AC_PROG_INSTALL
builtin(include, ./conf/configure.in.dynamic)
#
# decide where to install the shared library
#
INST_OLIBSH="${prefix}/lib"
if test -d ${prefix}/shlib ; then
INST_OLIBSH="${prefix}/shlib"
fi
AC_SUBST(INST_OLIBSH)
NS_FNS_TAIL
builtin(include, ./conf/configure.in.tail)
otcl-1.14/doc/autoload.html 0000664 0000764 0000766 00000007130 06364020665 014534 0 ustar tomh nsnam
OTcl Autoloading (Version 0.96, Sept. 95)
OTcl Autoloading (Version 0.96, Sept. 95)
Overview
This reference page describes how arrange for OTcl classes and
their methods to be demand loaded. The mechanism extends the existing
Tcl autoloading scheme (with which you should be familiar) by using an
otcl_mkindex procedure to add entries to a tclIndex
file. It allows you to distribute classes across files without
additional concern for inheritance dependencies, as well as distribute
a class's methods across files.
Extending a tclIndex
To add OTcl load entries to a tclIndex, use the
otcl_mkindex procedure, defined during OTcl
initialization. For example, to update the tclIndex in the
current directory for the demand loading of classes, issue this shell
command:
echo "otcl_mkindex Class . *.tcl" | otclsh
otcl_mkindex takes the same directory and filename pattern
arguments as auto_mkindex, but also takes a list of classes
as its first argument. This list, the creator list, describes the kind
of objects that are candidates for demand loading. Usually this will
be Class, as above, to cause index entries to be generated for
classes. But it may also specify other classes if you are working with
meta-classes or need loading for regular objects.
otcl_mkindex appends the tclIndex file directly, and
returns a string describing the number of object and method index
entries it generated.
Like auto_mkindex, otcl_mkindex will only find
obvious candidates for demand loading. Both explicit creation, via the
create method, and implicit creation, via a method name that
is not a known method of Class, are considered in the
search. Objects (but not methods) must be created at the hard left
margin, and object and method names may not begin with "$".
How Loading Works
Autoloading of class and object commands is triggered via the
regular Tcl unknown mechanism, so that invoking a missing
class or object command will cause it to be loaded. In addition, OTcl
demand loads in two other ways.
First, unknown classes referenced as superclasses will be demand
loaded. This is triggered internally by the OTcl system. It means that
you can distribute classes across files without concern for sourcing
the files in inheritance order. It does not mean, however, that you
can make forward references to classes within a file, or mutually
recursive forward references across files.
Second, undefined methods may be demand loaded when they are
invoked. This is arranged for autoloaded classes by the OTcl object loader,
otcl_load. It means that you can distribute the definition of
a class and its methods over more than one file.
Method level loading works as follows. When a class or object is
being autoloaded by otcl_load, only those methods defined in
the main class file that is sourced will be fully loaded. Other
methods that are known to exist because of auto_index entries
are then filled with load stubs by using the auto option of
the proc and instproc methods. This guarantees that
if they are invoked, they will be loaded. Note that these method load
stubs must be installed, rather than relying on an unknown-style load
scheme, to cater for the shadowing of methods. Also, you can control
your own load policy by rewriting otcl_load.
otcl-1.14/doc/capi.html 0000664 0000764 0000766 00000020423 06364020665 013640 0 ustar tomh nsnam
OTcl C API (Version 0.96, September 95)
OTcl C API (Version 0.96, September 95)
Overview
This reference page describes the C application programmer
interface (API) for manipulating OTcl classes and objects. See otclAppInit.c for an example of a
Timer class written in C; Timer is included in the
shells if the symbol TESTCAPI is defined.
OTcl's C API is designed to complement the OTcl language in much
the same way that Tcl allows commands written in C to be added to an
interpreter. It is a minimal interface, suitable for migrating methods
to C for performance, or for manipulating complex (ie. non-string)
data structures. It is not a general package for binding C++ classes
and methods to Tcl commands.
See the tutorial for an introduction to
Tcl-level programming in OTcl.
Working with the C API
To access the C API, include otcl.h. This header defines
the externally visible interfaces, including the data structures
required to use them.
Object and Class Structures
Objects and classes are always manipulated through pointers to
opaque structures:
struct OTclObject;
struct OTclClass;
Actually, you can cast a class pointer to an object pointer (since
all classes are objects too) with no ill-effects, but you shouldn't
need to.
Two utility functions convert string names to object and class
pointers:
struct OTclObject*
OTclGetObject(Tcl_Interp* in, char* name);
struct OTclClass*
OTclGetClass(Tcl_Interp* in, char* name);
These functions are useful for getting handles to Object
and Class (the system provided classes) for use in creating
new classes, etc.
Two utility functions convert clientdata to object and class
pointers:
struct OTclObject*
OTclAsObject(Tcl_Interp* in, ClientData cd);
struct OTclClass*
OTclAsClass(Tcl_Interp* in, ClientData cd);
These functions are useful within method definitions when you have
installed the method to pass the current object via the clientdata;
see the section on Methods below. They perform a safe cast.
Initialization
OTcl is initialized for an interpreter with a standard module
initialization routine, called from an AppInit or through dynamic
loading.
int
Otcl_Init(Tcl_Interp* in);
Calls through the C API must be arranged to occur after OTcl
initialization.
Objects and Classes
Objects and classes can be created and destroyed from C as well as
Tcl without distinction. That is, classes created in C can be
destroyed from Tcl, and vice versa.
Creation
Objects and classes are created in an interpreter through class
pointers. Use a pointer to Class to create a generic class,
and a pointer to Object to create a generic object.
struct OTclObject*
OTclCreateObject(Tcl_Interp* in, char* name, struct OTclClass* cl);
struct OTclClass*
OTclCreateClass(Tcl_Interp* in, char* name, struct OTclClass* cl);
Both calls are conceptually equivalent to "cl create name"
in Tcl, but return either a pointer value or NULL to indicate
failure.
Deletion
Object and classes are deleted from an interpreter through their
pointers.
int
OTclDeleteObject(Tcl_Interp* in, struct OTclObject* obj);
int
OTclDeleteClass(Tcl_Interp* in, struct OTclClass* cl);
Both calls are conceptually equivalent to "obj destroy" or
"cl destroy", and return a Tcl call code.
Methods
Methods can be added and combined from C as well as from Tcl
without distinction. For example, C methods can be called from Tcl
transparently, and C methods can combine with Tcl methods
automatically.
Interface Conventions
In terms of interface, methods are analogous to Tcl commands, with
two important differences.
- The argc/argv array is passed in "expanded form", having three extra
arguments. argv[0] contains the name of the object, just as Tcl's
first argument contains the name of the invoking command. The next
three arguments contain values for extra method context variables:
self, class, and proc. The remaining
arguments (argv[4] and higher) contain the arguments passed to the
method.
- The clientData may be used to obtain a pointer to the object on
behalf of which the method is being invoked. If the method was created
with a clientData of NULL, then the dispatcher fills the
clientData with an object pointer. Otherwise, the dispatcher passes
the specified clientData. To convert the clientData to an object or
class pointer, you can use the typed casting functions
OTclAsObject and OTclAsClass.
Adding Methods
Two functions add methods to objects and classes, serving as the C
equivalent of the proc and instproc methods. The
types of the last three arguments are the same as for Tcl
commands.
void
OTclAddPMethod(struct OTclObject* obj, char* nm, Tcl_CmdProc* proc,
ClientData cd, Tcl_CmdDeleteProc* dp);
void
OTclAddIMethod(struct OTclClass* cl, char* nm, Tcl_CmdProc* proc,
ClientData cd, Tcl_CmdDeleteProc* dp);
Removing Methods
Two functions remove methods from objects and classes. If a
deleteProc callback was registered to clean up the method, then it is
passed the original non-NULL clientdata. If the original clientdata
was NULL, however, then a pointer to the object or class from which
the method is being removed is passed instead.
int
OTclRemovePMethod(struct OTclObject* obj, char* nm);
int
OTclRemoveIMethod(struct OTclClass* cl, char* nm);
Combining Methods
An executing methods can be automatically combined with the
next-most specific method with the following function. It is
equivalent to "obj next ..args..". argc/argv is passed in
expanded form, and should carry the context of the currently executing
method. It returns a Tcl return code.
int
OTclNextMethod(struct OTclObject* obj, Tcl_Interp* in, int argc, char*argv[]);
Instance Variables
Tcl accessible instance variables (stored as strings) can be
manipulated from C. In addition, objects can store a handle to private
auxilliary data.
*InstVar
OTclSetInstVar, OTclGetInstVar, and OTclUnsetInstVar mimic
Tcl_SetVar, Tcl_GetVar, and Tcl_UnsetVar for instance variables. The
return values and codes for parameters such as flgs match Tcl
conventions.
char*
OTclSetInstVar(struct OTclObject* obj, Tcl_Interp* in,
char* name, char* value, int flgs);
char*
OTclGetInstVar(struct OTclObject* obj, Tcl_Interp* in,
char* name, int flgs);
int
OTclUnsetInstVar(struct OTclObject* obj, Tcl_Interp* in,
char* name, int flgs);
Auxilliary Data
OTclSetObjectData, OTclGetObjectData and OTclUnsetObjectData
manipulate private object clientdata, such as a pointer to an
auxilliary data region. ObjectData is a per object and per class
resource to allow for inheritance. Typically, it is manipulated on
behalf of the invoking object in each class method by using the
directly associated class. In this manner specializations of a class
may each store their own ObjectData.
int
OTclGetObjectData(struct OTclObject* obj,struct OTclClass* cl,
ClientData* data);
void
OTclSetObjectData(struct OTclObject* obj, struct OTclClass* cl,
ClientData data);
int
OTclUnsetObjectData(struct OTclObject* obj, struct OTclClass* cl);
Get fills the data value passed by reference, and returns
0 or 1 depending on whether the ObjectData
existed. If it didn't, then data is filled with NULL. Set
overwrites existing ObjectData without error. Unset returns 0
or 1 depending on whether the ObjectData existed.
otcl-1.14/doc/class.html 0000664 0000764 0000766 00000032252 06364020665 014034 0 ustar tomh nsnam
OTcl Classes (Version 0.96, September 95)
OTcl Classes (Version 0.96, September 95)
Overview
This reference page describes the functionality provided for all
classes by methods on the Class class. See the tutorial for an introduction to programming
in OTcl, and the C API page for details of
manipulating classes from C.
Classes in OTcl are a special kind of object used mainly for
inheritance. By convention, they are named with mixed case to
distinguish them from regular objects. They inherit all the abilities
of regular objects from Object, and add more. The inherited
behavior includes method lookup, dispatch, and combination, and
initialization syntax. See Objects in OTcl
to understand these abilities of regular objects.
Classes are created through meta-class objects, either implicitly
with a widget command syntax, or explicitly by calling a creation
method. Generic classes may be created with the Class
class. By default, they will inherit from Object. The classes
Bagel, and SuperBagel, which inherits from Bagel, may be defined as
follows. See the create instproc for a description of the
overall creation process and how to customize it.
% Class Bagel
Bagel
% Bagel info class
Class
% Bagel info superclass
Object
% Class SuperBagel -superclass Bagel
SuperBagel
% SuperBagel info class
Class
% SuperBagel info superclass
Bagel
Class is the repository for the behavior common to all
classes. It includes methods for defining new methods for use by
instances, initializing and destroying classes, specifying their
superclasses, querying them, and so forth. The remainder of this
reference page describes these methods. Their functionality can be
customized for particular meta-classes or classes by using the
standard inheritance mechanisms, or changed directly for all classes
by rewriting the methods on Class in Tcl or C.
Alloc
The alloc proc is used to allocate a fresh class object
that is an instance of class Class and has superclass
Object. It is normally called by the system as part of class
creation, but may be called by the user.
The system create instproc on Class expects all
alloc procs to take the name of the object to allocate, and a
list of arguments. It expects them to allocate the object, install it
in the interpreter, and return the list of unprocessed arguments. For
the case of the Class alloc proc, no additional arguments are
processed, and so they are all returned.
To customize class creation, write an init instproc, not
an alloc proc. New alloc procs will typically be
written in C to allocate structurally different types of object.
% Class alloc foo bar baz
bar baz
% foo info class
Class
% foo info procs
% foo info vars
Create
The create instproc provides a mechanism for classes to
create other classes and objects. It is invoked by the default
unknown instproc if no matching method name can be found, and
so may be ellided to yield the familiar widget-like creation
syntax.
create takes the name of a class or object to create plus
extra initialization argument pairs, and returns the name of the
object or class created. It effectively calls an alloc proc
to allocate the object, then dispatches the init method with
the initialization arguments to initialize the object. Recall that the
base init method on Object interprets these
arguments as option key and option value pairs, evaluating each pair
in turn. The following three sequences are essentially equivalent
(except in terms of return value).
% Class create Bagel
Bagel
% Class Bagel
Bagel
% Class alloc Bagel
% Bagel init
The alloc proc that is called by create is determined by
the class object on which it is called. create first looks
for an alloc proc on this class object, then on its
superclasses according to the precedence ordering. The result is that
calling create on Class (or a class specialized from
it) will create a new class, whereas calling create on
Object (or a class specialized from it) will create a new
object.
Classes may customize the initialization of their instances by
defining an init instproc. If the option key and option value
creation syntax is still desired, this init instproc should
combine its behavior with the init instproc on
Object by using the next instproc, as shown
below. For example, the class Bagel may require an instance variable
called bites to be initialized to a default value of 12, in addition
to regular option key and option value initialization. This is
accomplished as follows. (The use of eval is simply to flatten the
list of arguments contained in args.) Similarly, an init
instproc on Class may be used to customize the initialization
of all classes.
% Class Bagel
Bagel
% Bagel instproc init {args} {
$self set bites 12
eval $self next $args
}
% Bagel instproc flavor {f} {
$self set flavor $f
}
% Bagel abagel -flavor sesame
abagel
% abagel set bites
12
% abagel set flavor
sesame
Alternatively, the standard inheritance mechanisms may be used to
provide some or all classes with their own create proc,
allowing complete control over the creation process. For reference,
the default create instproc on Class is conceptually
defined as follows.
Class instproc create {obj args} {
set h [$self info heritage]
foreach i [concat $self $h] {
if {[$i info commands alloc] != {}} then {
set args [eval [list $i] alloc [list $obj] $args]
$obj class $self
eval [list $obj] init $args
return $obj
}
}
error {No reachable alloc}
}
Info
The info instproc is used to query the class and retrieve
information about its current state. It mirrors the Tcl info command,
and has the following options in addition to those of the Object
info instproc.
- superclass returns the superclass list of the
object. With an additional argument that is the name of a class, it
returns 1 if that class is a direct or indirect superclass of the
class, and 0 otherwise.
- subclass returns the subclass list of the object. With an
additional argument that is the name of a class, it returns 1 if that
class is a direct or indirect subclass of the class, and 0 otherwise.
- heritage returns the inheritance precedence list (as
described for the superclass instproc). An additional
argument is taken to be a string match pattern which filters the
result list.
- instances returns a list of the instance objects of the
class. An additional argument is taken to be a string match pattern
which filters the result list.
- instprocs returns a list of the names of instproc methods
defined on the class. An additional argument is taken to be a string
match pattern which filters the result list.
- instcommands returns a list of the names of both Tcl and
C instproc methods defined on the class. An additional argument is
taken to be a string match pattern which filters the result list.
- instargs is used to query the argument list of a Tcl
instproc method. It functions in the same manner as the Tcl info args
command.
- instbody is used to query the body of a Tcl instproc
method. It functions in the same manner as the Tcl info body command.
- instdefault is used to query the default value of an
argument of a Tcl instproc method. It functions in the same manner as
the Tcl info default command.
These options can recover most information about the state of a
class. As an example, the following instproc returns a list of all
direct and indirect instances of a class.
Class instproc instances {} {
set il {}
foreach i [Class info instances] {
if {[$self info subclass $i]} then {
eval lappend il [$i info instances]
}
}
return $il
}
Instproc
The instproc instproc is used to install instproc methods
on a class, for use by that class's direct and indirect instances. Use
instproc to share and inherit behaviors. With particular
argument forms, instproc can also remove instproc methods
from a class, or specify an autoload script for demand loading of the
instproc method.
The arguments and body of an instproc method are of the same form
as a Tcl procedure, with two exceptions. If both args and body are
empty, then an existing instproc method with the specified name is
removed from the class. If args is {auto}, then the body is
interpreted as an autoload script in the same manner as described
under the proc instproc in OTcl
Objects. See OTcl Autoloading for a
higher level demand loading scheme.
The following example demonstrates defining instprocs, using them
on behalf of and object, and combining their functionality with
next.
% Class Bagel
Bagel
% Class SuperBagel -superclass Bagel
SuperBagel
% Bagel instproc taste {} {
puts yum!
}
% SuperBagel instproc taste {} {
$self next
puts YUM!
}
% SuperBagel abagel
abagel
% abagel taste
yum!
YUM!
The environment in effect when an instproc is being executed is the
same as when a proc is being executed, and is described under the
proc instproc in OTcl Objects. The
special variable class may be used for a variety of tasks,
such as to access shared variables stored on the class object. For
example, the default size of a bagel in bites may be stored on the
Bagel class to be accessed during the init instproc as
follows.
% Class Bagel
Bagel
% Bagel set bites 12
12
% Bagel instproc init {args} {
$class instvar bites
$self set size $bites
eval $self next $args
}
% Bagel abagel
abagel
% abagel set size
12
% Bagel set bites 7
7
% Bagel abagel
abagel
% abagel set size
7
Superclass
The superclass instproc is used to change the superclasses
from which a class directly inherits behavior. It takes one argument
that is a list of superclasses and returns the empty string. The order
of the superclass list determines the order of inheritance. Multiple
inheritance is supported.
The superclasses must be in precedence order (from most specialized
to least specialized) if they are related, and the resulting
superclass relation must be cycle-free. An error is returned and the
superclass graph is unchanged if either of these conditions are
unmet.
The linear precedence order in which superclasses are searched for
instprocs is constrained according to each local superclass list. It
is guaranteed that if A inherits from B and C, then A will behave like
a B before it behaves like a C, and so forth for B and C and their
superclasses. The algorithm used to generate this ordering is an
unspecified CLOS-like topological sort of the inheritance graph. (This
is all you need to know. Multiple inheritance is best thought of in
terms of local orderings. If you are relying on subtleties of the
global ordering, then you are asking for trouble.)
The heritage option of the info instproc may be
used to discover the precedence order, and hence the path that the
next instproc will use when instructed to combine
methods.
Unknown
The unknown instproc for classes is used to implement
implicit creation of objects. It is invoked when no matching method is
found, and interprets the method name as the name of an object to be
created with create, thus allowing a widget-like creation
syntax.
See the entry for unknown in OTcl
Objects for a general description of the unknown method
mechanism.
The unknown instproc on Class is conceptually
defined as follows. It you do not want implicit creation, then
redefine or remove the default method with the instproc
method.
Class instproc unknown {m args} {
if {$m == {create}} then {
error "$self: unable to dispatch $m"
}
eval [list $self] create [list $m] $args
}
otcl-1.14/doc/object.html 0000664 0000764 0000766 00000044242 06364020665 014177 0 ustar tomh nsnam
OTcl Objects (Version 0.96, September 95)
OTcl Objects (Version 0.96, September 95)
Overview
This reference page describes the functionality provided for all
objects by methods on the Object class. See the tutorial for an introduction to programming
in OTcl, and the C API page for details of
manipulating objects from C.
Objects in OTcl are instances of classes. They are created through
class objects either implicitly, with a widget command syntax, or
explicitly, by calling a creation method. After defining a class Bagel
with instprocs flavor and size below, a new bagel object called abagel
is created and initialized by calling its flavor and size
instprocs. The creation process may be customized for any class. See
OTcl Classes for details.
% Class Bagel
Bagel
% Bagel instproc flavor {args} {
$self set flavors $args
}
% Bagel instproc size {s} {
$self set bites $s
}
% Bagel abagel -flavor Sesame -size 12
abagel
% abagel info vars
flavors bites
% abagel set flavors
Sesame
% abagel set bites
12
Once created, objects are manipulated through methods placed on
them directly, and methods they inherit from their class object and
its superclasses. The former methods are called procs, the latter
instprocs. As in Tcl, there is no distinction between system provided
methods (such as info and set) and user provided methods (such as
flavor and size). Procs take precedence over instprocs, and the order
of inheritance for instprocs is discussed under the
superclass instproc in OTcl
Classes.
All methods are called through the object by using a widget-like
syntax. The method name is used as the first argument, with the
method's arguments as subsequent arguments. The most specific method
that is found either on the object or in its inheritance ordering will
be invoked. The flavor and size methods are called on bagels as
follows.
% abagel flavor Sesame Onion
Sesame Onion
% abagel size 10
10
% abagel set flavors
Sesame Onion
% abagel set bites
10
Generic objects may be created with the Object
class. Object is the repository for the behavior common to
all objects. It includes methods for defining new methods and instance
variables, initializing and destroying objects, querying them, and so
forth. The remainder of this reference page describes these
methods. Their functionality can be customized for particular classes
or objects by using the standard inheritance mechanisms, or changed
directly for all objects by rewriting the methods on Object
in Tcl or C.
Alloc
The alloc proc is used to allocate a fresh object that is
an instance of class Object. It is normally called by the system as
part of object creation, but may be called by the user.
The system create instproc on Class expects all
alloc procs to take the name of the object to allocate, and a
list of arguments. It expects them to allocate the object, install it
in the interpreter, and return the list of unprocessed arguments. For
the case of the Object alloc proc, no additional arguments
are processed, and so they are all returned.
To customize object creation, write an init instproc, not
an alloc proc. New alloc procs will typically be
written in C to allocate structurally different types of object.
% Object alloc foo bar baz
bar baz
% foo info class
Object
% foo info procs
% foo info vars
Array
The array instproc returns information about array
instance variables. It mirrors the Tcl array command. See the Tcl
array command for options. Array is conceptually defined as
follows.
Object instproc array {opt ary args} {
$self instvar $ary
eval array [list $opt] [list $ary] $args
}
Class
The class instproc changes the class of an object, where
the notion of class is expressed using the names of class objects. The
class of an object may be changed at any time, with a run-time type
checking system enforcing safety as subsequent methods are
executed.
% Class Bagel
Bagel
% Bagel instproc what {} { $self info class }
% Class NewBagel
NewBagel
% Bagel abagel
abagel
% abagel info class
Bagel
% abagel what
Bagel
% abagel set foo bar
bar
% abagel info vars
foo
% abagel class NewBagel
% abagel info class
NewBagel
% abagel what
abagel: unable to dispatch method what
% abagel info vars
foo
Changing the class of an object does not change the instance
variables and procs it contains, only the instprocs accessible through
it. This may be customized with the standard inheritance
mechanisms.
Destroy
The destroy instproc tears down the object, removes it
from the interpreter, and releases its memory. Unset traces on
instance varaibles are triggered in the process. It takes no
arguments, and returns the empty string.
User defined teardown code may be added to objects and classes with
the standard inheritance mechanisms.
If the object is also a class, then its instances are destroyed,
and classes that depend on it as superclasses have it removed from
their superclass list.
There is only one user visible destroy method for both
objects and classes. The real teardown work is performed below the
method level, through deletion callbacks issued by the Tcl
interpreter. This ensures that cleanup will be invoked if the command
corresponding to the object is deleted from the interpreter in any
manner, including calls to Tcl_DeleteCommand and renaming the
command to {}.
% Class Bagel
Bagel
% Bagel instproc destroy {} {
puts "zap!"
$self next
}
% Bagel abagel
abagel
% abagel proc destroy {} {
puts "poof!"
$self next
}
% abagel destroy
poof!
zap!
% info commands abagel
While cleanup (including user defined teardown) occurs even if the
command is renamed to {}, calling the destroy method is the
preferable way to dispose of an object, since error codes cannot be
returned if Tcl_DeleteCommand is triggered directly.
Info
The info instproc is used to query the object and retrieve
information about its current state. It mirrors the Tcl info command,
and has the following options.
- class returns the class of the object. With an additional
argument that is the name of a class, it returns 1 if the object is a
direct or indirect instance of that class, and 0 otherwise.
- procs returns a list of the names of proc methods defined
on the object. An additional argument is taken to be a string match
pattern which filters the result list.
- commands returns a list of the names of both Tcl and C
proc methods defined on the object. An additional argument is taken to
be a string match pattern which filters the result list.
- args is used to query the argument list of a Tcl proc
method. It functions in the same manner as the Tcl info args command.
- body is used to query the body of a Tcl proc method. It
functions in the same manner as the Tcl info body command.
- default is used to query the default value of an argument
of a Tcl proc method. It functions in the same manner as the Tcl info
default command.
- vars returns a list of the names of instance variables
defined on the object. An additional argument is taken to be a string
match pattern which filters the result list.
In conjunction with other methods such as array and
set, these options can recover most information about the
state of an object. As an example, the following proc reverse
engineers Tcl procs. This is its output when run on itself.
Object proc retrieve {p} {
set txt [list $self proc $p]
set al [$self info args $p]
set dft {}
for {set i 0} {$i < [llength $al]} {incr i} {
set av [lindex $al $i]
if {[$self info default $p $av dft]} then {
set al [lreplace $al $i $i [list $av $dft]]
}
}
lappend txt $al
lappend txt [$self info body $p]
return $txt
}
Init
The init instproc is used to initialize a freshly
allocated object that is a direct or indirect instance of the class
Object. It is normally called by the system (perhaps from more
specialized init instprocs) as part of object creation, but
may be called by the user.
init interprets its arguments as pairs of option keys and
option values. Each option key should be the name of a valid method
for the object, preceded by a dash. The method should take one
argument. For each option key and option value pair, init calls the
method on the object, with the option value as its argument. It
returns the empty string.
To customize object creation, write an init instproc for a
class, not an alloc proc. If the option key and option value
creation syntax is still desired, then call the Object init
instproc by using next. This is discussed in the
create instproc in OTcl Classes.
% Class Bagel
Bagel
% foreach i {1 2 3 4} {
Bagel instproc $i {v} {puts $v}
}
% Bagel abagel
abagel
% abagel init -1 one -2 two -3 three -4 four!
one
two
three
four!
init is conceptually equivalent to the following.
Object instproc init {args} {
if {[llength $args]%2 != 0} then {
error {uneven number of arguments}
}
while {$args != {}} {
set key [lindex $args 0]
if {[string match {-*} $key]} then {
set key [string range $key 1 end]
}
set val [lindex $args 1]
if {[catch {$self $key $val} msg]!=0} then {
set opt [list $self $key $val]
error "$msg during $opt"
}
set args [lrange $args 2 end]
}
return {}
}
Instvar
The instvar instproc is used within the body of a method
to map instance variables to local variables. It mirrors the Tcl upvar
command (and is implemented in terms of it).
Multiple instance variables may be declared at once. The instance
variables may be scalars or arrays (but see below), and need not be
previously defined. By default the local alias for an instance
variable is the same as the name of the instance variable. Renaming in
the style of upvar is specified using a two element lists in the
declaration. This departs from Tcl upvar syntax, but allows a simple
declaration for the majority of cases, with access to the full
functionality of upvar when necessary.
% Class Bagel; Bagel abagel
abagel
% abagel set flavor sesame
sesame
% abagel set size {12 bites}
12 bites
% abagel proc taste {} {
$self instvar flavor
return $flavor
}
% abagel taste
sesame
% abagel proc query {} {
$self instvar size {flavor f}
return "$f, $size"
}
% abagel query
sesame, 12 bites
Note that the renaming syntax is required to access individual
array elements directly. This is because Tcl's upvar does not allow a
remote array element to be locally accessed as an array
element. Instead, it is often easier to map the whole array for
access.
Next
The next instproc is used within the body of a method to
call the next-most shadowed method. It is used to combine inherited
methods without depending on explicitly knowing their location. For
example, it is typically used as part of init
instprocs for classes to form an aggregate initialization
method. next is analogous to call-next-method in CLOS. See
the superclass instproc in OTcl
Classes for a discussion of the order of inheritance.
next searches for an instproc method with the same name as
the current method. It begins its search after the position in the
precedence ordering where the current method was found, if the current
method is an instproc, or from the beginning of the precedence
ordering of the object's class, if the current method is a proc. The
position information between calls to next is recovered from
the class variable. If no next method is found, then an empty
string is returned without error. Otherwise, the next method is called
with the arguments that were passed to next.
Proc
The proc instproc is used to install proc methods on an
object, for sole use by that object. Use proc to customize
individual objects beyond the functionality provided by via their
class, not for inheritance. With particular argument forms,
proc can also remove proc methods from an object, or specify
an autoload script for demand loading of the proc method.
The arguments and body of a proc method are of the same form as a
Tcl procedure, with two exceptions. If both args and body are empty,
then an existing proc method with the specified name is removed from
the object. If args is {auto}, then the body is interpreted
as an autoload script as described below.
Within the body of the proc and instproc methods, three special
variables are defined. These variables are for reading only. Instance
variables may be accessed as local variables by using the
instvar instproc.
- self is bound to the name of the object on whose behalf
the method is executing. It may be used to invoke further methods. It
is the equivalent of this in C++.
- class is bound to the name of the class object on which
the method that is executing is defined, if the method is an instproc,
and the empty string if the method is a proc. It does not contain the
class of the object, which may be retrieved with the info
instproc.
- proc is bound to the name of the proc or instproc method
that is executing.
% Class Bagel; Bagel abagel
abagel
% abagel info procs
% abagel proc flavor {f} {
$self instvar flavor
set flavor $f
return "called $self $proc $f"
}
% abagel info procs
flavor
% abagel flavor sesame
called abagel flavor sesame
Proc and instproc methods may also be declared to autoload. This
function is usually accessed through the higher level demand loading
scheme described in OTcl Autoloading.
If the argument list is {auto}, then the body is taken to
be a script for demand loading of the method. When the method is
invoked, the script will be executed (and should cause the real method
to be loaded) and then the method will be restarted. While the stub is
waiting to load the method body, the method is recognized as a
proc by the info method, but cannot be queried for
its body or arguments.
% set tmp [open "tmp" w]
file3
% puts $tmp {abagel proc bagel {} { return "bagel" }}
% close $tmp
% Class Bagel; Bagel abagel
abagel
% abagel proc bagel auto {
puts -nonewline "loading... "
source tmp
}
% abagel bagel
loading... bagel
% abagel bagel
bagel
Set
The set instproc is used to place instance variables on an
object as well as to access them. It mirrors the Tcl set command (and
is implemented in terms of it). It returns the value of the instance
variable. Instance variables may be scalar or array variables. They
are stored in separate slots than methods, and so are distinct from
methods with the same name.
% Class Bagel; Bagel abagel
abagel
% abagel info vars
% abagel set avar aval
aval
% abagel set avar
aval
% abagel set foo(bar) baz
baz
% abagel set foo(bar)
baz
% abagel info vars
foo avar
Unknown
The unknown method, if defined for an object, is invoked
by the system when no matching method can be found for regular
dispatch. By default, it is not defined for Object, but
exists as a hook for user defined handlers, such as abbreviations,
load monitoring, error reporting, etc. An unknown instproc
that implements implicit creation is defined for Class; see
its reference page.
Like Tcl's unknown proc, the unknown method
receives as its arguments the name of the method that could not be
invoked, along with that method's arguments. The result it returns is
returned as the overall result of the call.
As an example, the following unknown instproc implements
abbreviations and verbose error messsages.
% Object instproc unknown {m args} {
foreach i [$self info commands] {
lappend meth($i) {}
}
set cl [$self info class]
foreach i [concat $cl [$cl info heritage]] {
foreach j [$i info instcommands] {
lappend meth($j) {}
}
}
set abbrev [array names meth "$m*"]
switch -exact [llength $abbrev] {
0 { error "$self: invalid method \"$m\": [lsort [array names meth]]" }
1 { eval [list $self] $abbrev $args }
default { error "$self: ambiguous method \"$m\": [lsort $abbrev]" }
}
}
% Object obj
obj
% obj f
obj: invalid method "f": array class destroy info init instvar next proc set unknown unset
% obj i
obj: ambiguous method "i": info init instvar
% obj d
Unset
The unset instproc is used to remove instance variables
from an object. It mirrors the Tcl unset command (and is implemented
in terms of it).
% Class Bagel; Bagel abagel
abagel
% abagel set foo bar
bar
% abagel info vars
foo
% abagel unset foo
% abagel info vars
otcl-1.14/doc/tutorial.html 0000664 0000764 0000766 00000034073 06364020665 014575 0 ustar tomh nsnam
OTcl Tutorial (Version 0.96, September 95)
OTcl Tutorial (Version 0.96, September 95)
This tutorial is intended to start you programming in OTcl quickly,
assuming you are already familiar with object-oriented programming. It
omits many details of the language that can be found in the reference
pages Objects in OTcl and Classes in OTcl. It also doesn't mention the C API or describe how to autoload classes.
Comparison with C++
To the C++ programmer, object-oriented programming in OTcl may feel
unfamiliar at first. Here are some of the differences to help you
orient yourself.
- Instead of a single class declaration in C++, write multiple
definitions in OTcl. Each method definition (with instproc)
adds a method to a class. Each instance variable definition (with
set or via instvar in a method body) adds an
instance variable to an object.
- Instead of a constructor in C++, write an init instproc
in OTcl. Instead of a destructor in C++, write a destroy
instproc in OTcl. Unlike constructors and destructors, init and
destroy methods do not combine with base classes automatically. They
should be combined explicitly with next.
- Unlike C++, OTcl methods are always called through the object. The
name self, which is equivalent to this in C++, may
be used inside method bodies. Unlike C++, OTcl methods are always
virtual.
- Instead of calling shadowed methods by naming the method
explicitly as in C++, call them with next. next
searches further up the inheritance graph to find shadowed methods
automatically. It allows methods to be combined without naming
dependencies.
- Avoid using static methods and variables, since there is no exact
analogue in OTcl. Place shared variables on the class object and
access them from methods by using $class. This behavior will
then be inherited. For inherited methods on classes, program with
meta-classes. If inheritance is not needed, use proc methods
on the class object.
Programming in OTcl
Suppose we need to work with many bagels in our application. We
might start by creating a Bagel class.
% Class Bagel
Bagel
We can now create bagels and keep track of them using the
info method.
% Bagel abagel
abagel
% abagel info class
Bagel
% Bagel info instances
abagel
Of course, bagels don't do much yet. They should remember whether
they've been toasted. We can create and access an instance variable
with the set method. All instance variables are public in the
sense of C++. Again, the info method helps us keep track of
things.
% abagel set toasted 0
0
% abagel info vars
toasted
% abagel set toasted
0
But we really want them to begin in an untoasted state to start
with. We can achieve this by adding an init instproc to the
Bagel class. Generally, whenever you want newly created
objects to be initialized, you'll write an init instproc for
their class.
% Bagel instproc init {args} {
$self set toasted 0
eval $self next $args
}
% Bagel bagel2
bagel2
% bagel2 info vars
toasted
% bagel2 set toasted
0
There are several things going on here. As part of creating
objects, the system arranges for init to be called on them
just after they are allocated. The instproc method added a
method to the Bagel class for use by its instances. Since it
is called init, the system found it and called it when a new bagel was
created.
The body of the init instproc also has some interesting
details. The call to next is typical for init methods, and
has to do with combining all inherited init methods into an aggregate
init. We'll discuss it more later. The variable called self
is set when a method is invoked, and contains the name of the object
on behalf of which it is running, or bagel2 in this
case. It's used to reach further methods on the object or inherited
through the object's class, and is like this in C++. There
are also two other special variables that you may be interested in,
proc and class.
Our bagels now remember whether they've been toasted, except for
the first one that was created before we wrote an init. Let's destroy
it and start again.
% Bagel info instances
bagel2 abagel
% abagel destroy
% Bagel info instances
bagel2
% Bagel abagel
abagel
Now we're ready to add a method to bagels so that we can toast
them. Methods stored on classes for use by their instances are called
instprocs. They have an argument list and body like regular Tcl
procs. Here's the toast instproc.
% Bagel instproc toast {} {
$self instvar toasted
incr toasted
if {$toasted>1} then {
error "something's burning!"
}
return {}
}
% Bagel info instprocs
init toast
Aside from setting the toasted variable, the body of the
toast instproc demonstrates the instvar method. It is used to
declare instance variables and bring them into local scope. The
instance variable toasted, previously initialized with the
set method, can now be manipulated through the local variable
toasted.
We invoke the toast instproc on bagels in the same way we use the
info and destroy instprocs that were provided by the
system. That is, there is no distinction between user and system
methods.
% abagel toast
% abagel toast
something's burning!
Now we can add spreads to the bagels and start tasting them. If we
have bagels that aren't topped, as well as bagels that are, we may
want to make toppable bagels a separate class. Let explore inheritance
with these two classes, starting by making a new class
SpreadableBagel that inherits from Bagel.
% Class SpreadableBagel -superclass Bagel
SpreadableBagel
% SpreadableBagel info superclass
Bagel
% SpreadableBagel info heritage
Bagel Object
More options on the info method let us determine that
SpreadableBagel does indeed inherit from Bagel, and
further that it also inherits from Object. Object
embodies the basic functionality of all objects, from which new
classes inherit by default. Thus Bagel inherits from
Object directly (we didn't tell the system otherwise) while
SpreadableBagel inherits from Object indirectly via
Bagel.
The creation syntax, with its "-superclass", requires more
explanation. First, you might be wondering why all methods except
create are called by using their name after the object name,
as the second argument. The answer is that create is called
as part of the system's unknown mechanism if no other method can be
found. This is done to provide the familiar widget-like creation
syntax, but you may call create explicitly if you prefer.
Second, as part of object initialization, each pair of arguments is
interpreted as a (dash-preceded) procedure name to invoke on the
object with a corresponding argument. This initialization
functionality is provided by the init instproc on the
Object class, and is why the Bagel init
instproc calls next. The following two code snippets are
equivalent (except in terms of return value). The shorthand it what
you use most of the time, the longhand explains the operation of the
shorthand.
% Class SpreadableBagel
SpreadableBagel
% SpreadableBagel superclass Bagel
% Class create SpreadableBagel
SpreadableBagel
% SpreadableBagel superclass Bagel
% Class SpreadableBagel -superclass Bagel
SpreadableBagel
Once you understand this relationship, you will realize that there
is nothing special about object creation. For example, you can add
other options, such as one specifying the size of a bagel in
bites.
% Bagel instproc size {n} {
$self set bites $n
}
% SpreadableBagel abagel -size 12
abagel
% abagel set bites
12
We need to add methods to spread toppings to
SpreadableBagel, along with a list of current toppings. If we
wish to always start with an empty list of toppings, we will also need
an init instproc.
% SpreadableBagel instproc init {args} {
$self set toppings {}
eval $self next $args
}
% SpreadableBagel instproc spread {args} {
$self instvar toppings
set toppings [concat $toppings $args]
return $toppings
}
Now the use of next in the init method can be
further explained. SpreadableBagels are also bagels, and need
their toasted variable initialized to zero. The call to
next arranges for the next method up the inheritance tree to
be found and invoked. It provides functionality similar to
call-next-method in CLOS.
In this case, the init instproc on the Bagel
class is found and invoked. Eval is being used only to flatten the
argument list in args. When next is called again in
Bagels init instproc, the init method on
Object is found and invoked. It interprets its arguments as
pairs of procedure name and argument values, calling each in turn, and
providing the option initialization functionality of all
objects. Forgetting to call next in an init instproc
would result in no option initializations.
Let's add a taste instproc to bagels, splitting its functionality
between the two classes and combining it with next.
% Bagel instproc taste {} {
$self instvar toasted
if {$toasted == 0} then {
return raw!
} elseif {$toasted == 1} then {
return toasty
} else {
return burnt!
}
}
% SpreadableBagel instproc taste {} {
$self instvar toppings
set t [$self next]
foreach i $toppings {
lappend t $i
}
return $t
}
% SpreadableBagel abagel
abagel
% abagel toast
% abagel spread jam
jam
% abagel taste
toasty jam
Of course, along come sesame, onion, poppy, and a host of other
bagels, requiring us to expand our scheme. We could keep track of
flavor with an instance variable, but this may not be
appropriate. Flavor is an innate property of the bagels, and one that
can affect other behavior - you wouldn't put jam on an onion bagel,
would you? Instead of making a class heirarchy, let's use multiple
inheritance to make the flavor classes mixins that add a their taste
independent trait to bagels or whatever other food they are mixed
with.
% Class Sesame
Sesame
% Sesame instproc taste {} {
concat [$self next] "sesame"
}
% Class Onion
Onion
% Onion instproc taste {} {
concat [$self next] "onion"
}
% Class Poppy
Poppy
% Poppy instproc taste {} {
concat [$self next] "poppy"
}
Well, they don't appear to do much, but the use of next
allows them to be freely mixed.
% Class SesameOnionBagel -superclass {Sesame Onion SpreadableBagel}
SesameOnionBagel
% SesameOnionBagel abagel -spread butter
% abagel taste
raw! butter onion sesame
For multiple inheritance, the system determines a linear
inheritance ordering that respects all of the local superclass
orderings. You can examine this ordering with an info
option. next follows this ordering when it combines
behavior.
% SesameOnionBagel info heritage
Sesame Onion SpreadableBagel Bagel Object
We can also combine our mixins with other classes, classes that
need have nothing to do with bagels, leading to a family of chips.
% Class Chips
Chips
% Chips instproc taste {} {
return "crunchy"
}
% Class OnionChips -superclass {Onion Chips}
OnionChips
% OnionChips abag
abag
% abag taste
crunchy onion
Other Directions
There are many other things we could do with bagels, but it's time
to consult the reference pages. The OTcl language aims to provide you
with the basic object-oriented programming features that you need for
most tasks, while being extensible enough to allow you to customize
existing features or create your own.
Here are several important areas that the tutorial hasn't
discussed.
- There is support for autoloading libraries of classes and
methods. See OTcl Autoloading for details.
- There is a C level interface (as defined by otcl.h) that
allows new objects and classes to be created, and methods implemented
in C to be added to objects. See OTcl C API
for details.
- Classes are special kinds of objects, and have all of the
properties of regular objects. Thus classes are a convenient
repository for procedures and data that are shared by their
instances. And the behavior of classes may be controlled by the
standard inheritance mechanisms and the class Class.
- Methods called procs can be added to individual object, for sole
use by that object. This allows particular objects to be hand-crafted,
perhaps storing their associated procedures and data.
- User defined methods are treated in the same way as system
provided methods (such as set and info). You can use
the standard inheritance mechanisms to provide your own implementation
in place of a system method.
- There are several other system methods that haven't been
described. array gives information on array instance
variables, unset removes instance variables, there are
further info options, and so forth.
otcl-1.14/install-sh 0000664 0000764 0000766 00000004212 06364020664 013267 0 ustar tomh nsnam #!/bin/sh
#
# install - install a program, script, or datafile
# This comes from X11R5; it is not part of GNU.
#
# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $
#
# This script is compatible with the BSD install script, but was written
# from scratch.
#
# set DOITPROG to echo to test this script
# Don't use :- since 4.3BSD and earlier shells don't like it.
doit="${DOITPROG-}"
# put in absolute paths if you don't have them in your path; or use env. vars.
mvprog="${MVPROG-mv}"
cpprog="${CPPROG-cp}"
chmodprog="${CHMODPROG-chmod}"
chownprog="${CHOWNPROG-chown}"
chgrpprog="${CHGRPPROG-chgrp}"
stripprog="${STRIPPROG-strip}"
rmprog="${RMPROG-rm}"
instcmd="$mvprog"
chmodcmd=""
chowncmd=""
chgrpcmd=""
stripcmd=""
rmcmd="$rmprog -f"
mvcmd="$mvprog"
src=""
dst=""
while [ x"$1" != x ]; do
case $1 in
-c) instcmd="$cpprog"
shift
continue;;
-m) chmodcmd="$chmodprog $2"
shift
shift
continue;;
-o) chowncmd="$chownprog $2"
shift
shift
continue;;
-g) chgrpcmd="$chgrpprog $2"
shift
shift
continue;;
-s) stripcmd="$stripprog"
shift
continue;;
*) if [ x"$src" = x ]
then
src=$1
else
dst=$1
fi
shift
continue;;
esac
done
if [ x"$src" = x ]
then
echo "install: no input file specified"
exit 1
fi
if [ x"$dst" = x ]
then
echo "install: no destination specified"
exit 1
fi
# If destination is a directory, append the input filename; if your system
# does not like double slashes in filenames, you may need to add some logic
if [ -d $dst ]
then
dst="$dst"/`basename $src`
fi
# Make a temp file name in the proper directory.
dstdir=`dirname $dst`
dsttmp=$dstdir/#inst.$$#
# Move or copy the file name to the temp name
$doit $instcmd $src $dsttmp
# and set any options; do chmod last to preserve setuid bits
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi
# Now rename the file to the real destination.
$doit $rmcmd $dst
$doit $mvcmd $dsttmp $dst
exit 0
otcl-1.14/lib/test.tcl 0000664 0000764 0000766 00000031203 07711534521 013516 0 ustar tomh nsnam #
# $Id: test.tcl,v 1.2 2003/07/29 18:13:37 xuanc Exp $
#
# Copyright 1993 Massachusetts Institute of Technology
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation, and that the name of M.I.T. not be used in advertising or
# publicity pertaining to distribution of the software without specific,
# written prior permission. M.I.T. makes no representations about the
# suitability of this software for any purpose. It is provided "as is"
# without express or implied warranty.
#
#
#
# a meta-class for test objects, and a class for test suites
#
Class TestClass -superclass Class
Class TestSuite
#
# check basic argument dispatch and unknown
#
TestSuite objectdispatch
objectdispatch proc run {{n 50}} {
Object adispatch
adispatch proc unknown {m args} {eval list [list $m] $args}
adispatch proc cycle {l n args} {
if {$l>=$n} then {return ok}
set i [llength $args]
foreach a $args {
if {$a != $i} then {
error "wrong order in arguments: $l $n $args"
}
incr i -1
}
incr l
set ukn [eval [list $self] $args]
if {$ukn != $args} then {
error "wrong order in unknown: $ukns"
}
eval [list $self] [list $proc] [list $l] [list $n] [list $l] $args
}
if {[catch {adispatch cycle 1 $n 1} msg]} then {
error "FAILED $self: cycle: $msg"
}
return "PASSED $self"
}
#
# examples from the workshop paper
#
TestSuite paperexamples
paperexamples proc example1 {} {
Object astack
astack set things {}
astack proc put {thing} {
$self instvar things
set things [concat [list $thing] $things]
return $thing
}
astack proc get {} {
$self instvar things
set top [lindex $things 0]
set things [lrange $things 1 end]
return $top
}
astack put bagel
astack get
astack destroy
}
paperexamples proc example2 {} {
Class Safety
Safety instproc init {} {
$self next
$self set count 0
}
Safety instproc put {thing} {
$self instvar count
incr count
$self next $thing
}
Safety instproc get {} {
$self instvar count
if {$count == 0} then { return {empty!} }
incr count -1
$self next
}
Class Stack
Stack instproc init {} {
$self next
$self set things {}
}
Stack instproc put {thing} {
$self instvar things
set things [concat [list $thing] $things]
return $thing
}
Stack instproc get {} {
$self instvar things
set top [lindex $things 0]
set things [lrange $things 1 end]
return $top
}
Class SafeStack -superclass {Safety Stack}
SafeStack s
s put bagel
s get
s get
s destroy
SafeStack destroy
Stack destroy
Safety destroy
}
paperexamples proc run {} {
set msg {}
if {[catch {$self example1; $self example2} msg] == "0"} then {
return "PASSED $self"
} else {
error "FAILED $self: $msg"
}
}
#
# create a graph of classes
#
TestSuite classcreate
classcreate proc factorgraph {{n 3600}} {
TestClass $n
for {set i [expr {$n/2}]} {$i>1} {incr i -1} {
if {($n % $i) == 0} then {
#
# factors become subclasses, direct or indirect
#
if {[TestClass info instances $i] == {}} then {
$self factorgraph $i
$i superclass $n
} elseif {[$i info superclass $n] == 0} then {
$i superclass [concat [$i info superclass] $n]
}
}
}
}
classcreate proc run {} {
set msg {}
if {[catch {$self factorgraph} msg] == "0"} then {
return "PASSED $self"
} else {
error "FAILED $self: $msg"
}
}
#
# lookup superclasses and combine inherited methods
#
TestSuite inheritance
inheritance proc meshes {s l} {
set p -1
foreach j $s {
set n [lsearch -exact $l $j]
if {$n == -1} then {
error "FAILED $self - missing superclass"
}
if {$n <= $p} then {
error "FAILED $self - misordered heritage: $s : $l"
}
set p $n
}
}
inheritance proc superclass {} {
foreach i [TestClass info instances] {
set s [$i info superclass]
set h [$i info heritage]
#
# superclasses should mesh with heritage
#
$self meshes $s $h
}
}
inheritance proc combination {} {
foreach i [TestClass info instances] {
#
# combination should mesh with heritage
#
$i anumber
set obj [lrange [anumber combineforobj] 1 end]
set h [$i info heritage]
$self meshes $obj $h
anumber destroy
if {[$i info procs combineforclass] != {}} then {
set cls [lrange [$i combineforclass] 1 end]
$self meshes $cls $h
}
}
}
inheritance proc run {} {
#
# add combine methods to "random" half of the graph
#
set t [TestClass info instances]
for {set i 0} {$i < [llength $t]} {incr i 2} {
set o [lindex $t $i]
$o instproc combineforobj {} {
return [concat [list $class] [$self next]]
}
$o proc combineforclass {} {
return [concat [list $class] [$self next]]
}
}
#
# and to Object as a fallback
#
Object instproc combineforobj {} {
return [concat [list $class] [$self next]]
}
Object proc combineforclass {} {
return [concat [list $class] [$self next]]
}
$self superclass
$self combination
return "PASSED $self"
}
#
# destroy graph of classes
#
TestSuite classdestroy
classdestroy proc run {} {
#
# remove half of the graph at a time
#
TestClass instproc destroy {} {
global TCdestroy
set TCdestroy $self
$self next
}
while {[TestClass info instances] != {}} {
set t [TestClass info instances]
for {set i 0} {$i < [llength $t]} {incr i} {
set o [lindex $t $i]
#
# quarter dies directly, quarter indirectly, quarter renamed
#
if {($i % 2) == 0} then {
global TCdestroy
set sb [$o info subclass]
if {[info tclversion] >= 7.4 && ($i % 4) == 0} then {
rename $o {}
} else {
$o destroy
}
if {[catch {set TCdestroy}] || $TCdestroy != $o} then {
error "FAILED $self - destroy instproc not run for $o"
}
if {[info commands $o] != {}} then {
error "FAILED $self - $o not removed from interpreter"
}
unset TCdestroy
#
# but everyone must still have a superclass
#
foreach j $sb {
if {[$j info superclass] == {}} then {
$j superclass Object
}
}
} elseif {[info tclversion] >= 7.4 && ($i % 3) == 0} then {
rename $o $o.$i
}
}
inheritance superclass
inheritance combination
}
return "PASSED $self"
}
TestSuite objectinits
objectinits proc prepare {n} {
#
# head of a chain of classes that do add inits
#
TestClass 0
0 instproc init {args} {
eval $self next $args
$self set order {}
}
#
# and the rest
#
for {set i 1} {$i < $n} {incr i} {
TestClass $i -superclass [expr {$i-1}]
#
# record the reverse order of inits
#
$i instproc init {args} {
eval $self next $args
$self instvar order
lappend order $class
}
#
# add instproc for init options
#
$i instproc $i.set {val} {
$self instvar $class
set $class $proc.$val
}
}
}
objectinits proc run {{n 15}} {
$self prepare $n
set il {}
for {set i 1} {$i < $n} {incr i} {
lappend il $i
set al {}
set args {}
for {set j $i} {$j > 0} {incr j -1} {
lappend al $j
lappend args -$j.set $j
#
# create obj of increasing class with increasing options
#
if {[catch {eval $i $i.$j $args} msg] != 0} then {
error "FAILED $self - $msg"
}
if {[$i.$j set order] != $il} then {
error "FAILED $self - inited order was wrong"
}
set vl [lsort -decreasing -integer [$i.$j info vars {[0-9]*}]]
if {$vl != $al} then {
error "FAILED $self - wrong instvar names: $vl : $al"
}
foreach k $vl {
set val $k.set.$k
if {[$i.$j set $k] != $val} then {
error "FAILED $self - wrong instvar values"
}
}
}
}
return "PASSED $self"
}
TestSuite objectvariables
objectvariables proc run {{n 100}} {
TestClass Variables
Variables avar
foreach obj {avar Variables TestClass Class Object} {
#
# set up some variables
#
$obj set scalar 0
$obj set array() {}
$obj unset array()
$obj set unset.$n {}
#
# mess with them recursively
#
$obj proc recurse {n} {
$self instvar scalar array
incr scalar
set array($n) $n
$self instvar unset.$n
unset unset.$n
incr n -1
$self instvar unset.$n
set unset.$n [array names array]
if {$n > 0} then {
$self recurse $n
}
}
$obj recurse $n
#
# check the result and clean up
#
if {[$obj set scalar] != $n} then {
error "FAILED $self - scalar"
}
$obj unset scalar
for {set i $n} {$i > 0} {incr i -1} {
if {[$obj set array($i)] != $i} then {
error "FAILED $self - array"
}
}
$obj unset array
if {[$obj info vars] != "unset.0"} then {
error "FAILED $self - unset: [$obj info vars]"
}
}
#
# trace variables
#
Variables avar2
avar2 proc trace {var ops} {
$self instvar $var
trace variable $var $ops "avar2 traceproc"
}
avar2 proc traceproc {maj min op} {
global trail; lappend trail [list $maj $min $op]
}
global guide trail
avar2 trace array wu
for {set i 0} {$i < $n} {incr i} {
avar2 trace scalar$i wu
avar2 set scalar$i $i
lappend guide [list scalar$i {} w]
avar2 set array($i) [avar2 set scalar$i]
lappend guide [list array $i w]
}
if {$guide != $trail} then {
error "FAILED $self - trace: expected $guide, got $trail"
}
#
# destroy must trigger unset traces
#
set trail {}
set guide {}
lappend guide [list array {} u]
for {set i 0} {$i < $n} {incr i} {
lappend guide [list scalar$i {} u]
}
avar2 destroy
if {[lsort $guide] != [lsort $trail]} then {
error "FAILED $self - trace: expected $guide, got $trail"
}
Variables destroy
return "PASSED $self"
}
#
# c api, if compiled with -DTESTCAPI
#
TestSuite capi
capi proc run {{n 50}} {
set start [dawnoftime read]
for {set i 0} {$i < $n} {incr i} {
Timer atime$i
if {$i % 3} {atime$i stop}
if {$i % 7} {atime$i read}
if {$i % 2} {atime$i start}
if {$i % 5} {atime$i stop}
}
set end [dawnoftime read]
if {$end < $start} {
error "FAILED $self: timer doesn't work"
}
foreach i [Timer info instances] {$i destroy}
Timer destroy
return "PASSED $self"
}
#
# high and low level autoload
#
TestSuite autoload
autoload proc atest {} {
}
autoload proc run {{n 10}} {
global auto_path
foreach i [glob -nocomplain tmpld*.tcl] {exec rm -f $i}
set prev Object
for {set i 0} {$i <= $n} {incr i} {
set fid [open "tmpld$i.tcl" w]
puts $fid "Class AutoTest$i -superclass $prev"
puts $fid "AutoTest0 instproc $i {args} {return 1}"
set prev AutoTest$i
close $fid
}
catch {exec mv -f tclIndex tclIndex.saved}
otcl_mkindex Class . tmpld*.tcl
lappend auto_path .
auto_reset
# why use AutoTest5?
# fine for 0, but not others
# if enable print out in otcl.c, seg fault
# xuanc, 7/29/03
set m [expr {$n/2}]
if {[catch {AutoTest$m atest} msg]} then {
error "FAILED $self - $msg"
}
for {set i $n} {$i > $m} {incr i -1} {
if {[AutoTest0 info instprocs $i] == {}} then {
error "FAILED $self - missing loader stub"
}
if {![catch {AutoTest0 info instbody $i}]} then {
error "FAILED $self - premature load"
}
}
for {set i 0} {$i <= $m} {incr i} {
if {[AutoTest0 info instprocs $i] == {}} then {
error "FAILED $self - missing instproc"
}
if {[catch {AutoTest0 info instbody 0}]} then {
error "FAILED $self - failed load"
}
}
# why 0-10? AutoTest5 can only load procs 0-5
# hangs when i = 6
# need to fix, xuanc, 7/29/2003
for {set i 0} {$i <= $n} {incr i} {
if {![atest $i]} then {
error "FAILED $self - wrong proc result"
}
}
puts "after atest"
exec rm -f tclIndex
foreach i [glob -nocomplain tmpld*.tcl] {exec rm -f $i}
catch {exec mv -f tclIndex.saved tclIndex}
return "PASSED $self"
}
TestSuite proc run {} {
#
# run individual tests in needed order
#
puts [objectdispatch run]
puts [paperexamples run]
puts [classcreate run]
puts [inheritance run]
puts [classdestroy run]
puts [objectinits run]
puts [objectvariables run]
if {[info commands Timer] != {}} then {
puts [capi run]
}
# autoload hangs---xuanc, 7/29/03
puts [autoload run]
}
TestSuite run
exit
# Local Variables:
# mode: tcl
# tcl-indent-level: 2
# End:
otcl-1.14/Makefile.in 0000664 0000764 0000766 00000010061 11274666210 013331 0 ustar tomh nsnam
#
# try ./configure first to fill in all the definitions corresponding
# to your system, but you always can edit the sections below manually.
#
CC= @CC@
CFLAGS= @CFLAGS@
RANLIB= @RANLIB@
INSTALL= @INSTALL@
#
# how to compile, link, and name shared libraries
#
SHLIB_LD= @SHLIB_LD@
SHLIB_CFLAGS= @SHLIB_CFLAGS@
SHLIB_SUFFIX= @SHLIB_SUFFIX@
SHLD_FLAGS= @DL_LD_FLAGS@
DL_LIBS= @DL_LIBS@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
#
# where to install shells, libraries, and includes
#
INST_OTCLSH= @prefix@/bin
INST_OWISH= @prefix@/bin
INST_OLIB= @prefix@/lib
INST_OLIBSH= @INST_OLIBSH@
INST_OINC= @prefix@/include
#
# ------------ you shouldn't need to configure below here -----------------
#
INCLUDES = \
-I. \
@V_INCLUDES@ \
@V_INCLUDE_X11@ \
-I@includedir@ \
@V_INCLUDE@
DEFINES = \
@V_DEFINE@
LIB = @V_LIBS@ \
@V_LIB_X11@ @V_LIB@ -lm
OTCLLIB= -L. -lotcl
CP= cp -f
RM= rm -f
MV= mv -f
CFILES = otcl.c otclAppInit.c otkAppInit.c
.c.o:
$(CC) -c $(CFLAGS) $(DEFINES) $(INCLUDES) $<
all: libotcl.a libotcl$(SHLIB_SUFFIX) otclsh owish
#
# compile an appinit with tcl and otcl and link against
# libotcl.a plus required tcl libs to give a standalone binary
#
otclsh: otclAppInit.c libotcl.a
rm -f libotcl$(SHLIB_SUFFIX)
$(CC) -o otclsh $(SHLD_FLAGS) $(CFLAGS) $(INCLUDES) otclAppInit.c \
$(OTCLLIB) $(LIB)
#
# compile an appinit with tcl/tk and otcl and link against
# libotcl.a plus required tcl/tk libs to give a standalone binary
#
owish: otkAppInit.c libotcl.a
rm -f libotcl$(SHLIB_SUFFIX)
$(CC) -o owish $(SHLD_FLAGS) $(CFLAGS) $(INCLUDES) otkAppInit.c \
$(OTCLLIB) $(LIB)
#
# compile otcl.c and link it into a library archive
# INCLUDES give a path to tclInt.h (plus tk and X11)
#
libotcl.a: otcl.c
rm -f libotcl.a otcl.o
$(CC) -c $(CFLAGS) $(DEFINES) $(INCLUDES) otcl.c
ar cq libotcl.a otcl.o
$(RANLIB) libotcl.a
#
# compile otcl.c and link it into a shared object
# INCLUDES give a path to tclInt.h (plus tk and X11)
#
libotcl$(SHLIB_SUFFIX): otcl.c
rm -f libotcl$(SHLIB_SUFFIX) otcl.o so_locations
$(CC) -c $(CFLAGS) $(DEFINES) $(SHLIB_CFLAGS) $(INCLUDES) otcl.c
$(SHLIB_LD) -o libotcl$(SHLIB_SUFFIX) otcl.o
test: otclsh owish
./otclsh lib/test.tcl
./owish lib/test.tcl
dirs:
for d in $(INST_OWISH) $(INST_OTCLSH) $(INST_OLIB) $(INST_OLIBSH) $(INST_OINC); do \
if [ ! -d $$d ]; then \
mkdir -p $$d ;\
fi;\
done
install: owish otclsh libotcl.a libotcl$(SHLIB_SUFFIX) otcl.h dirs
$(INSTALL) owish $(INST_OWISH)
$(INSTALL) otclsh $(INST_OTCLSH)
$(INSTALL) libotcl.a $(INST_OLIB)
$(RANLIB) $(INST_OLIB)/libotcl.a
$(INSTALL) libotcl$(SHLIB_SUFFIX) $(INST_OLIBSH)
$(INSTALL) -m 644 otcl.h $(INST_OINC)
clean:
rm -f owish otclsh libotcl.a libotcl$(SHLIB_SUFFIX) \
otcl.o otkAppInit.o otclAppInit.o \
config.status config.log config.cache \
core so_locations *.core Makefile
# To be compatible with ns/nam
distclean: clean
binclean:
rm -f otcl.o otkAppInit.o otclAppInit.o \
config.status config.log config.cache \
core so_locations
srctar:
@cwd=`pwd` ; dir=`basename $$cwd` ; \
name=otcl-`cat VERSION | tr A-Z a-z` ; \
tar=otcl-src-`cat VERSION`.tar.gz ; \
list="" ; \
for i in `cat FILES` ; do list="$$list $$name/$$i" ; done; \
echo \
"(rm -f $$tar; cd .. ; ln -s $$dir $$name)" ; \
(rm -f $$tar; cd .. ; ln -s $$dir $$name) ; \
echo \
"(cd .. ; tar cfh $$tar [lots of files])" ; \
(cd .. ; tar cfhz - $$list) > $$tar ; \
echo \
"rm ../$$name; chmod 444 $$tar" ; \
rm ../$$name; chmod 444 $$tar
depend: $(CFILES)
@echo Making dependencies for $(srcdir){$(CFILES)}
@$(CC) -MM $(CFLAGS) $(INCLUDES) $(DEFINES) $(CFILES) > makedep
@echo '/^# DO NOT DELETE THIS LINE/+1,$$d' > eddep
@echo '$$r makedep' >> eddep
@echo 'w' >>eddep
@$(CP) Makefile Makefile.bak
@ed - Makefile < eddep
@$(RM) eddep makedep
@echo '# DEPENDENCIES MUST END AT END OF FILE' >> Makefile
@echo '# IF YOU PUT STUFF HERE IT WILL GO AWAY' >> Makefile
@echo '# see make depend above' >> Makefile
# DO NOT DELETE THIS LINE
# DEPENDENCIES MUST END AT END OF FILE
# IF YOU PUT STUFF HERE IT WILL GO AWAY
# see make depend above
otcl-1.14/makefile.vc 0000664 0000764 0000766 00000010652 10316150657 013400 0 ustar tomh nsnam # Generated automatically from Makefile.in by configure.
#
# try ./configure first to fill in all the definitions corresponding
# to your system, but you always can edit the sections below manually.
#
APPVER=4.0
TARGETOS=BOTH
TOOLS32 = C:\Program Files\Microsoft Visual Studio\VC98
cc32= "$(TOOLS32)\bin\cl"
link32= "$(TOOLS32)\bin\link"
CFLAGS= -Zi -W3
LIB= lib
INSTALL=
OTCL_DIR= ..\otcl
!include
#
# where to find tcl/tk source (for includes) and binaries (for libraries)
#
STATIC_TCLTK = 1
TCLPATCHLEVEL = 8.4.11
TCLDOTVERSION = 8.3
TCLVERSION = $(TCLDOTVERSION:.=)
!if exist(..\tcl$(TCLPATCHLEVEL))
TCLSUFFIX = $(TCLPATCHLEVEL)
!else if exist(..\tcl$(TCLDOTVERSION))
TCLSUFFIX = $(TCLDOTVERSION)
!else
TCLSUFFIX =
!endif
TCLINC= -I..\tcl$(TCLSUFFIX)\generic
TKINC= -I..\tk$(TCLSUFFIX)\generic
# Where X headers are located
TKXINC= -I..\tk$(TCLSUFFIX)\xlib
!ifdef STATIC_TCLTK
TCLLIB= ..\tcl$(TCLSUFFIX)\win\Release\tcl$(TCLVERSION)s.lib
TKLIB= ..\tk$(TCLSUFFIX)\win\Release\tk$(TCLVERSION)s.lib
!else
TCLLIB= ..\tcl$(TCLSUFFIX)\win\Release\tcl$(TCLVERSION).lib
TKLIB= ..\tk$(TCLSUFFIX)\win\Release\tk$(TCLVERSION).lib
!endif
!ifdef STATIC_TCLTK
OTCLSH_LIBS= $(conlibsmt)
OWISH_LIBS= $(guilibsmt) imm32.lib
!else
OTCLSH_LIBS= $(conlibsdll)
OWISH_LIBS= $(guilibsdll)
!endif
#
# X11 and other libraries from tcl/tk make as needed to link tclsh and wish
#
XINC=$(TKXINC)
XLIB=
OTHER_TCL_LIBS=
OTHER_TK_LIBS=
#
# where to install shells, libraries, and includes
#
INST_OTCLSH=
INST_OWISH=
INST_OLIB=
INST_OLIBSH=
INST_OINC=
#
# ------------ you shouldn't need to configure below here -----------------
#
.SUFFIXES : .cc
!ifdef STATIC_TCLTK
CVARS= $(cvarsmt) -DSTATIC_BUILD=1
!else
CVARS= $(cvarsdll)
!endif
CINCLUDES= -I. $(TCLINC) $(TKINC) $(XINC)
OTCLLIB= otcl.lib
.c.o:
$(CC) $(cdebug:-Z7=) $(cflags) $(CVARS) -c $(CFLAGS) $(CINCLUDES) -Fo$@ $<
all: $(OTCLLIB) otclsh.exe owish.exe
#
# compile an appinit with tcl and otcl and link against
# libotcl.a plus required tcl libs to give a standalone binary
#
otclsh.exe: otclAppInit.o $(OTCLLIB)
set LIB="$(TOOLS32)\lib"
$(link32) $(ldebug) $(conlflags) -out:$@ \
otclAppInit.o $(OTCLLIB) \
$(TCLLIB) $(OTHER_TCL_LIBS) $(OTCLSH_LIBS) user32.lib
#
# compile an appinit with tcl/tk and otcl and link against
# libotcl.a plus required tcl/tk libs to give a standalone binary
owish.exe: otkAppInit.o $(OTCLLIB)
set LIB="$(TOOLS32)\lib"
$(link32) $(ldebug) $(conlflags) -out:$@ \
otkAppInit.o $(OTCLLIB) $(TKLIB) $(TCLLIB) $(XLIB) $(DL_LIBS) \
$(OTHER_TK_LIBS) $(OTHER_TCL_LIBS) $(OWISH_LIBS) user32.lib
#
# compile otcl.c and link it into a library archive
# INCLUDES give a path to tclInt.h (plus tk and X11)
#
$(OTCLLIB): otcl.o
$(LIB) /nologo /name:$(OTCLLIB) /OUT:$(OTCLLIB) otcl.o
#
# compile otcl.c and link it into a shared object
# INCLUDES give a path to tclInt.h (plus tk and X11)
#
libotcl$(SHLIB_SUFFIX): otcl.c
rm -f libotcl$(SHLIB_SUFFIX) otcl.o so_locations
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(INCLUDES) otcl.c
$(SHLIB_LD) -o libotcl$(SHLIB_SUFFIX) otcl.o
test: otclsh.exe owish.exe
$(OTCL_DIR)\otclsh.exe lib/test.tcl
$(OTCL_DIR)\owish.exe lib/test.tcl
install: owish otclsh libotcl.a libotcl$(SHLIB_SUFFIX) otcl.h
$(INSTALL) $(INST_OWISH) owish
$(INSTALL) $(INST_OTCLSH) otclsh
$(INSTALL) $(INST_OLIB) libotcl.a
$(INSTALL) $(INST_OLIBSH) libotcl$(SHLIB_SUFFIX)
$(INSTALL) $(INST_OINC) otcl.h
clean:
@if exist otclsh.exe del otclsh.exe
@if exist owish.exe del owish.exe
@if exist otcl.lib del otcl.lib
@if exist otcl.o del otcl.o
@if exist otkAppInit.o del otkAppInit.o
@if exist otclAppInit.o del otclAppInit.o
binclean:
@if exist otcl.o del otcl.o
@if exist otkAppInit.o del otkAppInit.o
@if exist otclAppInit.o del otclAppInit.o
@if exist config.status del config.status
@if exist config.log del config.log
@if exist config.cache del config.cache
srctar:
@cwd=`pwd` ; dir=`basename $$cwd` ; \
name=otcl-`cat VERSION | tr A-Z a-z` ; \
tar=otcl-`cat VERSION`.tar.gz ; \
list="" ; \
for i in `cat FILES` ; do list="$$list $$name/$$i" ; done; \
echo \
"(rm -f $$tar; cd .. ; ln -s $$dir $$name)" ; \
(rm -f $$tar; cd .. ; ln -s $$dir $$name) ; \
echo \
"(cd .. ; tar cfh $$tar [lots of files])" ; \
(cd .. ; tar cfh - $$list) | gzip -c > $$tar ; \
echo \
"rm ../$$name; chmod 444 $$tar" ; \
rm ../$$name; chmod 444 $$tar
otcl-1.14/otcl.c 0000644 0000764 0000766 00000205765 11635457075 012420 0 ustar tomh nsnam /* -*- Mode: c++ -*-
*
* $Id: otcl.c,v 1.25 2011/09/18 20:58:40 tom_henderson Exp $
*
* Copyright 1993 Massachusetts Institute of Technology
*
* Permission to use, copy, modify, distribute, and sell this software and its
* documentation for any purpose is hereby granted without fee, provided that
* the above copyright notice appear in all copies and that both that
* copyright notice and this permission notice appear in supporting
* documentation, and that the name of M.I.T. not be used in advertising or
* publicity pertaining to distribution of the software without specific,
* written prior permission. M.I.T. makes no representations about the
* suitability of this software for any purpose. It is provided "as is"
* without express or implied warranty.
*
*/
#include
#include
#include
#include
/*
* compatibility definitions to bridge 7.x -> 7.5
*/
#if TCL_MAJOR_VERSION < 7
#error Tcl distribution is TOO OLD
#elif TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION <= 3
typedef char* Tcl_Command;
static char* Tcl_GetCommandName(Tcl_Interp* in, Tcl_Command id) {
return id;
}
static int Tcl_UpVar(Tcl_Interp* in, char* lvl, char* l, char* g, int flg){
char* args[4];
args[0] = "uplevel"; args[1] = "1";
args[2]=l; args[3]=g;
return Tcl_UpvarCmd(0, in, 4, args);
}
#define Tcl_CreateCommand(A,B,C,D,E) \
strcpy((char*)ckalloc(strlen(B)+1), B);\
Tcl_CreateCommand(A,B,C,D,E)
#endif
#if TCL_MAJOR_VERSION <= 7
#define TclIsVarUndefined(varPtr) \
((varPtr)->flags == VAR_UNDEFINED)
#endif
#if TCL_MAJOR_VERSION < 8
#define ObjVarTablePtr(OBJ) (&(OBJ)->variables.varTable)
#define compat_Tcl_AddObjErrorInfo(a,b,c) Tcl_AddErrorInfo(a,b)
#else
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5
#define ObjVarTablePtr(OBJ) ((OBJ)->variables.varTablePtr)
#else
#define TCL_VERSION_8_5_OR_HIGHER
#define ObjVarTablePtr(OBJ) (&(OBJ)->variables.varTablePtr->table)
#endif
#define compat_Tcl_AddObjErrorInfo(a,b,c) Tcl_AddObjErrorInfo(a,b,c)
#endif
#ifdef TCL_VERSION_8_5_OR_HIGHER
#define Tcl_VarHashInitialize(varTablePtr) varTablePtr = NULL;
#define Tcl_IsVarHashInitialized(varTablePtr) varTablePtr == NULL
#define Tcl_VarHashGetKey(table, hPtr) TclGetString(hPtr->key.objPtr)
#define Tcl_VarHashGetValue(hPtr) ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
#define Tcl_CmdInfoGetProc(co) (Proc *)(co->isNativeObjectProc) ? co->objClientData : co->clientData;
#else
#define Tcl_VarHashInitialize(varTablePtr) \
varTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); \
if (varTablePtr != NULL) Tcl_InitHashTable(varTablePtr, TCL_STRING_KEYS);
#define Tcl_IsVarHashInitialized(varTablePtr) varTablePtr != NULL
#define Tcl_VarHashGetKey(table, hPtr) Tcl_GetHashKey(table, hPtr)
#define Tcl_VarHashGetValue(hPtr) (Var*)Tcl_GetHashValue(hp);
#define Tcl_CmdInfoGetProc(co) (Proc*)co->clientData;
#endif
/*
* object and class internals
*/
typedef struct OTclObject {
Tcl_Command id;
Tcl_Interp* teardown;
struct OTclClass* cl;
struct OTclClass* type;
Tcl_HashTable* procs;
CallFrame variables;
} OTclObject;
typedef struct OTclClass {
struct OTclObject object;
struct OTclClasses* super;
struct OTclClasses* sub;
int color;
struct OTclClasses* order;
struct OTclClass* parent;
Tcl_HashTable instprocs;
Tcl_HashTable instances;
Tcl_HashTable* objectdata;
} OTclClass;
typedef struct OTclClasses {
struct OTclClass* cl;
struct OTclClasses* next;
} OTclClasses;
/*
* definitions of the main otcl objects
*/
static Tcl_HashTable* theObjects = 0;
static Tcl_HashTable* theClasses = 0;
static Tcl_CmdProc* ProcInterpId = 0;
/*
* error return functions
*/
static int
OTclErrMsg(Tcl_Interp *in, char* msg, Tcl_FreeProc* type) {
Tcl_SetResult(in, msg, type);
return TCL_ERROR;
}
static int
OTclErrArgCnt(Tcl_Interp *in, CONST84 char *cmdname, char *arglist) {
Tcl_ResetResult(in);
Tcl_AppendResult(in, "wrong # args: should be {", cmdname, 0);
if (arglist != 0) Tcl_AppendResult(in, " ", arglist, 0);
Tcl_AppendResult(in, "}", 0);
return TCL_ERROR;
}
static int
OTclErrBadVal(Tcl_Interp *in, char *expected, CONST84 char *value) {
Tcl_ResetResult(in);
Tcl_AppendResult(in, "expected ", expected, " but got", 0);
Tcl_AppendElement(in, value);
return TCL_ERROR;
}
static int
OTclErrType(Tcl_Interp *in, CONST84 char* nm, char* wt) {
Tcl_ResetResult(in);
Tcl_AppendResult(in,"type check failed: ",nm," is not of type ",wt,0);
return TCL_ERROR;
}
/*
* precedence ordering functions
*/
enum colors { WHITE, GRAY, BLACK };
static int
TopoSort(OTclClass* cl, OTclClass* base, OTclClasses* (*next)(OTclClass*)) {
OTclClasses* sl = (*next)(cl);
OTclClasses* pl;
/*
* careful to reset the color of unreported classes to
* white in case we unwind with error, and on final exit
* reset color of reported classes to white
*/
cl->color = GRAY;
for (; sl != 0; sl = sl->next) {
OTclClass* sc = sl->cl;
if (sc->color==GRAY) { cl->color = WHITE; return 0; }
if (sc->color==WHITE && !TopoSort(sc, base, next)) {
cl->color=WHITE;
if (cl == base) {
OTclClasses* pc = cl->order;
while (pc != 0) { pc->cl->color = WHITE; pc = pc->next; }
}
return 0;
}
}
cl->color = BLACK;
pl = (OTclClasses*)ckalloc(sizeof(OTclClasses));
pl->cl = cl;
pl->next = base->order;
base->order = pl;
if (cl == base) {
OTclClasses* pc = cl->order;
while (pc != 0) { pc->cl->color = WHITE; pc = pc->next; }
}
return 1;
}
static void
RC(OTclClasses* sl) {
while (sl != 0) {
OTclClasses* n = sl->next;
ckfree((char*)sl); sl = n;
}
}
static OTclClasses* Super(OTclClass* cl) { return cl->super; }
static OTclClasses*
ComputePrecedence(OTclClass* cl) {
if (!cl->order) {
int ok = TopoSort(cl, cl, Super);
if (!ok) { RC(cl->order); cl->order = 0; }
}
return cl->order;
}
static OTclClasses* Sub(OTclClass* cl) { return cl->sub; }
static OTclClasses*
ComputeDependents(OTclClass* cl) {
if (!cl->order) {
int ok = TopoSort(cl, cl, Sub);
if (!ok) { RC(cl->order); cl->order = 0; }
}
return cl->order;
}
static void
FlushPrecedences(OTclClass* cl) {
OTclClasses* pc;
RC(cl->order); cl->order = 0;
pc = ComputeDependents(cl);
/*
* ordering doesn't matter here - we're just using toposort
* to find all lower classes so we can flush their caches
*/
if (pc) pc = pc->next;
while (pc != 0) {
RC(pc->cl->order); pc->cl->order = 0;
pc = pc->next;
}
RC(cl->order); cl->order = 0;
}
static void
AddInstance(OTclObject* obj, OTclClass* cl) {
obj->cl = cl;
if (cl != 0) {
int nw;
(void) Tcl_CreateHashEntry(&cl->instances, (char*)obj, &nw);
}
}
static int
RemoveInstance(OTclObject* obj, OTclClass* cl) {
if (cl != 0) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cl->instances, (char*)obj);
if (hPtr) { Tcl_DeleteHashEntry(hPtr); return 1; }
}
return 0;
}
/*
* superclass/subclass list maintenance
*/
static void
AS(OTclClass* cl, OTclClass* s, OTclClasses** sl) {
OTclClasses* l = *sl;
while (l && l->cl != s) l = l->next;
if (!l) {
OTclClasses* sc = (OTclClasses*)ckalloc(sizeof(OTclClasses));
sc->cl = s; sc->next = *sl; *sl = sc;
}
}
static void
AddSuper(OTclClass* cl, OTclClass* super) {
if (cl && super) {
/*
* keep corresponding sub in step with super
*/
AS(cl, super, &cl->super);
AS(super, cl, &super->sub);
}
}
static int
RS(OTclClass* cl, OTclClass* s, OTclClasses** sl) {
OTclClasses* l = *sl;
if (!l) return 0;
if (l->cl == s) {
*sl = l->next;
ckfree((char*)l);
return 1;
}
while (l->next && l->next->cl != s) l = l->next;
if (l->next) {
OTclClasses* n = l->next->next;
ckfree((char*)(l->next));
l->next = n;
return 1;
}
return 0;
}
static int
RemoveSuper(OTclClass* cl, OTclClass* super) {
/*
* keep corresponding sub in step with super
*/
int sp = RS(cl, super, &cl->super);
int sb = RS(super, cl, &super->sub);
return (sp && sb);
}
/*
* internal type checking
*/
static OTclClass*
InObject(Tcl_Interp* in) {
Tcl_HashEntry* hp = Tcl_FindHashEntry(theObjects, (char*)in);
if (hp != 0) return (OTclClass*)Tcl_GetHashValue(hp);
return 0;
}
static OTclClass*
InClass(Tcl_Interp* in) {
Tcl_HashEntry* hp = Tcl_FindHashEntry(theClasses, (char*)in);
if (hp != 0) return (OTclClass*)Tcl_GetHashValue(hp);
return 0;
}
static int
IsType(OTclObject* obj, OTclClass* type) {
OTclClass* t = obj ? obj->type : 0;
while (t && t!=type) t = t->parent;
return (t != 0);
}
/*
* methods lookup and dispatch
*/
static int
LookupMethod(Tcl_HashTable* methods, CONST84 char* nm, Tcl_CmdProc** pr,
ClientData* cd, Tcl_CmdDeleteProc** dp)
{
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(methods, nm);
if (hPtr != 0) {
Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
if (pr != 0) *pr = co->proc;
if (cd != 0) *cd = co->clientData;
if (dp != 0) *dp = co->deleteProc;
return 1;
}
return 0;
}
static OTclClass*
SearchCMethod(OTclClasses* pl, CONST84 char* nm, Tcl_CmdProc** pr,
ClientData* cd, Tcl_CmdDeleteProc** dp)
{
while (pl != 0) {
Tcl_HashTable* cm = &pl->cl->instprocs;
if (LookupMethod(cm, nm, pr, cd, 0) != 0) break;
pl = pl->next;
}
return pl ? pl->cl : 0;
}
#define OTCLSMALLARGS 8
static int
OTclDispatch(ClientData cd, Tcl_Interp* in, int argc, CONST84 char* argv[]) {
OTclObject* self = (OTclObject*)cd;
Tcl_CmdProc* proc = 0;
ClientData cp = 0;
OTclClass* cl = 0;
if (argc < 2) return OTclErrArgCnt(in, argv[0], "message ?args...?");
/*
* try for local methods first, then up the class heirarchy
*/
if (!self->procs || !LookupMethod(self->procs, argv[1], &proc, &cp, 0))
cl = SearchCMethod(ComputePrecedence(self->cl),argv[1],&proc,&cp,0);
if (proc) {
CONST84 char* sargs[OTCLSMALLARGS];
CONST84 char** args = sargs;
int result;
int i;
/*
* permute args to be: self self class method
* and, if method has no clientdata, pass an object pointer.
*/
cp = (cp != 0) ? cp : cd;
if (argc+2 > OTCLSMALLARGS)
args = (CONST84 char**)ckalloc((argc+2)*sizeof(char*));
args[0] = argv[0];
args[1] = argv[0];
args[2] = cl ? (char *) Tcl_GetCommandName(in, cl->object.id) : "";
for (i = 1; i < argc; i++) args[i+2] = argv[i];
/*
printf("%d ", argc);
for (i = 0; i < argc; i++)
printf("%s ", argv[i]);
printf("\n");
*/
/*
for (i = 0; i < argc + 2; i++)
printf("%s ", args[i]);
printf("\n");
*/
result = (*proc)(cp, in, argc+2, (const char **) args);
/* this adds to the stack trace */
if (result == TCL_ERROR) {
char msg[150];
/* old_args2 is because args[2] was getting
* clobbered sometimes => seg fault.
* ---johnh
*/
CONST84 char *old_args2 = cl ? (char *) Tcl_GetCommandName(in, cl->object.id) : argv[0];
sprintf(msg, "\n (%.40s %.40s line %d)",
old_args2, argv[1], in->errorLine);
compat_Tcl_AddObjErrorInfo(in, msg, -1);
}
if (argc+2 > OTCLSMALLARGS) { ckfree((char*)args); args = 0; }
return result;
}
/*
* back off and try unknown
*/
if (!self->procs || !LookupMethod(self->procs, "unknown", &proc, &cp, 0))
cl = SearchCMethod(ComputePrecedence(self->cl),"unknown",&proc,&cp,0);
if (proc) {
CONST84 char* sargs[OTCLSMALLARGS];
CONST84 char** args = sargs;
int result;
int i;
/*
* permute args to be: self self class method
* and, if method has no clientdata, pass an object pointer.
*/
cp = (cp != 0) ? cp : cd;
if (argc+3 > OTCLSMALLARGS)
args = (CONST84 char**)ckalloc((argc+3)*sizeof(char*));
args[0] = argv[0];
args[1] = argv[0];
args[2] = cl ? (char *) Tcl_GetCommandName(in, cl->object.id) : "";
args[3] = "unknown";
for (i = 1; i < argc; i++) args[i+3] = argv[i];
result = (*proc)(cp, in, argc+3, (const char **) args);
if (result == TCL_ERROR) {
char msg[100];
sprintf(msg, "\n (%.30s unknown line %d)",
cl ? args[2] : argv[0], in->errorLine);
compat_Tcl_AddObjErrorInfo(in, msg, -1);
}
if (argc+3 > OTCLSMALLARGS) { ckfree((char*)args); args = 0; }
return result;
}
/*
* and if that fails too, error out
*/
Tcl_ResetResult(in);
Tcl_AppendResult(in, argv[0], ": unable to dispatch method ", argv[1], 0);
return TCL_ERROR;
}
/*
* autoloading
*/
static void
AutoLoaderDP(ClientData cd) {
ckfree((char*)cd);
}
static int
AutoLoader(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
/*
* cd is a script to evaluate; object context reconstructed from argv
*/
OTclObject* obj = OTclGetObject(in, argv[1]);
OTclClass* cl = argv[2][0] ? OTclGetClass(in, argv[2]) : 0;
CONST84 char* clname = cl ? argv[2] : "{}";
Tcl_CmdProc* proc = 0;
ClientData cp = 0;
if (Tcl_Eval(in, (char*)cd) != TCL_OK) {
Tcl_AppendResult(in, " during autoloading (object=", argv[1],
", class=", clname, ", proc=", argv[3],")", 0);
return TCL_ERROR;
}
/*
* the above eval should have displaced this procedure from the object,
* so check by looking at our old spot in the table, and if successful
* continue dispatch with the right clientdata.
*/
if (cl)
(void) LookupMethod(&cl->instprocs, argv[3], &proc, &cp, 0);
else if (obj->procs)
(void) LookupMethod(obj->procs, argv[3], &proc, &cp, 0);
if (proc && proc != (Tcl_CmdProc *) AutoLoader) {
ClientData cdata = (cp != 0) ? cp : (ClientData)obj;
return (*proc)(cdata, in, argc, (const char **) argv);
}
Tcl_ResetResult(in);
Tcl_AppendResult(in, "no new proc during autoloading (object=", argv[1],
", class=", clname, ", proc=", argv[3],")", 0);
return TCL_ERROR;
}
int
MakeAuto(Tcl_CmdInfo* proc, CONST84 char* loader) {
proc->proc = (Tcl_CmdProc *) AutoLoader;
proc->deleteProc = AutoLoaderDP;
proc->clientData = (ClientData)strcpy(ckalloc(strlen(loader)+1), loader);
return (proc->clientData != 0);
}
/*
* creating, installing, listing and removing procs
*/
static void
AddMethod(Tcl_HashTable* methods, CONST84 char* nm, Tcl_CmdProc* pr,
ClientData cd, ClientData ocd, Tcl_CmdDeleteProc* dp, ClientData dd)
{
int nw = 0;
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(methods, nm, &nw);
Tcl_CmdInfo* co = (Tcl_CmdInfo*)ckalloc(sizeof(Tcl_CmdInfo));
co->proc = pr;
co->clientData = cd;
#ifdef TCL_VERSION_8_5_OR_HIGHER
co->objClientData = ocd;
co->isNativeObjectProc = (ocd != NULL) ? 1 : 0;
#endif
co->deleteProc = dp;
co->deleteData = dd;
Tcl_SetHashValue(hPtr, (ClientData)co);
}
static int
RemoveMethod(Tcl_HashTable* methods, CONST84 char* nm, ClientData cd) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(methods, nm);
if (hPtr != 0) {
Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
#ifdef TCL_VERSION_8_5_OR_HIGHER
#else
if (co->deleteProc != 0) (*co->deleteProc)(co->deleteData);
#endif
ckfree((char*)co);
Tcl_DeleteHashEntry(hPtr);
return 1;
}
return 0;
}
#if TCL_MAJOR_VERSION >= 8
typedef struct {
Tcl_Interp* interp;
int procUid;
} OTclDeleteProcData;
static int s_ProcUid=0;
static const char s_otclProcPrefix[] = "::otcl::p";
static char s_otclProcName[sizeof(s_otclProcPrefix) + 8];
const char* GetProcName(int index)
{
sprintf(s_otclProcName, "%s%d", s_otclProcPrefix, index);
return s_otclProcName;
}
static void
OTclDeleteProc(ClientData cd)
{
OTclDeleteProcData* pdpd = (OTclDeleteProcData*)cd;
/* cleanup, ignore any errors */
Tcl_Command cmd;
cmd = Tcl_FindCommand(pdpd->interp, (char*)GetProcName(pdpd->procUid),
(Tcl_Namespace*)NULL, 0);
if (cmd)
Tcl_DeleteCommandFromToken(pdpd->interp, cmd);
ckfree((char*)pdpd);
}
#endif
int
MakeProc(Tcl_CmdInfo* proc, Tcl_Interp* in, int argc, CONST84 char* argv[]) {
CONST84 char* name = argv[1];
CONST84 char* oargs = argv[2];
CONST84 char* nargs = (CONST84 char*)ckalloc(strlen("self class proc ")+strlen(argv[2])+1);
int ok = 0;
CONST84 char* id;
#if TCL_MAJOR_VERSION >= 8
Tcl_Obj **objv;
int i;
id= (char*)GetProcName(++s_ProcUid);
#else
id= "__OTclProc__";
#endif
/*
* add the standard method args automatically
*/
argv[1] = id;
(void)strcpy((char *)nargs, "self class proc ");
if (argv[2][0] != 0) (void) strcat((char *)nargs, argv[2]);
argv[2] = nargs;
#if TCL_MAJOR_VERSION >= 8
objv = (Tcl_Obj **)ckalloc(argc * sizeof(Tcl_Obj *));
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1); /* let strlen() decide length */
Tcl_IncrRefCount(objv[i]);
}
/*
* use standard Tcl_ProcCmd to digest, and fish result out of interp
*/
if (Tcl_ProcObjCmd(0, in, argc, objv) == TCL_OK) {
if (Tcl_GetCommandInfo(in, id, proc) && proc->proc == ProcInterpId) {
OTclDeleteProcData* pData =
(OTclDeleteProcData*)(ckalloc(sizeof(OTclDeleteProcData)));
pData->procUid = s_ProcUid;
pData->interp = in;
/* set the delete procedure to be OTclDeleteProc, which will
* remove the procedure, the deleteProc will be called in, for example,
* RemoveMethod, note that we are changing a copy of proc, the original
* proc structure still has the right deleteProc */
proc->deleteProc = OTclDeleteProc;
proc->deleteData = (ClientData)pData;
ok = 1;
}
}
for (i = 0; i < argc; i++)
Tcl_DecrRefCount(objv[i]);
ckfree((char *)objv);
#else /* TCL_MAJOR_VERSION < 8 */
if (Tcl_ProcCmd(0, in, argc, argv) == TCL_OK) {
if (Tcl_GetCommandInfo(in, id, proc) && proc->proc == ProcInterpId) {
Tcl_CmdDeleteProc* dp = proc->deleteProc;
proc->deleteProc = 0;
if (Tcl_SetCommandInfo(in, id, proc))
(void)Tcl_DeleteCommand(in, id);
proc->deleteProc = dp;
ok = 1;
}
}
#endif /* TCL_MAJOR_VERSION < 8 */
ckfree((char*)nargs);
argv[1] = name;
argv[2] = oargs;
return ok;
}
static void
ListKeys(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* pattern, int isVarHash) {
Tcl_HashSearch hSrch;
Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
Tcl_ResetResult(in);
for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
char* key = (isVarHash) ? Tcl_VarHashGetKey(table, hPtr) : Tcl_GetHashKey(table, hPtr);
if (!pattern || Tcl_StringMatch(key, pattern))
Tcl_AppendElement(in, key);
}
}
static void
ListInstanceKeys(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* pattern) {
Tcl_HashSearch hSrch;
Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
Tcl_ResetResult(in);
for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
OTclObject* obj = (OTclObject*)Tcl_GetHashKey(table, hPtr);
CONST84 char* name = (char *) Tcl_GetCommandName(in, obj->id);
if (!pattern || Tcl_StringMatch(name, pattern))
Tcl_AppendElement(in, name);
}
}
static void
ListProcKeys(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* pattern) {
Tcl_HashSearch hSrch;
Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
Tcl_ResetResult(in);
for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
CONST84 char* key = Tcl_GetHashKey(table, hPtr);
Tcl_CmdProc* proc = ((Tcl_CmdInfo*)Tcl_GetHashValue(hPtr))->proc;
if (pattern && !Tcl_StringMatch(key, pattern)) continue;
/*
* also counts anything to be autoloaded as a proc
*/
if (proc!=(Tcl_CmdProc *) AutoLoader && proc!=ProcInterpId) continue;
Tcl_AppendElement(in, key);
}
}
static Proc*
FindProc(Tcl_HashTable* table, CONST84 char* name) {
Tcl_HashEntry* hPtr = table ? Tcl_FindHashEntry(table, name) : 0;
if (hPtr) {
Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
if (co->proc == ProcInterpId)
return Tcl_CmdInfoGetProc(co);
}
return 0;
}
static int
ListProcArgs(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* name) {
Proc* proc = FindProc(table, name);
if (proc) {
#if TCL_MAJOR_VERSION == 7
Arg* args = proc->argPtr;
#else
CompiledLocal* args = proc->firstLocalPtr;
#endif
int i = 0;
/*
* skip over hidden self, class, proc args
*/
for (; args!=0 && i<3; args = args->nextPtr, i++) ;
Tcl_ResetResult(in);
while (args != 0) {
#if TCL_MAJOR_VERSION >= 8
/*#if TCL_RELEASE_SERIAL >= 3*/
#if ((TCL_MINOR_VERSION == 0) && (TCL_RELEASE_SERIAL >= 3)) || (TCL_MINOR_VERSION > 0)
if (TclIsVarArgument(args))
#else
if (args->isArg)
#endif
#endif
Tcl_AppendElement(in, args->name);
args = args->nextPtr;
}
return TCL_OK;
}
return OTclErrBadVal(in, "a tcl method name", name);
}
static int
ListProcDefault(Tcl_Interp* in, Tcl_HashTable* table,
CONST84 char* name, CONST84 char* arg, CONST84 char* var)
{
/*
* code snarfed from tcl info default
*/
Proc* proc = FindProc(table, name);
if (proc) {
#if TCL_MAJOR_VERSION < 8
Arg *ap;
for (ap = proc->argPtr; ap != 0; ap = ap->nextPtr) {
if (strcmp(arg, ap->name) != 0) continue;
if (ap->defValue != 0) {
if (Tcl_SetVar(in, var, ap->defValue, 0) == 0) {
#else
CompiledLocal *ap;
for (ap = proc->firstLocalPtr; ap != 0; ap = ap->nextPtr) {
if (strcmp(arg, ap->name) != 0) continue;
if (ap->defValuePtr != 0) {
if (Tcl_SetVar(in,
var,
#if TCL_MINOR_VERSION == 0
TclGetStringFromObj(ap->defValuePtr,
(int *) NULL),
#else
TclGetString(ap->defValuePtr),
#endif
0) == NULL) {
#endif
Tcl_ResetResult(in);
Tcl_AppendResult(in, "couldn't store default value in variable \"",
var, "\"", (char *) 0);
return TCL_ERROR;
}
Tcl_SetResult(in, "1", TCL_STATIC);
} else {
if (Tcl_SetVar(in, var, "", 0) == 0) {
Tcl_AppendResult(in, "couldn't store default value in variable \"",
var, "\"", (char *) 0);
return TCL_ERROR;
}
Tcl_SetResult(in, "0", TCL_STATIC);
}
return TCL_OK;
}
Tcl_ResetResult(in);
Tcl_AppendResult(in, "procedure \"", name,
"\" doesn't have an argument \"", arg, "\"", (char *) 0);
return TCL_ERROR;
}
return OTclErrBadVal(in, "a tcl method name", name);
}
static int
ListProcBody(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* name) {
Proc* proc = FindProc(table, name);
if (proc) {
Tcl_ResetResult(in);
#if TCL_MAJOR_VERSION< 8
Tcl_AppendResult(in, proc->command, 0);
#else
Tcl_AppendResult(in,
#if TCL_MINOR_VERSION == 0
TclGetStringFromObj(proc->bodyPtr, (int *)NULL),
#else
TclGetString(proc->bodyPtr),
#endif
0);
#endif
return TCL_OK;
}
return OTclErrBadVal(in, "a tcl method name", name);
}
/*
* object creation
*/
static void
PrimitiveOInit(void* mem, Tcl_Interp* in, CONST84 char* name, OTclClass* cl) {
OTclObject* obj = (OTclObject*)mem;
obj->teardown = in;
AddInstance(obj, cl);
obj->type = InObject(in);
obj->procs = 0;
/*
* fake callframe needed to interface to tcl variable
* manipulations. looks like one below global
*/
obj->variables.level = 1;
#if TCL_MAJOR_VERSION < 8
obj->variables.argc = 0;
obj->variables.argv = 0;
#else
obj->variables.numCompiledLocals = 0;
obj->variables.compiledLocals = 0;
#endif
obj->variables.callerPtr = 0;
obj->variables.callerVarPtr = 0;
#if TCL_MAJOR_VERSION >= 8
/* we need to deal with new members in CallFrame in Tcl8.0 */
obj->variables.isProcCallFrame = 1;
/* XXX: is it correct to assign global namespace here? */
obj->variables.nsPtr = ((Interp *)in)->globalNsPtr;
obj->variables.objc = 0;
obj->variables.objv = NULL; /* we don't want byte codes for now */
obj->variables.procPtr = (Proc *) ckalloc(sizeof(Proc));
obj->variables.procPtr->iPtr = (Interp *)in;
obj->variables.procPtr->refCount = 1;
/* XXX it correct to assign global namespace here? */
obj->variables.procPtr->cmdPtr = NULL;
obj->variables.procPtr->bodyPtr = NULL;
obj->variables.procPtr->numArgs = 0; /* actual argument count is set below. */
obj->variables.procPtr->numCompiledLocals = 0;
obj->variables.procPtr->firstLocalPtr = NULL;
obj->variables.procPtr->lastLocalPtr = NULL;
#ifdef TCL_VERSION_8_5_OR_HIGHER
obj->variables.clientData = NULL;
obj->variables.localCachePtr = NULL;
#endif
#endif
}
static void PrimitiveODestroyNoFree(ClientData cd);
static void
PrimitiveODestroy(ClientData cd) {
PrimitiveODestroyNoFree(cd);
ckfree((char*)cd);
}
static void
PrimitiveODestroyNoFree(ClientData cd) {
OTclObject* obj = (OTclObject*)cd;
Tcl_HashSearch hs;
Tcl_HashEntry* hp;
Tcl_HashSearch hs2;
Tcl_HashEntry* hp2;
Tcl_Interp* in;
/*
* check and latch against recurrent calls with obj->teardown
*/
if (!obj || !obj->teardown) return;
in = obj->teardown; obj->teardown = 0;
/*
* call and latch user destroy with obj->id if we haven't
*/
if (obj->id) {
CONST84 char* args[2] = { "", "destroy" };
Tcl_CmdInfo info;
/*
* but under 7.4p1 it is too late, so check with info
*/
args[0] = (char *) Tcl_GetCommandName(in, obj->id);
if (Tcl_GetCommandInfo(in, args[0], &info))
(void) OTclDispatch(cd, in, 2, args);
obj->id = 0;
}
/*
* resume the primitive teardown for procs and variables.
* variables unset here were lost from user destroy, and
* any trace error messages will be swallowed.
*/
if (obj->variables.varTablePtr == NULL) goto done;
hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
while (hp != 0) {
for (;;) {
Var* vp = Tcl_VarHashGetValue(hp);
if (!TclIsVarUndefined(vp)) break;
hp = Tcl_NextHashEntry(&hs);
if (hp == 0)
goto done;
}
if (hp != 0) {
char* name = Tcl_VarHashGetKey(ObjVarTablePtr(obj), hp);
(void)OTclUnsetInstVar(obj, in, name, TCL_LEAVE_ERR_MSG);
}
hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
}
done:
#ifdef TCL_VERSION_8_5_OR_HIGHER
#else
hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
while (hp != 0) {
/*
* We delete the hash table below so disassociate
* each remaining (undefined) var from its hash table entry.
* (Otherwise, tcl will later try to delete
* the already-freed hash table entry.)
*/
Var* vp = (Var*)Tcl_GetHashValue(hp);
vp->hPtr = 0;
hp = Tcl_NextHashEntry(&hs);
}
#endif
if (obj->variables.varTablePtr != NULL)
Tcl_DeleteHashTable(ObjVarTablePtr(obj));
hp2 = obj->procs ? Tcl_FirstHashEntry(obj->procs, &hs2) : 0;
for (; hp2 != 0; hp2 = Tcl_NextHashEntry(&hs2)) {
Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hp2);
ClientData cdest = cd;
if (co->clientData != 0) cdest = co->clientData;
if (co->deleteProc != 0) (*co->deleteProc)(co->deleteData);
ckfree((char*)co);
}
if (obj->procs) {
Tcl_DeleteHashTable(obj->procs); ckfree((char*)(obj->procs));
}
(void)RemoveInstance(obj, obj->cl);
#if TCL_MAJOR_VERSION >= 8
ckfree((char*)(obj->variables.procPtr));
ckfree((char*)(obj->variables.varTablePtr));
#endif
}
static OTclObject*
PrimitiveOCreate(Tcl_Interp* in, CONST84 char* name, OTclClass* cl) {
OTclObject* obj = (OTclObject*)ckalloc(sizeof(OTclObject));
#if TCL_MAJOR_VERSION < 8
if (obj != 0) {
PrimitiveOInit(obj, in, name, cl);
obj->id = Tcl_CreateCommand(in, name, OTclDispatch, (ClientData)obj,
PrimitiveODestroy);
}
#else
Tcl_VarHashInitialize(obj->variables.varTablePtr);
if (obj != 0) {
if (Tcl_IsVarHashInitialized(obj->variables.varTablePtr)) {
PrimitiveOInit(obj, in, name, cl);
obj->id = Tcl_CreateCommand(in, name, (Tcl_CmdProc *) OTclDispatch,
(ClientData)obj, PrimitiveODestroy);
} else {
ckfree((char *)obj);
obj = NULL;
}
}
#endif
return obj;
}
static void
PrimitiveCInit(void* mem, Tcl_Interp* in, CONST84 char* name, OTclClass* class) {
OTclObject* obj = (OTclObject*)mem;
OTclClass* cl = (OTclClass*)mem;
obj->type = InClass(in);
cl->super = 0;
cl->sub = 0;
AddSuper(cl, InObject(in));
cl->parent = InObject(in);
cl->color = WHITE;
cl->order = 0;
Tcl_InitHashTable(&cl->instprocs, TCL_STRING_KEYS);
Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS);
cl->objectdata = 0;
}
static void
PrimitiveCDestroy(ClientData cd) {
OTclClass* cl = (OTclClass*)cd;
OTclObject* obj = (OTclObject*)cd;
Tcl_HashSearch hSrch;
Tcl_HashEntry* hPtr;
Tcl_Interp* in;
/*
* check and latch against recurrent calls with obj->teardown
*/
if (!obj || !obj->teardown) return;
in = obj->teardown; obj->teardown = 0;
/*
* call and latch user destroy with obj->id if we haven't
*/
if (obj->id) {
CONST84 char* args[2] = { "", "destroy" };
Tcl_CmdInfo info;
/*
* but under 7.4p1 it is too late, so check with info
*/
args[0] = (char *) Tcl_GetCommandName(in, obj->id);
if (Tcl_GetCommandInfo(in, args[0], &info))
(void) OTclDispatch(cd, in, 2, args);
obj->id = 0;
}
/*
* resume the primitive teardown for instances and instprocs
*/
hPtr = Tcl_FirstHashEntry(&cl->instances, &hSrch);
while (hPtr) {
/*
* allow circularity for meta-classes
*/
OTclObject* inst;
for (;;) {
inst = (OTclObject*)Tcl_GetHashKey(&cl->instances, hPtr);
if (inst != (OTclObject*)cl) {
CONST84 char* name = (char *) Tcl_GetCommandName(inst->teardown, inst->id);
(void)Tcl_DeleteCommand(inst->teardown, name);
break;
}
hPtr = Tcl_NextHashEntry(&hSrch);
if (hPtr == 0)
goto done;
}
hPtr = Tcl_FirstHashEntry(&cl->instances, &hSrch);
}
done:
hPtr = Tcl_FirstHashEntry(&cl->instprocs, &hSrch);
for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
/* for version 8 the instprocs are registered, so no need to delete them (?) */
Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
ClientData cdest = cd;
if (co->clientData != 0) cdest = co->clientData;
if (co->deleteProc != 0) (*co->deleteProc)(co->deleteData);
ckfree((char*)co);
}
Tcl_DeleteHashTable(&cl->instprocs);
if (cl->objectdata) {
Tcl_DeleteHashTable(cl->objectdata);
ckfree((char*)(cl->objectdata)); cl->objectdata = 0;
}
/*
* flush all caches, unlink superclasses
*/
FlushPrecedences(cl);
while (cl->super) (void)RemoveSuper(cl, cl->super->cl);
while (cl->sub) (void)RemoveSuper(cl->sub->cl, cl);
/*
* handoff the primitive teardown
*/
obj->teardown = in;
/* don't want to free the memory since we need to
* delete the hash table later, because we want the
* PrimitiveODestory to destory the hash entries first */
PrimitiveODestroyNoFree(cd);
Tcl_DeleteHashTable(&cl->instances);
ckfree((char*)cd);
}
static OTclClass*
PrimitiveCCreate(Tcl_Interp* in, CONST84 char* name, OTclClass* class){
OTclClass* cl = (OTclClass*)ckalloc(sizeof(OTclClass));
#if TCL_MAJOR_VERSION < 8
if (cl != 0) {
OTclObject* obj = (OTclObject*)cl;
PrimitiveOInit(obj, in, name, class);
PrimitiveCInit(cl, in, name, class);
obj->id = Tcl_CreateCommand(in, name, OTclDispatch, (ClientData)cl,
PrimitiveCDestroy);
}
#else
Tcl_VarHashInitialize(cl->object.variables.varTablePtr);
if (cl != 0) {
if (Tcl_IsVarHashInitialized(cl->object.variables.varTablePtr)) {
OTclObject* obj = &cl->object;
PrimitiveOInit(obj, in, name, class);
PrimitiveCInit(cl, in, name, class);
obj->id = Tcl_CreateCommand(in, name, (Tcl_CmdProc *) OTclDispatch,
(ClientData)cl, PrimitiveCDestroy);
} else {
ckfree((char *)cl);
cl = NULL;
}
}
#endif
return cl;
}
/*
* object method implementations
*/
static int
OTclOAllocMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclClass* cl = OTclAsClass(in, cd);
OTclObject* newobj;
int i;
if (!cl) return OTclErrType(in, argv[0], "Class");
if (argc < 5) return OTclErrArgCnt(in, argv[0], "alloc ?args?");
newobj = PrimitiveOCreate(in, argv[4], cl);
if (newobj == 0) return OTclErrMsg(in,"Object alloc failed", TCL_STATIC);
/*
* this alloc doesn't process any extra args, so return them all
*/
Tcl_ResetResult(in);
for (i = 5; i < argc; i++) Tcl_AppendElement(in, argv[i]);
return TCL_OK;
}
static int
OTclOInitMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
int i;
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc < 4) return OTclErrArgCnt(in, argv[0], "init ?args?");
if (argc & 1) return OTclErrMsg(in, "uneven number of args", TCL_STATIC);
for (i=4; ivariables.varTablePtr == NULL) goto done;
hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
while (hp != 0) {
for (;;) {
Var* vp = Tcl_VarHashGetValue(hp);
if (!TclIsVarUndefined(vp)) break;
hp = Tcl_NextHashEntry(&hs);
if (hp == 0)
goto done;
}
if (hp != 0) {
CONST84 char* name = Tcl_VarHashGetKey(ObjVarTablePtr(obj), hp);
result = OTclUnsetInstVar(obj, in, name, TCL_LEAVE_ERR_MSG);
if (result != TCL_OK) break;
}
hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
}
if (hp != 0) return TCL_ERROR;
done:
/*
* latch, and call delete command if not already in progress
*/
oid = obj->id; obj->id = 0;
if (obj->teardown != 0) {
CONST84 char* name = (char *) Tcl_GetCommandName(in, oid);
return (Tcl_DeleteCommand(in, name) == 0) ? TCL_OK : TCL_ERROR;
}
Tcl_ResetResult(in);
return TCL_OK;
}
static int
OTclOClassMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
OTclClass* cl;
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc != 5) return OTclErrArgCnt(in, argv[0], "class ");
/*
* allow a change to any class; type system enforces safety later
*/
cl = OTclGetClass(in, argv[4]);
if (!cl) return OTclErrBadVal(in, "a class", argv[4]);
(void)RemoveInstance(obj, obj->cl);
AddInstance(obj, cl);
return TCL_OK;
}
static int OTclCInfoMethod(ClientData, Tcl_Interp*, int, CONST84 char*[]);
static int
OTclOInfoMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc < 5) return OTclErrArgCnt(in,argv[0],"info ?args?");
if (!strcmp(argv[4], "class")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info class ?class?");
if (argc == 5) {
Tcl_SetResult(in, (char *)Tcl_GetCommandName(in, obj->cl->object.id),
TCL_VOLATILE);
} else {
int result;
CONST84 char* saved = argv[4];
argv[4] = "superclass";
result = OTclCInfoMethod((ClientData)obj->cl, in, argc, argv);
argv[4] = saved;
return result;
}
} else if (!strcmp(argv[4], "commands")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info commands ?pat?");
ListKeys(in, obj->procs, (argc == 6) ? argv[5] : 0, 0);
} else if (!strcmp(argv[4], "procs")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info procs ?pat?");
ListProcKeys(in, obj->procs, (argc == 6) ? argv[5] : 0);
} else if (!strcmp(argv[4], "args")) {
if (argc != 6) return OTclErrArgCnt(in,argv[0],"info args ");
return ListProcArgs(in, obj->procs, argv[5]);
} else if (!strcmp(argv[4], "default")) {
if (argc != 8)
return OTclErrArgCnt(in,argv[0],"info default ");
return ListProcDefault(in, obj->procs, argv[5], argv[6], argv[7]);
} else if (!strcmp(argv[4], "body")) {
if (argc != 6) return OTclErrArgCnt(in,argv[0],"info body ");
return ListProcBody(in, obj->procs, argv[5]);
} else if (!strcmp(argv[4], "vars")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info vars ?pat?");
ListKeys(in, ObjVarTablePtr(obj), (argc == 6) ? argv[5] : 0, 1);
} else {
return OTclErrBadVal(in, "an info option", argv[4]);
}
return TCL_OK;
}
static int
OTclOProcMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
Tcl_CmdInfo proc;
int op;
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc != 7) return OTclErrArgCnt(in,argv[0],"proc name args body");
/*
* if the args list is "auto", the body is a script to load the proc
*/
if (!strcmp("auto", argv[5])) op = MakeAuto(&proc, argv[6]);
else if (argv[5][0]==0 && argv[6][0]==0) op = -1;
else op = MakeProc(&proc,in, argc-3, argv+3);
if (!obj->procs) {
obj->procs = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(obj->procs, TCL_STRING_KEYS);
}
(void)RemoveMethod(obj->procs, argv[4], (ClientData)obj);
if (op == 1) AddMethod(obj->procs, argv[4], proc.proc,
#ifdef TCL_VERSION_8_5_OR_HIGHER
proc.clientData, proc.objClientData, proc.deleteProc, proc.deleteData);
#else
proc.clientData, NULL, proc.deleteProc, proc.deleteData);
#endif
return (op != 0) ? TCL_OK : TCL_ERROR;
}
static int
OTclONextMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
CONST84 char* class = (char *) Tcl_GetVar(in, "class",0);
CONST84 char* method = (char *) Tcl_GetVar(in, "proc",0);
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc < 4) return OTclErrArgCnt(in, argv[0], "next ?args?");
if (!method||!class) return OTclErrMsg(in,"no executing proc", TCL_STATIC);
argv[2] = class;
argv[3] = method;
return OTclNextMethod(obj, in, argc, argv);
}
static int
OTclOSetMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
CONST84 char* result;
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc<5 || argc>6) return OTclErrArgCnt(in, argv[0], "set var ?value?");
if (argc == 6)
result = OTclSetInstVar(obj, in, argv[4], argv[5], TCL_LEAVE_ERR_MSG);
else
result = OTclGetInstVar(obj, in, argv[4], TCL_LEAVE_ERR_MSG);
if (result != 0) Tcl_SetResult(in, (char *)result, TCL_VOLATILE);
return (result != 0) ? TCL_OK : TCL_ERROR;
}
static int
OTclOUnsetMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclObject* obj = OTclAsObject(in, cd);
int result = TCL_ERROR;
int i;
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc < 5) return OTclErrArgCnt(in, argv[0], "unset ?vars?");
for (i=4; i
*/
if (iPtr->varFramePtr) {
CallFrame* saved = iPtr->varFramePtr->callerVarPtr;
int level = iPtr->varFramePtr->level;
iPtr->varFramePtr->callerVarPtr = &obj->variables;
iPtr->varFramePtr->level = obj->variables.level+1;
result = Tcl_UpVar(in, frameName, varName, localName, flags);
iPtr->varFramePtr->callerVarPtr = saved;
iPtr->varFramePtr->level = level;
} else {
Tcl_SetResult(in, "no instvar in global :: scope", TCL_STATIC);
}
return result;
}
static int
OTclOInstVarMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[])
{
OTclObject* obj = OTclAsObject(in, cd);
int i;
int result = TCL_ERROR;
if (!obj) return OTclErrType(in, argv[0], "Object");
if (argc < 5) return OTclErrArgCnt(in, argv[0], "instvar ?vars?");
for (i=4; i ?args?");
newcl = PrimitiveCCreate(in, argv[4], cl);
if (newcl == 0) return OTclErrMsg(in,"Class alloc failed", TCL_STATIC);
/*
* this alloc doesn't process any extra args, so return them all
*/
Tcl_ResetResult(in);
for (i = 5; i < argc; i++) Tcl_AppendElement(in, argv[i]);
return TCL_OK;
}
static int
OTclCCreateMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclClass* cl = OTclAsClass(in, cd);
OTclObject* obj;
Tcl_CmdProc* proc = 0;
ClientData cp = 0;
OTclClasses* pl;
CONST84 char* args[4];
int result;
int i;
if (!cl) return OTclErrType(in, argv[0], "Class");
if (argc < 5) return OTclErrArgCnt(in, argv[0], "create ?args?");
for (pl = ComputePrecedence(cl); pl != 0; pl = pl->next) {
Tcl_HashTable* procs = pl->cl->object.procs;
if (procs && LookupMethod(procs,"alloc",&proc,&cp,0)) break;
}
if (!pl) return OTclErrMsg(in, "no reachable alloc", TCL_STATIC);
for (i=0; i<4; i++) args[i] = argv[i];
argv[0] = (char *) Tcl_GetCommandName(in, pl->cl->object.id);
argv[1] = argv[0];
argv[2] = "";
argv[3] = "alloc";
cp = (cp != 0) ? cp : (ClientData)pl->cl;
result = (*proc)(cp, in, argc, (const char **) argv);
for (i=0; i<4; i++) argv[i] = args[i];
if (result != TCL_OK) return result;
obj = OTclGetObject(in, argv[4]);
if (obj == 0)
return OTclErrMsg(in, "couldn't find result of alloc", TCL_STATIC);
(void)RemoveInstance(obj, obj->cl);
AddInstance(obj, cl);
result = Tcl_VarEval(in, argv[4], " init ", in->result, 0);
if (result != TCL_OK) return result;
Tcl_SetResult(in, (char *)argv[4], TCL_VOLATILE);
return TCL_OK;
}
static int
OTclCSuperClassMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclClass* cl = OTclAsClass(in, cd);
OTclClasses* osl = 0;
int ac = 0;
CONST84 char** av = 0;
OTclClass** scl = 0;
int reversed = 0;
int i, j;
if (!cl) return OTclErrType(in, argv[0], "Class");
if (argc != 5) return OTclErrArgCnt(in, argv[0], "superclass ");
if (Tcl_SplitList(in, argv[4], &ac, (const char ***) &av) != TCL_OK)
return TCL_ERROR;
scl = (OTclClass**)ckalloc(ac*sizeof(OTclClass*));
for (i = 0; i < ac; i++) {
scl[i] = OTclGetClass(in, av[i]);
if (!scl[i]) {
/*
* try to force autoloading if we can't resolve a class name
*/
int loaded = 0;
char* args = (char*)ckalloc(strlen("auto_load ")+strlen(av[i])+1);
(void)strcpy(args, "auto_load ");
(void) strcat(args, av[i]);
if (Tcl_Eval(in, args) == TCL_OK) {
scl[i] = OTclGetClass(in, av[i]);
loaded = (scl[i] != 0);
}
ckfree(args);
if (!loaded) {
ckfree((char*)av);
ckfree((char*)scl);
return OTclErrBadVal(in, "a list of classes", argv[4]);
}
}
}
/*
* check that superclasses don't precede their classes
*/
for (i = 0; i < ac; i++) {
if (reversed != 0) break;
for (j = i+1; j < ac; j++) {
OTclClasses* dl = ComputePrecedence(scl[j]);
if (reversed != 0) break;
while (dl != 0) {
if (dl->cl == scl[i]) break;
dl = dl->next;
}
if (dl != 0) reversed = 1;
}
}
if (reversed != 0) {
ckfree((char*)av);
ckfree((char*)scl);
return OTclErrBadVal(in, "classes in dependence order", argv[4]);
}
while (cl->super != 0) {
/*
* build up an old superclass list in case we need to revert
*/
OTclClass* sc = cl->super->cl;
OTclClasses* l = osl;
osl = (OTclClasses*)ckalloc(sizeof(OTclClasses));
osl->cl = sc;
osl->next = l;
(void)RemoveSuper(cl, cl->super->cl);
}
for (i = 0; i < ac; i++)
AddSuper(cl, scl[i]);
ckfree((char*)av);
ckfree((char*)scl);
FlushPrecedences(cl);
if (!ComputePrecedence(cl)) {
/*
* cycle in the superclass graph, backtrack
*/
OTclClasses* l;
while (cl->super != 0) (void)RemoveSuper(cl, cl->super->cl);
for (l = osl; l != 0; l = l->next) AddSuper(cl, l->cl);
RC(osl);
return OTclErrBadVal(in, "a cycle-free graph", argv[4]);
}
RC(osl);
Tcl_ResetResult(in);
return TCL_OK;
}
static int
OTclCInfoMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclClass* cl = OTclAsClass(in, cd);
if (!cl) return OTclErrType(in, argv[0], "Class");
if (argc < 5) return OTclErrArgCnt(in,argv[0],"info ?args?");
if (!strcmp(argv[4], "superclass")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info superclass ?class?");
if (argc == 5) {
OTclClasses* sl = cl->super;
OTclClasses* sc = 0;
/*
* reverse the list to obtain presentation order
*/
Tcl_ResetResult(in);
while (sc != sl) {
OTclClasses* nl = sl;
while (nl->next != sc) nl = nl->next;
Tcl_AppendElement(in, Tcl_GetCommandName(in, nl->cl->object.id));
sc = nl;
}
} else {
OTclClass* isc = OTclGetClass(in, argv[5]);
OTclClasses* pl;
if (isc == 0) return OTclErrBadVal(in, "a class", argv[5]);
pl = ComputePrecedence(cl);
/*
* search precedence to see if we're related or not
*/
while (pl != 0) {
if (pl->cl == isc) {
Tcl_SetResult(in, "1", TCL_STATIC);
break;
}
pl = pl->next;
}
if (pl == 0) Tcl_SetResult(in, "0", TCL_STATIC);
}
} else if (!strcmp(argv[4], "subclass")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info subclass ?class?");
if (argc == 5) {
OTclClasses* sl = cl->sub;
OTclClasses* sc = 0;
/*
* order unimportant
*/
Tcl_ResetResult(in);
for (sc = sl; sc != 0; sc = sc->next)
Tcl_AppendElement(in, Tcl_GetCommandName(in, sc->cl->object.id));
} else {
OTclClass* isc = OTclGetClass(in, argv[5]);
OTclClasses* pl;
OTclClasses* saved;
if (isc == 0) return OTclErrBadVal(in, "a class", argv[5]);
saved = cl->order; cl->order = 0;
pl = ComputeDependents(cl);
/*
* search precedence to see if we're related or not
*/
while (pl != 0) {
if (pl->cl == isc) {
Tcl_SetResult(in, "1", TCL_STATIC);
break;
}
pl = pl->next;
}
if (pl == 0) Tcl_SetResult(in, "0", TCL_STATIC);
RC(cl->order); cl->order = saved;
}
} else if (!strcmp(argv[4], "heritage")) {
OTclClasses* pl = ComputePrecedence(cl);
CONST84 char* pattern = (argc == 6) ? argv[5] : 0;
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info heritage ?pat?");
if (pl) pl = pl->next;
Tcl_ResetResult(in);
for (; pl != 0; pl = pl->next) {
CONST84 char* name = (char *) Tcl_GetCommandName(in, pl->cl->object.id);
if (pattern && !Tcl_StringMatch(name, pattern)) continue;
Tcl_AppendElement(in, name);
}
} else if (!strcmp(argv[4], "instances")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info instances ?pat?");
ListInstanceKeys(in, &cl->instances, (argc == 6) ? argv[5] : 0);
} else if (!strcmp(argv[4], "instcommands")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info instcommands ?pat?");
ListKeys(in, &cl->instprocs, (argc == 6) ? argv[5] : 0, 0);
} else if (!strcmp(argv[4], "instprocs")) {
if (argc > 6) return OTclErrArgCnt(in,argv[0],"info instprocs ?pat?");
ListProcKeys(in, &cl->instprocs, (argc == 6) ? argv[5] : 0);
} else if (!strcmp(argv[4], "instargs")) {
if (argc != 6) return OTclErrArgCnt(in,argv[0],"info instargs ");
return ListProcArgs(in, &cl->instprocs, argv[5]);
} else if (!strcmp(argv[4], "instdefault")) {
if (argc != 8)
return OTclErrArgCnt(in,argv[0],
"info instdefault ");
return ListProcDefault(in, &cl->instprocs, argv[5], argv[6], argv[7]);
} else if (!strcmp(argv[4], "instbody")) {
if (argc != 6) return OTclErrArgCnt(in,argv[0],"info instbody ");
return ListProcBody(in, &cl->instprocs, argv[5]);
} else {
return OTclOInfoMethod(cd, in, argc, argv);
}
return TCL_OK;
}
static int
OTclCInstProcMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclClass* cl = OTclAsClass(in, cd);
Tcl_CmdInfo proc;
int op;
if (!cl) return OTclErrType(in, argv[0], "Class");
if (argc != 7) return OTclErrArgCnt(in,argv[0],"instproc name args body");
/*
* if the args list is "auto", the body is a script to load the proc
*/
if (!strcmp("auto", argv[5])) op = MakeAuto(&proc, argv[6]);
else if (argv[5][0]==0 && argv[6][0]==0) op = -1;
else op = MakeProc(&proc,in, argc-3, argv+3);
(void)RemoveMethod(&cl->instprocs, argv[4], (ClientData)cl);
if (op == 1) AddMethod(&cl->instprocs, argv[4], proc.proc,
#ifdef TCL_VERSION_8_5_OR_HIGHER
proc.clientData, proc.objClientData, proc.deleteProc, proc.deleteData);
#else
proc.clientData, NULL, proc.deleteProc, proc.deleteData);
#endif
return (op != 0) ? TCL_OK : TCL_ERROR;
}
/*
* C interface routines for manipulating objects and classes
*/
extern OTclObject*
OTclAsObject(Tcl_Interp* in, ClientData cd) {
OTclObject* obj = (OTclObject*)cd;
return IsType(obj, InObject(in)) ? obj : 0;
}
extern OTclClass*
OTclAsClass(Tcl_Interp* in, ClientData cd) {
OTclClass* cl = (OTclClass*)cd;
return IsType((OTclObject*)cl, InClass(in)) ? cl : 0;
}
extern OTclObject*
OTclGetObject(Tcl_Interp* in, CONST84 char* name) {
Tcl_CmdInfo info;
OTclObject* obj = 0;
if (Tcl_GetCommandInfo(in, name, &info))
if (info.proc == (Tcl_CmdProc *) OTclDispatch)
obj = OTclAsObject(in, info.clientData);
return obj;
}
extern OTclClass*
OTclGetClass(Tcl_Interp* in, CONST84 char* name) {
Tcl_CmdInfo info;
OTclClass* cl = 0;
if (Tcl_GetCommandInfo(in, name, &info))
if (info.proc == (Tcl_CmdProc *) OTclDispatch)
cl = OTclAsClass(in, info.clientData);
return cl;
}
extern OTclObject*
OTclCreateObject(Tcl_Interp* in, CONST84 char* name, OTclClass* cl) {
CONST84 char* args[3];
args[0] = (char *) Tcl_GetCommandName(in, cl->object.id);
args[1] = "create";
args[2] = name;
if (OTclDispatch((ClientData)cl,in,3,args) != TCL_OK) return 0;
return OTclGetObject(in, name);
}
extern OTclClass*
OTclCreateClass(Tcl_Interp* in, CONST84 char* name, OTclClass* cl){
CONST84 char* args[3];
args[0] = (char *) Tcl_GetCommandName(in, cl->object.id);
args[1] = "create";
args[2] = name;
if (OTclDispatch((ClientData)cl,in,3,args) != TCL_OK) return 0;
return OTclGetClass(in, name);
}
extern int
OTclDeleteObject(Tcl_Interp* in, OTclObject* obj) {
CONST84 char* args[2];
args[0] = (char *) Tcl_GetCommandName(in, obj->id);
args[1] = "destroy";
return OTclDispatch((ClientData)obj, in, 2, args);
}
extern int
OTclDeleteClass(Tcl_Interp* in, OTclClass* cl) {
CONST84 char* args[2];
args[0] = (char *) Tcl_GetCommandName(in, cl->object.id);
args[1] = "destroy";
return OTclDispatch((ClientData)cl, in, 2, args);
}
extern void
OTclAddPMethod(OTclObject* obj, char* nm, Tcl_CmdProc* proc,
ClientData cd, Tcl_CmdDeleteProc* dp)
{
if (obj->procs)
(void)RemoveMethod(obj->procs, nm, (ClientData)obj);
else {
obj->procs = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(obj->procs, TCL_STRING_KEYS);
}
AddMethod(obj->procs, nm, proc, cd, NULL, dp, cd);
}
extern void
OTclAddIMethod(OTclClass* cl, char* nm, Tcl_CmdProc* proc,
ClientData cd, Tcl_CmdDeleteProc* dp)
{
(void)RemoveMethod(&cl->instprocs, nm, (ClientData)cl);
AddMethod(&cl->instprocs, nm, proc, cd, NULL, dp, cd);
}
extern int
OTclRemovePMethod(OTclObject* obj, char* nm) {
if (obj->procs) return RemoveMethod(obj->procs, nm, (ClientData)obj);
else return 0;
}
extern int
OTclRemoveIMethod(OTclClass* cl, char* nm) {
return RemoveMethod(&cl->instprocs, nm, (ClientData)cl);
}
extern int
OTclNextMethod(OTclObject* obj, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
OTclClass* cl = 0;
OTclClass* ncl;
OTclClasses* pl;
Tcl_CmdProc* proc = 0;
ClientData cp = 0;
CONST84 char* class = argv[2];
int result = TCL_OK;
if (class[0]){
cl = OTclGetClass(in, class);
if (!cl) return OTclErrBadVal(in, "a class", class);
}
/*
* if we are already in the precedence ordering, then advance
* past our last point; otherwise (if cl==0) start from the start
*/
pl = ComputePrecedence(obj->cl);
while (pl && cl) {
if (pl->cl == cl) cl = 0;
pl = pl->next;
}
/*
* search for a further class method and patch args before launching.
* if no further method, return without error.
*/
ncl = SearchCMethod(pl, argv[3], &proc, &cp, 0);
if (proc != 0) {
cp = (cp != 0) ? cp : (ClientData)obj;
argv[2] = (char *) Tcl_GetCommandName(in, ncl->object.id);
result = (*proc)(cp, in, argc, (const char **) argv);
argv[2] = class;
}
return result;
}
extern CONST84_RETURN char*
OTclSetInstVar(OTclObject* obj,Tcl_Interp* in,
CONST84 char* name, CONST84 char* value,int flgs){
Interp* iPtr = (Interp*)in;
CallFrame* saved = iPtr->varFramePtr;
CONST84 char* result;
iPtr->varFramePtr = &obj->variables;
result = (char *) Tcl_SetVar(in, name, value, flgs);
iPtr->varFramePtr = saved;
return result;
}
extern CONST84_RETURN char*
OTclGetInstVar(OTclObject* obj, Tcl_Interp* in, CONST84 char* name, int flgs){
Interp* iPtr = (Interp*)in;
CallFrame* saved = iPtr->varFramePtr;
CONST84 char* result;
iPtr->varFramePtr = &obj->variables;
result = (char *) Tcl_GetVar(in, name, flgs);
iPtr->varFramePtr = saved;
return result;
}
extern int
OTclUnsetInstVar(OTclObject* obj, Tcl_Interp* in, CONST84 char* name, int flgs) {
Interp* iPtr = (Interp*)in;
CallFrame* saved = iPtr->varFramePtr;
int result;
iPtr->varFramePtr = &obj->variables;
result = Tcl_UnsetVar(in, name, flgs);
iPtr->varFramePtr = saved;
return result;
}
extern void
OTclSetObjectData(OTclObject* obj, OTclClass* cl, ClientData data) {
Tcl_HashEntry *hPtr;
int nw;
if (!cl->objectdata) {
cl->objectdata = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(cl->objectdata, TCL_ONE_WORD_KEYS);
}
hPtr = Tcl_CreateHashEntry(cl->objectdata, (char*)obj, &nw);
Tcl_SetHashValue(hPtr, data);
}
extern int
OTclGetObjectData(OTclObject* obj, OTclClass* cl, ClientData* data) {
Tcl_HashEntry *hPtr;
if (!cl->objectdata) return 0;
hPtr = Tcl_FindHashEntry(cl->objectdata, (char*)obj);
if (data) *data = hPtr ? Tcl_GetHashValue(hPtr) : 0;
return (hPtr != 0);
}
extern int
OTclUnsetObjectData(OTclObject* obj, OTclClass* cl) {
Tcl_HashEntry *hPtr;
if (!cl->objectdata) return 0;
hPtr = Tcl_FindHashEntry(cl->objectdata, (char*)obj);
if (hPtr) Tcl_DeleteHashEntry(hPtr);
return (hPtr != 0);
}
/*
* Tcl extension initialization routine
*/
#define MAXTCLPROC 4096
extern int
Otcl_Init(Tcl_Interp* in) {
OTclClass* theobj = 0;
OTclClass* thecls = 0;
Tcl_HashEntry* hp1;
Tcl_HashEntry* hp2;
int nw1;
int nw2;
char tm[MAXTCLPROC];
#if TCL_MAJOR_VERSION >= 8
Tcl_Namespace *namespacePtr;
#endif
/*
* discover Tcl's hidden proc interpreter
*/
if (ProcInterpId == 0) {
char* args[4];
#if TCL_MAJOR_VERSION >= 8
int i;
int res = 0;
Tcl_Obj* objv[4];
#endif
args[0]="proc"; args[1]="_fake_"; args[2]=""; args[3]="return";
#if TCL_MAJOR_VERSION < 8
if (Tcl_ProcCmd(0, in, 4, args) == TCL_OK) {
Tcl_CmdInfo info;
if (Tcl_GetCommandInfo(in, args[1], &info)) {
ProcInterpId = info.proc;
(void)Tcl_DeleteCommand(in, args[1]);
} else return OTclErrMsg(in, "proc failed", TCL_STATIC);
} else return TCL_ERROR;
#else /*TCL_MAJOR_VERSION >= 8*/
for (i = 0; i < 4; i++) {
objv[i] = Tcl_NewStringObj(args[i], -1);
Tcl_IncrRefCount(objv[i]);
}
if (Tcl_ProcObjCmd(0, in, 4, objv) == TCL_OK) {
Tcl_CmdInfo info;
if (Tcl_GetCommandInfo(in, args[1], &info)) {
ProcInterpId = info.proc;
(void)Tcl_DeleteCommand(in, args[1]);
} else
res = 1;
} else
res = 2;
for (i = 0; i < 4; i++)
Tcl_DecrRefCount(objv[i]);
switch (res) {
case 1: return OTclErrMsg(in, "proc failed", TCL_STATIC);
case 2: return TCL_ERROR;
}
#endif /*TCL_MAJOR_VERSION >= 8*/
}
/*
* bootstrap the tables of base objects and classes
*/
if (theObjects == 0) {
theObjects = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
if (!theObjects) return OTclErrMsg(in, "Object table failed", TCL_STATIC);
Tcl_InitHashTable(theObjects, TCL_ONE_WORD_KEYS);
}
if (theClasses == 0) {
theClasses = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
if (!theClasses) return OTclErrMsg(in, "Class table failed", TCL_STATIC);
Tcl_InitHashTable(theClasses, TCL_ONE_WORD_KEYS);
}
hp1 = Tcl_CreateHashEntry(theObjects, (char*)in, &nw1);
if (nw1) theobj = PrimitiveCCreate(in, "Object", 0);
hp2 = Tcl_CreateHashEntry(theClasses, (char*)in, &nw2);
if (nw2) thecls = PrimitiveCCreate(in, "Class", 0);
if (!nw1 && !nw2) {
Tcl_SetResult(in, "0", TCL_STATIC);
return TCL_OK;
} else if (!theobj || !thecls) {
if (theobj) PrimitiveCDestroy((ClientData)theobj);
if (thecls) PrimitiveCDestroy((ClientData)thecls);
return OTclErrMsg(in, "Object/Class failed", TCL_STATIC);
}
Tcl_SetHashValue(hp1, (char*)theobj);
Tcl_SetHashValue(hp2, (char*)thecls);
theobj->object.type = thecls;
theobj->parent = 0;
thecls->object.type = thecls;
thecls->parent = theobj;
AddInstance((OTclObject*)theobj, thecls);
AddInstance((OTclObject*)thecls, thecls);
AddSuper(thecls, theobj);
#if TCL_MAJOR_VERSION >= 8
/* create the otcl namespace of otcl instprocs and procs */
namespacePtr = Tcl_CreateNamespace(in, "otcl", (ClientData) NULL,
(Tcl_NamespaceDeleteProc *) NULL);
if (namespacePtr==NULL)
return OTclErrMsg(in, "creation of name space failed", TCL_STATIC);
#endif
/*
* and fill them with functionality
*/
OTclAddPMethod((OTclObject*)theobj, "alloc", (Tcl_CmdProc *) OTclOAllocMethod, 0, 0);
OTclAddIMethod(theobj, "init", (Tcl_CmdProc *) OTclOInitMethod, 0, 0);
OTclAddIMethod(theobj, "destroy", (Tcl_CmdProc *) OTclODestroyMethod, 0, 0);
OTclAddIMethod(theobj, "class", (Tcl_CmdProc *) OTclOClassMethod, 0, 0);
OTclAddIMethod(theobj, "info", (Tcl_CmdProc *) OTclOInfoMethod, 0, 0);
OTclAddIMethod(theobj, "proc", (Tcl_CmdProc *) OTclOProcMethod, 0, 0);
OTclAddIMethod(theobj, "next", (Tcl_CmdProc *) OTclONextMethod, 0, 0);
OTclAddIMethod(theobj, "set", (Tcl_CmdProc *) OTclOSetMethod, 0, 0);
OTclAddIMethod(theobj, "unset", (Tcl_CmdProc *) OTclOUnsetMethod, 0, 0);
OTclAddIMethod(theobj, "instvar", (Tcl_CmdProc *) OTclOInstVarMethod, 0, 0);
OTclAddPMethod((OTclObject*)thecls, "alloc", (Tcl_CmdProc *) OTclCAllocMethod, 0, 0);
OTclAddIMethod(thecls, "create", (Tcl_CmdProc *) OTclCCreateMethod, 0, 0);
OTclAddIMethod(thecls, "superclass", (Tcl_CmdProc *) OTclCSuperClassMethod, 0, 0);
OTclAddIMethod(thecls, "info", (Tcl_CmdProc *) OTclCInfoMethod, 0, 0);
OTclAddIMethod(thecls, "instproc", (Tcl_CmdProc *) OTclCInstProcMethod, 0, 0);
/*
* with some methods and library procs in tcl - they could go in a
* otcl.tcl file, but they're embedded here with Tcl_Eval to avoid
* the need to carry around a separate library.
*/
(void)strcpy(tm, "Object instproc array {opt ary args} { \n");
(void)strcat(tm, " $self instvar $ary \n");
(void)strcat(tm, " eval array [list $opt] [list $ary] $args \n");
(void)strcat(tm, "} \n");
if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
(void)strcpy(tm, "Class instproc unknown {m args} { \n");
(void)strcat(tm, " if {$m == {create}} then { \n");
(void)strcat(tm, " error \"$self: unable to dispatch $m\" \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " eval [list $self] create [list $m] $args \n");
(void)strcat(tm, "} \n");
if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
(void)strcpy(tm, "proc otcl_load {obj file} { \n");
(void)strcat(tm, " global auto_index \n");
(void)strcat(tm, " source $file \n");
(void)strcat(tm, " foreach i [array names auto_index \\\n");
(void)strcat(tm, " [list $obj *proc *]] { \n");
(void)strcat(tm, " set type [lindex $i 1] \n");
(void)strcat(tm, " set meth [lindex $i 2] \n");
(void)strcat(tm, " if {[$obj info ${type}s $meth] == {}} then { \n");
(void)strcat(tm, " $obj $type $meth {auto} $auto_index($i) \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " } \n");
if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
(void)strcpy(tm, "proc otcl_mkindex {meta dir args} { \n");
(void)strcat(tm, " set sp {[ ]+} \n");
(void)strcat(tm, " set st {^[ ]*} \n");
(void)strcat(tm, " set wd {([^ ]+)} \n");
(void)strcat(tm, " foreach creator $meta { \n");
(void)strcat(tm, " lappend cp \"$st$creator${sp}create$sp$wd\" \n");
(void)strcat(tm, " lappend ap \"$st$creator$sp$wd\" \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " foreach method {proc instproc} { \n");
(void)strcat(tm, " lappend mp \"$st$wd${sp}($method)$sp$wd\" \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " foreach cl [concat Class [Class info heritage]] {\n");
(void)strcat(tm, " eval lappend meths [$cl info instcommands] \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " set old [pwd] \n");
(void)strcat(tm, " cd $dir \n");
(void)strcat(tm, " append idx \"# Tcl autoload index file, \" \n");
(void)strcat(tm, " append idx \"version 2.0\\n\" \n");
(void)strcat(tm, " append idx \"# otcl additions generated with \" \n");
(void)strcat(tm, " append idx \"\\\"otcl_mkindex [list $meta] \" \n");
(void)strcat(tm, " append idx \"[list $dir] $args\\\"\\n\" \n");
(void)strcat(tm, " set oc 0 \n");
(void)strcat(tm, " set mc 0 \n");
(void)strcat(tm, " foreach file [eval glob -nocomplain -- $args] { \n");
(void)strcat(tm, " if {[catch {set f [open $file]} msg]} then { \n");
(void)strcat(tm, " catch {close $f} \n");
(void)strcat(tm, " cd $old \n");
(void)strcat(tm, " error $msg \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " while {[gets $f line] >= 0} { \n");
(void)strcat(tm, " foreach c $cp { \n");
(void)strcat(tm, " if {[regexp $c $line x obj]==1 && \n");
(void)strcat(tm, " [string index $obj 0]!={$}} then { \n");
(void)strcat(tm, " incr oc \n");
(void)strcat(tm, " append idx \"set auto_index($obj) \" \n");
(void)strcat(tm, " append idx \"\\\"otcl_load $obj \" \n");
(void)strcat(tm, " append idx \"\\$dir/$file\\\"\\n\" \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " foreach a $ap { \n");
(void)strcat(tm, " if {[regexp $a $line x obj]==1 && \n");
(void)strcat(tm, " [string index $obj 0]!={$} && \n");
(void)strcat(tm, " [lsearch -exact $meths $obj]==-1} { \n");
(void)strcat(tm, " incr oc \n");
(void)strcat(tm, " append idx \"set auto_index($obj) \" \n");
(void)strcat(tm, " append idx \"\\\"otcl_load $obj \" \n");
(void)strcat(tm, " append idx \"\\$dir/$file\\\"\\n\" \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " foreach m $mp { \n");
(void)strcat(tm, " if {[regexp $m $line x obj ty pr]==1 && \n");
(void)strcat(tm, " [string index $obj 0]!={$} && \n");
(void)strcat(tm, " [string index $pr 0]!={$}} then { \n");
(void)strcat(tm, " incr mc \n");
(void)strcat(tm, " append idx \"set \\{auto_index($obj \" \n");
(void)strcat(tm, " append idx \"$ty $pr)\\} \\\"source \" \n");
(void)strcat(tm, " append idx \"\\$dir/$file\\\"\\n\" \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " close $f \n");
(void)strcat(tm, " } \n");
(void)strcat(tm, " set t [open tclIndex a+] \n");
(void)strcat(tm, " puts $t $idx nonewline \n");
(void)strcat(tm, " close $t \n");
(void)strcat(tm, " cd $old \n");
(void)strcat(tm, " return \"$oc objects, $mc methods\" \n");
(void)strcat(tm, "} \n");
if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
Tcl_SetResult(in, "1", TCL_STATIC);
return TCL_OK;
}
/*
* Otcl strangness: why isn't c listed?
* dash> otclsh
* % Class Foo
* Foo
* % Foo instproc a a {}
* % Foo instproc b {} { }
* % Foo instproc c {} {}
* % Foo info instprocs
* a b
* -johnh, 30-Jun-98
*/
otcl-1.14/otcl.h 0000664 0000764 0000766 00000006054 07742344404 012410 0 ustar tomh nsnam /* -*- Mode: c++ -*-
*
* $Id: otcl.h,v 1.5 2003/10/12 21:35:00 xuanc Exp $
*
* Copyright 1993 Massachusetts Institute of Technology
*
* Permission to use, copy, modify, distribute, and sell this software and its
* documentation for any purpose is hereby granted without fee, provided that
* the above copyright notice appear in all copies and that both that
* copyright notice and this permission notice appear in supporting
* documentation, and that the name of M.I.T. not be used in advertising or
* publicity pertaining to distribution of the software without specific,
* written prior permission. M.I.T. makes no representations about the
* suitability of this software for any purpose. It is provided "as is"
* without express or implied warranty.
*
*/
#ifndef _otcl_h_
#define _otcl_h_
#include
/* compatible char definition for versions < 8.4 */
/* NOTE: tcl8.3.2 defines CONST, but used it in other places...? */
#if TCL_MAJOR_VERSION < 8 || TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4
#define CONST84
#define CONST84_RETURN
#endif
struct OTclObject;
struct OTclClass;
extern struct OTclObject*
OTclAsObject(Tcl_Interp* in, ClientData cd);
extern struct OTclClass*
OTclAsClass(Tcl_Interp* in, ClientData cd);
extern struct OTclObject*
OTclGetObject(Tcl_Interp* in, CONST84 char* name);
extern struct OTclClass*
OTclGetClass(Tcl_Interp* in, CONST84 char* name);
extern struct OTclObject*
OTclCreateObject(Tcl_Interp* in, CONST84 char* name, struct OTclClass* cl);
extern struct OTclClass*
OTclCreateClass(Tcl_Interp* in, CONST84 char* name, struct OTclClass* cl);
extern int
OTclDeleteObject(Tcl_Interp* in, struct OTclObject* obj);
extern int
OTclDeleteClass(Tcl_Interp* in, struct OTclClass* cl);
extern void
OTclAddPMethod(struct OTclObject* obj, char* nm, Tcl_CmdProc* proc,
ClientData cd, Tcl_CmdDeleteProc* dp);
extern void
OTclAddIMethod(struct OTclClass* cl, char* nm, Tcl_CmdProc* proc,
ClientData cd, Tcl_CmdDeleteProc* dp);
extern int
OTclRemovePMethod(struct OTclObject* obj, char* nm);
extern int
OTclRemoveIMethod(struct OTclClass* cl, char* nm);
extern int
OTclNextMethod(struct OTclObject* obj, Tcl_Interp* in,
int argc, CONST84 char*argv[]);
extern CONST84_RETURN char*
OTclSetInstVar(struct OTclObject* obj, Tcl_Interp* in,
CONST84 char* name, CONST84 char* value, int flgs);
extern CONST84_RETURN char*
OTclGetInstVar(struct OTclObject* obj, Tcl_Interp* in,
CONST84 char* name, int flgs);
extern int
OTclUnsetInstVar(struct OTclObject* obj, Tcl_Interp* in,
CONST84 char* name, int flgs);
extern int
OTclOInstVarOne(struct OTclObject* obj, Tcl_Interp *in, char *frameName,
CONST84 char *varName, CONST84 char *localName, int flags);
extern void
OTclSetObjectData(struct OTclObject* obj, struct OTclClass* cl,
ClientData data);
extern int
OTclGetObjectData(struct OTclObject* obj, struct OTclClass* cl,
ClientData* data);
extern int
OTclUnsetObjectData(struct OTclObject* obj, struct OTclClass* cl);
extern int
Otcl_Init(Tcl_Interp* in);
#endif /* _otcl_h_ */
otcl-1.14/otclAppInit.c 0000664 0000764 0000766 00000014431 06433460522 013662 0 ustar tomh nsnam /*
* tclAppInit.c --
*
* Provides a default version of the Tcl_AppInit procedure.
*
* Copyright (c) 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.
*/
#ifndef lint
/* static char sccsid[] = "@(#) tclAppInit.c 1.11 94/12/17 16:14:03"; */
#endif /* not lint */
#include
#include
#if TCL_MAJOR_VERSION < 7
#error Tcl distribution TOO OLD
#endif
#ifdef TESTCAPI
#include
#include
typedef struct {
time_t started;
int prior;
} timerdata;
#ifdef STATIC_LIB
#include
#include
extern BOOL APIENTRY
Tcl_LibMain(HINSTANCE hInstance,DWORD reason,LPVOID reserved);
/* procedure to call before exiting to clean up */
void static_exit(void){
HINSTANCE hInstance=TclWinGetTclInstance();
Tcl_LibMain(hInstance, DLL_PROCESS_DETACH, NULL);
}
#endif
static int
TimerInit(ClientData cd, Tcl_Interp* in, int argc, char*argv[]) {
struct OTclObject* timer = OTclAsObject(in, cd);
struct OTclClass* tcl = OTclGetClass(in, "Timer");
timerdata* data;
if (!timer || !tcl) return TCL_ERROR;
data = (timerdata*)ckalloc(sizeof(timerdata));
data->started = time(0);
data->prior = 0;
(void)OTclSetObjectData(timer, tcl, (ClientData)data);
if (!OTclSetInstVar(timer, in, "running", "0", TCL_LEAVE_ERR_MSG))
return TCL_ERROR;
return OTclNextMethod(timer, in, argc, argv);
}
static int
TimerDestroy(ClientData cd, Tcl_Interp* in, int argc, char*argv[]) {
struct OTclObject* timer = OTclAsObject(in, cd);
struct OTclClass* tcl = OTclGetClass(in, "Timer");
timerdata* data;
if (!timer || !tcl) return TCL_ERROR;
if (!OTclGetObjectData(timer, tcl, (ClientData*)(&data))) return TCL_ERROR;
(void)OTclUnsetObjectData(timer, tcl);
ckfree(data);
return OTclNextMethod(timer, in, argc, argv);
}
static int
TimerStart(ClientData cd, Tcl_Interp* in, int argc, char*argv[]) {
struct OTclObject* timer = OTclAsObject(in, cd);
struct OTclClass* tcl = OTclGetClass(in, "Timer");
timerdata* data;
if (!timer || !tcl || argc>5) return TCL_ERROR;
if (!OTclGetObjectData(timer, tcl, (ClientData*)(&data))) return TCL_ERROR;
if (data->started == 0) data->started = time(0);
if (!OTclSetInstVar(timer, in, "running", "1", TCL_LEAVE_ERR_MSG))
return TCL_ERROR;
return TCL_OK;
}
static int
TimerRead(ClientData cd, Tcl_Interp* in, int argc, char*argv[]) {
struct OTclObject* timer = OTclAsObject(in, cd);
struct OTclClass* tcl = OTclGetClass(in, "Timer");
timerdata* data;
char val[20];
int total;
if (!timer || !tcl || argc>5) return TCL_ERROR;
if (!OTclGetObjectData(timer, tcl, (ClientData*)(&data))) return TCL_ERROR;
total = data->prior;
if (data->started) total += (int)(time(0) - data->started);
(void)sprintf(val, "%d", total);
Tcl_SetResult(in, val, TCL_VOLATILE);
return TCL_OK;
}
static int
TimerStop(ClientData cd, Tcl_Interp* in, int argc, char*argv[]) {
struct OTclObject* timer = OTclAsObject(in, cd);
struct OTclClass* tcl = OTclGetClass(in, "Timer");
timerdata* data;
if (!timer || !tcl || argc>5) return TCL_ERROR;
if (!OTclGetObjectData(timer, tcl, (ClientData*)(&data))) return TCL_ERROR;
if (data->started != 0) {
data->prior += (int)(time(0) - data->started);
data->started = 0;
}
return TCL_OK;
}
static int
TestCAPI_Init(Tcl_Interp* in) {
struct OTclClass* class = OTclGetClass(in, "Class");
struct OTclClass* object = OTclGetClass(in, "Object");
struct OTclClass* timer;
struct OTclObject* dawn;
if (!class || !object) return TCL_ERROR;
timer = OTclCreateClass(in, "Timer", class);
if (!timer) return TCL_ERROR;
OTclAddIMethod(timer, "start", TimerStart, 0, 0);
OTclAddIMethod(timer, "read", TimerRead, 0, 0);
OTclAddIMethod(timer, "stop", TimerStop, 0, 0);
OTclAddIMethod(timer, "init", TimerInit, 0, 0);
OTclAddIMethod(timer, "destroy", TimerDestroy, 0, 0);
dawn = OTclCreateObject(in, "dawnoftime", timer);
if (!dawn) return TCL_ERROR;
if (Tcl_Eval(in, "dawnoftime start") != TCL_OK) return TCL_ERROR;
return TCL_OK;
}
#endif
/*
* The following variable is a special hack that is needed in order for
* Sun shared libraries to be used for Tcl.
*/
#ifdef NEED_MATHERR
extern int matherr();
int *tclDummyMathPtr = (int *) matherr;
#endif
/*
*----------------------------------------------------------------------
*
* main --
*
* This is the main program for the application.
*
* Results:
* None: Tcl_Main never returns here, so this procedure never
* returns either.
*
* Side effects:
* Whatever the application does.
*
*----------------------------------------------------------------------
*/
#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION < 4
extern int main();
int *tclDummyMainPtr = (int *) main;
#else
int
main(argc, argv)
int argc; /* Number of command-line arguments. */
char **argv; /* Values of command-line arguments. */
{
#ifdef STATIC_LIB
HINSTANCE hInstance=GetModuleInstance(NULL);
Tcl_LibMain(hInstance, DLL_PROCESS_ATTACH, NULL);
atexit(static_exit);
#endif
Tcl_Main(argc, argv, Tcl_AppInit);
return 0; /* Needed only to prevent compiler warning. */
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
*
* This procedure performs application-specific initialization.
* Most applications, especially those that incorporate additional
* packages, will have their own version of this procedure.
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
* message in interp->result if an error occurs.
*
* Side effects:
* Depends on the startup script.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Otcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#ifdef TESTCAPI
if (TestCAPI_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#endif
#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION < 5
tcl_RcFileName = "~/.tclshrc";
#else
Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY);
#endif
return TCL_OK;
}
otcl-1.14/otkAppInit.c 0000644 0000764 0000766 00000005217 11635457075 013527 0 ustar tomh nsnam /*
* tkAppInit.c --
*
* Provides a default version of the Tcl_AppInit procedure for
* use in wish and similar Tk-based applications.
*
* Copyright (c) 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.
*/
#ifndef lint
/* static char sccsid[] = "@(#) tkAppInit.c 1.12 94/12/17 16:30:56"; */
#endif /* not lint */
#include
#include
#if TK_MAJOR_VERSION < 3 || (TK_MAJOR_VERSION==3 && TK_MINOR_VERSION<3)
#error Tk distribution TOO OLD
#endif
/*
* The following variable is a special hack that is needed in order for
* Sun shared libraries to be used for Tcl.
*/
#ifdef NEED_MATHERR
extern int matherr();
int *tclDummyMathPtr = (int *) matherr;
#endif
/*
*----------------------------------------------------------------------
*
* main --
*
* This is the main program for the application.
*
* Results:
* None: Tk_Main never returns here, so this procedure never
* returns either.
*
* Side effects:
* Whatever the application does.
*
*----------------------------------------------------------------------
*/
#if TK_MAJOR_VERSION < 4
extern int main();
int *tclDummyMainPtr = (int *) main;
#else
int
main(argc, argv)
int argc; /* Number of command-line arguments. */
char **argv; /* Values of command-line arguments. */
{
Tk_Main(argc, argv, Tcl_AppInit);
return 0; /* Needed only to prevent compiler warning. */
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
*
* This procedure performs application-specific initialization.
* Most applications, especially those that incorporate additional
* packages, will have their own version of this procedure.
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
* message in interp->result if an error occurs.
*
* Side effects:
* Depends on the startup script.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
Tk_Window mainWindow;
mainWindow = Tk_MainWindow(interp);
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Tk_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Otcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#if TK_MAJOR_VERSION < 4 || (TK_MAJOR_VERSION==4 && TK_MINOR_VERSION<1)
tcl_RcFileName = "~/.wishrc";
#else
Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY);
#endif
return TCL_OK;
}
otcl-1.14/README.html 0000664 0000764 0000766 00000014151 07316154542 013115 0 ustar tomh nsnam
OTcl - MIT Object Tcl
OTcl - MIT Object Tcl
The FAQ & Manual (Version 0.96, September 95)
David Wetherall
djw@lcs.mit.edu
MIT Lab for Computer Science
What is OTcl?
OTcl, short for MIT Object Tcl, is an extension to Tcl/Tk for
object-oriented programming. It shouldn't be confused with the IXI
Object Tcl extension by Dean Sheenan. (Sorry, but we both like the
name and have been using it for a while.)
Some of OTcl's features as compared to alternatives are:
- designed to be dynamically extensible, like Tcl, from the ground up
- builds on Tcl syntax and concepts rather than importing another language
- compact yet powerful object programming system (draws on CLOS,
Smalltalk, and Self)
- fairly portable implementation (2000 lines of C, without core hacks)
OTcl was presented at the Tcl/Tk Workshop '95. It constitutes a
standalone release of a system that has been in use, embedded in the
VuSystem, for
two years. We made the release public (with free use, distribution and
modification under the MIT license) to meet the demand for
object-oriented programming in Tcl.
Where do I get it?
The primary distribution site for OTcl, including this FAQ and
Manual, and documentation is:
ftp://ftp.tns.lcs.mit.edu/pub/otcl/
As well as the source code distribution, binary distributions are
available for some platforms.
How do I make it?
OTcl is known to work with Tcl/Tk versions 7.3/3.6, 7.4/4.0, and
7.5/4.1 (alpha1) on Unix platforms. Since it is written in ANSI C,
does not change the Tcl core, and is small, it should be relatively
easy to port to other platforms. [And I expect it could easily work
with earlier Tcl/Tk versions, at least down to 7.0/3.3.]
Compiling the Source Distribution
To build OTcl from its source distribution, you will need access to
the Tcl source distribution, plus compatible Tcl/Tk libraries and
external includes. The Tcl source is needed to include structures
defined in internal headers. The libraries are needed if you want to
link OTcl into standalone shells.
(Specifically, OTcl needs the file tclInt.h and tclIntDecls.h from
the source code to Tcl. If you're building OTcl on a platform with a
binary installation of Tcl/Tk you must get these header files
from the matching source code for your version ot Tcl/Tk.)
To compile, cd to the untarred directory, type
./configure, and then make. The configuration
process will ask you the location of the Tcl/Tk files it requires and
produce the Makefile. Running make will cause four
binaries to be produced; they are described below.
Don't be put off by the use of configure. Compiling OTcl is
straightforward (it's all in one C file!) and configure is mainly
being used to accommodate platform dependent libraries and
linking. You can edit the Makefile directly, or issue compile
and link commands manually.
Using and Installing the Binaries
OTcl compiles to four binary results, each suited to a different
purpose.
- otclsh, a tclsh loaded with OTcl.
- owish, a wish loaded with OTcl.
- libotcl.a, the OTcl library, for adding OTcl to your Tcl
application. See below.
- libotcl.so (suffix may vary), a shared version of the OTcl library
for dynamically loading OTcl into running Tcl shells. See below.
You can test the binaries with make test. This runs the
test.tcl script, which should report that several tests are
passed.
You can install the binaries with make install.
Adding OTcl to Your Application
OTcl doesn't change the core, so it can be added to other Tcl
applications or shells in the usual manner. It is known to work with
expect-5.18 and tclX7.4a, for example. However, OTcl does depend on
several internal Tcl data structures, so it may not be compatible with
Tcl versions in which the core has been modified.
With a Tcl application of version 7.5 or higher (and a corresponding
libotcl.so) OTcl may be loaded dynamically by issuing the tcl
command "load libotcl.so OTcl" to the running interpreter. (If
libotcl.so is not installed, then you may require environment
variables, such as LD_LIBRARY_PATH for Solaris, or other schemes for
access.)
Alternatively, OTcl can be linked into a Tcl application to provide
access to its C API. Simply call Otcl_Init from your
application initialization routine (for which you will need to include
otcl.h and link against an OTcl library). Then your modules
may acess OTcl C functions through its external interface file,
otcl.h.
How do I use it?
There's a quickstart tutorial to help you become familiar with OTcl
syntax and style. It's included in the distribution.
Tutorial
For documentation about objects, classes, and their capabilities,
see the following reference pages. They're included in the
distribution.
OTcl Objects
OTcl Classes
OTcl Autoloading
OTcl C API
You can read further about OTcl's capabilities and design in the
workshop paper, also included as part of the distribution. It provides
a couple of terse examples too.
Extending Tcl for Dynamic Object-Oriented Programming
David Wetherall and Christopher J. Lindblad
Proceedings of the Tcl/Tk Workshop '95, Toronto, July 1995.
Feedback?
Let me (djw@lcs.mit.edu) know
if you have suggestions or other feedback.
otcl-1.14/VERSION 0000664 0000764 0000766 00000000005 11335071541 012324 0 ustar tomh nsnam 1.14