Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume26 / tclx / part08 < prev next >

Wrap

Text File | 1991-11-19 | 47.6 KB | 1,503 lines

Newsgroups: comp.sources.misc From: karl@sugar.neosoft.com (Karl Lehenbauer) Subject: v26i008: tclx - extensions and on-line help for tcl 6.1, Part08/23 Message-ID: <1991Nov19.005438.8786@sparky.imd.sterling.com> X-Md4-Signature: bfcbd47886d3f1ec60c297ee541d3826 Date: Tue, 19 Nov 1991 00:54:38 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer) Posting-number: Volume 26, Issue 8 Archive-name: tclx/part08 Environment: UNIX #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 8 (of 23)." # Contents: extended/man/CreateExte.man extended/src/general.c # extended/src/math.c extended/src/tcl++.C extended/src/tclExtend.h # extended/tcllib/TclInit.tcl extended/tcllib/help/commands/file # extended/tcllib/help/intro/regexps extended/tests/cmdtrace.test # Wrapped by karl@one on Wed Nov 13 21:50:20 1991 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'extended/man/CreateExte.man' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/man/CreateExte.man'\" else echo shar: Extracting \"'extended/man/CreateExte.man'\" $4315 characters$ sed "s/^X//" >'extended/man/CreateExte.man' <<'END_OF_FILE' X.\"---------------------------------------------------------------------------- X.\" The definitions below are for supplemental macros used in Sprite X.\" manual entries. X.\" X.\" .HS name section [date [version]] X.\" Replacement for .TH in other man pages. See below for valid X.\" section names. X.\" X.\" .AP type name in/out [indent] X.\" Start paragraph describing an argument to a library procedure. X.\" type is type of argument (int, etc.), in/out is either "in", "out", X.\" or "in/out" to describe whether procedure reads or modifies arg, X.\" and indent is equivalent to second arg of .IP (shouldn't ever be X.\" needed; use .AS below instead) X.\" X.\" .AS [type [name]] X.\" Give maximum sizes of arguments for setting tab stops. Type and X.\" name are examples of largest possible arguments that will be passed X.\" to .AP later. If args are omitted, default tab stops are used. X.\" X.\" .BS X.\" Start box enclosure. From here until next .BE, everything will be X.\" enclosed in one large box. X.\" X.\" .BE X.\" End of box enclosure. X.\" X.\" .VS X.\" Begin vertical sidebar, for use in marking newly-changed parts X.\" of man pages. X.\" X.\" .VE X.\" End of vertical sidebar. X.\" X.\" .DS X.\" Begin an indented unfilled display. X.\" X.\" .DE X.\" End of indented unfilled display. X.\" X' # Heading for Sprite man pages X.de HS X.if '\\$2'cmds' .TH \\$1 1 \\$3 \\$4 X.if '\\$2'lib' .TH \\$1 3 \\$3 \\$4 X.if '\\$2'tcl' .TH \\$1 3 \\$3 \\$4 X.if '\\$2'tk' .TH \\$1 3 \\$3 \\$4 X.if t .wh -1.3i ^B X.nr ^l \\n(.l X.ad b X.. X' # Start an argument description X.de AP X.ie !"\\$4"" .TP \\$4 X.el \{\ X. ie !"\\$2"" .TP \\n()Cu X. el .TP 15 X.\} X.ie !"\\$3"" \{\ X.ta \\n()Au \\n()Bu X\&\\$1 \\fI\\$2\\fP (\\$3) X.\".b X.\} X.el \{\ X.br X.ie !"\\$2"" \{\ X\&\\$1 \\fI\\$2\\fP X.\} X.el \{\ X\&\\fI\\$1\\fP X.\} X.\} X.. X' # define tabbing values for .AP X.de AS X.nr )A 10n X.if !"\\$1"" .nr )A \\w'\\$1'u+3n X.nr )B \\n()Au+15n X.\" X.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n X.nr )C \\n()Bu+\\w'(in/out)'u+2n X.. X' # BS - start boxed text X' # ^y = starting y location X' # ^b = 1 X.de BS X.br X.mk ^y X.nr ^b 1u X.if n .nf X.if n .ti 0 X.if n \l'\\n(.lu\(ul' X.if n .fi X.. X' # BE - end boxed text (draw box now) X.de BE X.nf X.ti 0 X.mk ^t X.ie n \l'\\n(^lu\(ul' X.el \{\ X.\" Draw four-sided box normally, but don't draw top of X.\" box if the box started on an earlier page. X.ie !\\n(^b-1 \{\ X\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' X.\} X.el \}\ X\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' X.\} X.\} X.fi X.br X.nr ^b 0 X.. X' # VS - start vertical sidebar X' # ^Y = starting y location X' # ^v = 1 (for troff; for nroff this doesn't matter) X.de VS X.mk ^Y X.ie n 'mc \s12\(br\s0 X.el .nr ^v 1u X.. X' # VE - end of vertical sidebar X.de VE X.ie n 'mc X.el \{\ X.ev 2 X.nf X.ti 0 X.mk ^t X\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' X.sp -1 X.fi X.ev X.\} X.nr ^v 0 X.. X' # Special macro to handle page bottom: finish off current X' # box/sidebar if in box/sidebar mode, then invoked standard X' # page bottom macro. X.de ^B X.ev 2 X'ti 0 X'nf X.mk ^t X.if \\n(^b \{\ X.\" Draw three-sided box if this is the box's first page, X.\" draw two sides but no top otherwise. X.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c X.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c X.\} X.if \\n(^v \{\ X.nr ^x \\n(^tu+1v-\\n(^Yu X\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c X.\} X.bp X'fi X.ev X.if \\n(^b \{\ X.mk ^y X.nr ^b 2 X.\} X.if \\n(^v \{\ X.mk ^Y X.\} X.. X' # DS - begin display X.de DS X.RS X.nf X.sp X.. X' # DE - end display X.de DE X.fi X.RE X.sp .5 X.. X.\"---------------------------------------------------------------------------- X.HS Tcl_CreateExtendedInterp tcl X.BS X'@index: Tcl_CreateExtendedInterp X.SH NAME XTcl_CreateExtendedInterp \- set up a new Tcl command interpreter and Xinitialized all Extended Tcl commands. X.SH SYNOPSIS X.nf X\fB#include <tclExtend.h>\fR X.sp XTcl_Interp * X\fBTcl_CreateExtendedInterp\fR() X.BE X X.SH DESCRIPTION X.PP X\fBTcl_CreateExtendedInterp\fR creates a new interpreter structure and returns Xa pointer to the interpreter data stucture, as with \fBTcl_CreateInterp\fR. XIn addition, all Extended Tcl commands will be added to the interpreter. X X.SH KEYWORDS Xcommand, create, interpreter END_OF_FILE if test 4315 -ne `wc -c <'extended/man/CreateExte.man'`; then echo shar: \"'extended/man/CreateExte.man'\" unpacked with wrong size! fi # end of 'extended/man/CreateExte.man' fi if test -f 'extended/src/general.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/general.c'\" else echo shar: Extracting \"'extended/src/general.c'\" $5075 characters$ sed "s/^X//" >'extended/src/general.c' <<'END_OF_FILE' X/* X * general.c -- X * X * Contains general extensions to the basic TCL command set. X *--------------------------------------------------------------------------- X * Copyright 1991 Karl Lehenbauer and Mark Diekhans. X * X * Permission to use, copy, modify, and distribute this software and its X * documentation for any purpose and without fee is hereby granted, provided X * that the above copyright notice appear in all copies. Karl Lehenbauer and X * Mark Diekhans make no representations about the suitability of this X * software for any purpose. It is provided "as is" without express or X * implied warranty. X */ X X#include "tclExtdInt.h" X X/* X * These globals must be set by main for the information to be defined. X */ X Xchar *tclxVersion = "?"; /* Extended Tcl version number. */ Xchar *tclxPatchlevel = "?"; /* Extended Tcl patch level. */ X Xchar *tclAppName = "?"; /* Application name */ Xchar *tclAppLongname = "?"; /* Long, natural language application name */ Xchar *tclAppVersion = "?"; /* Version number of the application */ X X X/* X *---------------------------------------------------------------------- X * X * Tcl_EchoCmd -- X * Implements the TCL echo command: X * echo str1 [str2..] X * X * Results: X * Always returns TCL_OK. X * X *---------------------------------------------------------------------- X */ Xint XTcl_EchoCmd(clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X int idx; X X for (idx = 1; idx < argc; idx++) { X fputs (argv [idx], stdout); X if (idx < (argc - 1)) X printf(" "); X } X printf("\n"); X return TCL_OK; X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_InfoxCmd -- X * Implements the TCL infox command: X * infox option X * X *---------------------------------------------------------------------- X */ Xint XTcl_InfoxCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X if (argc != 2) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " option", (char *) NULL); X return TCL_ERROR; X } X X if (STREQU ("version", argv [1])) { X Tcl_SetResult (interp, tclxVersion, TCL_STATIC); X } else if (STREQU ("patchlevel", argv [1])) { X Tcl_SetResult (interp, tclxPatchlevel, TCL_STATIC); X } else if (STREQU ("appname", argv [1])) { X Tcl_SetResult (interp, tclAppName, TCL_STATIC); X } else if (STREQU ("applongname", argv [1])) { X Tcl_SetResult (interp, tclAppLongname, TCL_STATIC); X } else if (STREQU ("appversion", argv [1])) { X Tcl_SetResult (interp, tclAppVersion, TCL_STATIC); X } else { X Tcl_AppendResult (interp, "illegal option \"", argv [1], X "\" expect one of: version, patchlevel, appname, ", X "applongname, or appversion", (char *) NULL); X return TCL_ERROR; X } X return TCL_OK; X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_LoopCmd -- X * Implements the TCL loop command: X * loop var start end [increment] command X * X * Results: X * Standard TCL results. X * X *---------------------------------------------------------------------- X */ Xint XTcl_LoopCmd (dummy, interp, argc, argv) X ClientData dummy; X Tcl_Interp *interp; X int argc; X char **argv; X{ X int result = TCL_OK; X long i, lo, hi, incr = 1; X char *command; X X if ((argc < 5) || (argc > 6)) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " var lo hi [incr] command", (char *) NULL); X return TCL_ERROR; X } X X if (Tcl_GetLong (interp, argv[2], &lo) != TCL_OK) X return TCL_ERROR; X if (Tcl_GetLong (interp, argv[3], &hi) != TCL_OK) X return TCL_ERROR; X if (argc == 5) X command = argv[4]; X else { X if (Tcl_GetLong (interp, argv[4], &incr) != TCL_OK) X return TCL_ERROR; X command = argv[5]; X } X X for (i = lo; (((i < hi) && (incr > 0)) || ((i > hi) && (incr < 0))); X i += incr) { X char itxt[12]; X X sprintf(itxt,"%ld",i); X if (Tcl_SetVar(interp, argv[1], itxt, TCL_LEAVE_ERR_MSG) == NULL) X return TCL_ERROR; X X result = Tcl_Eval(interp, command, 0, (char **) NULL); X if (result != TCL_OK) { X if (result == TCL_CONTINUE) { X result = TCL_OK; X } else if (result == TCL_BREAK) { X result = TCL_OK; X break; X } else if (result == TCL_ERROR) { X char buf [64]; X X sprintf (buf, "\n (\"loop\" body line %d)", X interp->errorLine); X Tcl_AddErrorInfo (interp, buf); X break; X } else { X break; X } X } X } X return result; X} END_OF_FILE if test 5075 -ne `wc -c <'extended/src/general.c'`; then echo shar: \"'extended/src/general.c'\" unpacked with wrong size! fi # end of 'extended/src/general.c' fi if test -f 'extended/src/math.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/math.c'\" else echo shar: Extracting \"'extended/src/math.c'\" $4921 characters$ sed "s/^X//" >'extended/src/math.c' <<'END_OF_FILE' X/* X * math.c -- X * X * Mathematical Tcl commands. X *--------------------------------------------------------------------------- X * Copyright 1991 Karl Lehenbauer and Mark Diekhans. X * X * Permission to use, copy, modify, and distribute this software and its X * documentation for any purpose and without fee is hereby granted, provided X * that the above copyright notice appear in all copies. Karl Lehenbauer and X * Mark Diekhans make no representations about the suitability of this X * software for any purpose. It is provided "as is" without express or X * implied warranty. X */ X X#include "tclExtdInt.h" X Xextern int rand(); X X/* X * Prototypes of internal functions. X */ Xint Xreally_random _ANSI_ARGS_((int my_range)); X X X/* X *---------------------------------------------------------------------- X * X * Tcl_MaxCmd -- X * Implements the TCL max command: X * max num1 num2 [..numN] X * X * Results: X * Standard TCL results. X * X *---------------------------------------------------------------------- X */ Xint XTcl_MaxCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X double value, maxVal = MINDOUBLE; X int idx, maxIdx = 1; X X X if (argc < 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " num1 num2 [..numN]", (char *) NULL); X return TCL_ERROR; X } X X for (idx = 1; idx < argc; idx++) { X if (Tcl_GetDouble (interp, argv[idx], &value) != TCL_OK) X return TCL_ERROR; X if (value > maxVal) { X maxVal = value; X maxIdx = idx; X } X } X strcpy (interp->result, argv[maxIdx]); X return TCL_OK; X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_MinCmd -- X * Implements the TCL min command: X * min num1 num2 [..numN] X * X * Results: X * Standard TCL results. X * X *---------------------------------------------------------------------- X */ Xint XTcl_MinCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X double value, minVal = MAXDOUBLE; X int idx, minIdx = 1; X X if (argc < 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " num1 num2 [..numN]", (char *) NULL); X return TCL_ERROR; X } X X for (idx = 1; idx < argc; idx++) { X if (Tcl_GetDouble (interp, argv[idx], &value) != TCL_OK) X return TCL_ERROR; X if (value < minVal) { X minVal = value; X minIdx = idx; X } X } X strcpy (interp->result, argv[minIdx]); X return TCL_OK; X} X X/* X *---------------------------------------------------------------------- X * X * ReallyRandom -- X * Insure a good random return for a range, unlike an arbitrary X * random() % n, thanks to Ken Arnold, Unix Review, October 1987. X * X *---------------------------------------------------------------------- X */ X#ifdef TCL_32_BIT_RANDOM X# define RANDOM_RANGE ((1 << 31) - 1) X#else X# define RANDOM_RANGE ((1 << 15) - 1) X#endif X Xstatic int X XReallyRandom (myRange) X int myRange; X{ X int maxMultiple, rnum; X X maxMultiple = RANDOM_RANGE / myRange; X maxMultiple *= myRange; X while ((rnum = rand()) >= maxMultiple) X continue; X return (rnum % myRange); X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_RandomCmd -- X * Implements the TCL random command: X * random limit X * X * Results: X * Standard TCL results. X * X *---------------------------------------------------------------------- X */ Xint XTcl_RandomCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X unsigned range; X X if ((argc < 2) || (argc > 3)) X goto invalidArgs; X X if (STREQU (argv [1], "seed")) { X long seed; X X if (argc == 3) { X if (Tcl_GetLong (interp, argv[2], &seed) != TCL_OK) X return TCL_ERROR; X } else X seed = (unsigned) (getpid() + time((time_t *)NULL)); X X srand(seed); X X } else { X if (argc != 2) X goto invalidArgs; X if (Tcl_GetUnsigned (interp, argv[1], &range) != TCL_OK) X return TCL_ERROR; X if ((range == 0) || (range > RANDOM_RANGE)) X goto outOfRange; X X sprintf (interp->result, "%d", ReallyRandom (range)); X } X return TCL_OK; X XinvalidArgs: X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " limit | seed [seedval]", (char *) NULL); X return TCL_ERROR; XoutOfRange: X { X char buf [18]; X X sprintf (buf, "%d", RANDOM_RANGE); X Tcl_AppendResult (interp, argv [0], ": range must be > 0 and <= ", X buf, (char *) NULL); X return TCL_ERROR; X } X} END_OF_FILE if test 4921 -ne `wc -c <'extended/src/math.c'`; then echo shar: \"'extended/src/math.c'\" unpacked with wrong size! fi # end of 'extended/src/math.c' fi if test -f 'extended/src/tcl++.C' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/tcl++.C'\" else echo shar: Extracting \"'extended/src/tcl++.C'\" $4062 characters$ sed "s/^X//" >'extended/src/tcl++.C' <<'END_OF_FILE' X/* X * tcl++.C -- X * X * File to test it the C++ definitions compile. It is an alternative to the X * existing main.c to set up the Tcl shell and may be used as a example on X * how to use tcl++.h X * X *--------------------------------------------------------------------------- X * Copyright 1991 Karl Lehenbauer and Mark Diekhans. X * X * Permission to use, copy, modify, and distribute this software and its X * documentation for any purpose and without fee is hereby granted, provided X * that the above copyright notice appear in all copies. Karl Lehenbauer, X * Mark Diekhans, and Peter da Silva make no representations about the X * suitability of this software for any purpose. It is provided "as is" X * without express or implied warranty. X *--------------------------------------------------------------------------- X * Based on Tcl C++ classes developed by Parag Patel. X */ X X#include "tcl++.h" X#include "patchlevel.h" X Xextern errno; X X/* X * These globals are used by the infox command. X */ X Xextern char *tclxVersion; /* Extended Tcl version number. */ Xextern char *tclxPatchlevel; /* Extended Tcl patch level. */ X Xextern char *tclAppName; /* Application name */ Xextern char *tclAppLongname; /* Long, natural language application name */ Xextern char *tclAppVersion; /* Version number of the application */ X X/* X * If set to be a pointer to the procedure Tcl_RecordAndEval, will link in X * history X */ Xextern int (*tclShellCmdEvalProc) (); X Xint Xmain (int argc, X char **argv) X{ X TclInterp_cl *interpPtr; X char *defaultFile; X X X /* X * Set values to return from the infox command. X */ X tclxVersion = ckalloc (strlen (TCL_VERSION) + X strlen (TCL_EXTD_VERSION_SUFFIX) + 1); X strcpy (tclxVersion, TCL_VERSION); X strcat (tclxVersion, TCL_EXTD_VERSION_SUFFIX); X X tclxPatchlevel = "PATCHLEVEL"; X X /* X * Path name for default file. A version number is normally appended. X * >>>> MAYBE MODIFIED FOR a specific application <<< X */ X X defaultFile = ckalloc (strlen (TCL_DEFAULT) + strlen (TCL_VERSION) + X strlen (TCL_EXTD_VERSION_SUFFIX) + 1); X strcpy (defaultFile, TCL_DEFAULT); X strcat (defaultFile, TCL_VERSION); X strcat (defaultFile, TCL_EXTD_VERSION_SUFFIX); X X /* X * Set application specific values to return from the infox command. X * >>>> MAYBE MODIFIED FOR a specific application <<< X */ X tclAppName = "TclX"; X tclAppLongname = "Extended Tcl Shell"; X tclAppVersion = tclxVersion; X X /* X * If history is to be used, then set the eval procedure pointer that X * Tcl_CommandLoop so that history will be recorded. This reference X * also brings in history from Tcl.a. X */ X#ifndef TCL_NOHISTORY X tclShellCmdEvalProc = (int (*)())Tcl_RecordAndEval; X#endif X X /* X * Create a Tcl interpreter for the session, with all extended commands X * initialized. This can be replaced with Tcl_CreateInterp followed X * by a subset of the extended command initializaton procedures if X * desired. X */ X interpPtr = new TclInterp_cl; X X /* X * >>>>>> INITIALIZE APPLICATION SPECIFIC COMMANDS HERE <<<<<< X */ X X /* X * Load the tcl startup code, this should pull in all of the tcl X * procs, paths, command line processing, autoloads, packages, etc. X * If Tcl was invoked interactively, Tcl_Startup will give it X * a command loop . X */ X X interpPtr->Startup (argc, argv, defaultFile); X X /* X * Delete the interpreter (not neccessary under Unix, but we do X * it if TCL_MEM_DEBUG is set to better enable us to catch memory X * corruption problems) X */ X X#ifdef TCL_MEM_DEBUG X delete interpPtr; X#endif X X#ifdef TCL_SHELL_MEM_LEAK X printf (" >>> Dumping active memory list to mem.lst <<<\n"); X if (Tcl_DumpActiveMemory ("mem.lst") != TCL_OK) X panic ("error accessing `mem.lst': %s", strerror (errno)); X#endif X X exit(0); X} X END_OF_FILE if test 4062 -ne `wc -c <'extended/src/tcl++.C'`; then echo shar: \"'extended/src/tcl++.C'\" unpacked with wrong size! fi # end of 'extended/src/tcl++.C' fi if test -f 'extended/src/tclExtend.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/tclExtend.h'\" else echo shar: Extracting \"'extended/src/tclExtend.h'\" $4591 characters$ sed "s/^X//" >'extended/src/tclExtend.h' <<'END_OF_FILE' X/* X * tclExtend.h X * X * External declarations for the extended Tcl library. X *--------------------------------------------------------------------------- X * Copyright 1991 Karl Lehenbauer and Mark Diekhans. X * X * Permission to use, copy, modify, and distribute this software and its X * documentation for any purpose and without fee is hereby granted, provided X * that the above copyright notice appear in all copies. Karl Lehenbauer and X * Mark Diekhans make no representations about the suitability of this X * software for any purpose. It is provided "as is" without express or X * implied warranty. X */ X X#ifndef TCLEXTEND_H X#define TCLEXTEND_H X X#include <stdio.h> X#include "tcl.h" X X/* X * Version suffix for extended Tcl, this is appended to the standard Tcl X * version to form the actual extended Tcl version. X */ X X#define TCL_EXTD_VERSION_SUFFIX "a" /* 6.1a */ X Xtypedef void *void_pt; X X/* X * Exported Extended Tcl functions. X */ X XEXTERN void XTcl_CommandLoop _ANSI_ARGS_((Tcl_Interp *interp, X FILE *in, X FILE *out, X int interactive)); X XEXTERN Tcl_Interp * XTcl_CreateExtendedInterp (); X XEXTERN char * XTcl_DeleteKeyedListField _ANSI_ARGS_((Tcl_Interp *interp, X CONST char *fieldName, X CONST char *keyedList)); XEXTERN char * XTcl_DownShift _ANSI_ARGS_((char *targetStr, X CONST char *sourceStr)); X XEXTERN char * XTcl_UpShift _ANSI_ARGS_((char *targetStr, X CONST char *sourceStr)); X XEXTERN int XTcl_GetKeyedListField _ANSI_ARGS_((Tcl_Interp *interp, X CONST char *fieldName, X CONST char *keyedList, X char **fieldValuePtr)); X XEXTERN int XTcl_GetLong _ANSI_ARGS_((Tcl_Interp *interp, X CONST char *string, X long *longPtr)); X XEXTERN int XTcl_GetUnsigned _ANSI_ARGS_((Tcl_Interp *interp, X CONST char *string, X unsigned *unsignedPtr)); X XEXTERN char * XTcl_SetKeyedListField _ANSI_ARGS_((Tcl_Interp *interp, X CONST char *fieldName, X CONST char *fieldvalue, X CONST char *keyedList)); X XEXTERN int XTcl_StrToLong _ANSI_ARGS_((CONST char *string, X int base, X long *longPtr)); X XEXTERN int XTcl_StrToInt _ANSI_ARGS_((CONST char *string, X int base, X int *intPtr)); X XEXTERN int XTcl_StrToUnsigned _ANSI_ARGS_((CONST char *string, X int base, X unsigned *unsignedPtr)); X XEXTERN int XTcl_StrToDouble _ANSI_ARGS_((CONST char *string, X double *doublePtr)); X XEXTERN void_pt XTcl_HandleAlloc _ANSI_ARGS_((void_pt headerPtr, X char *handlePtr)); X XEXTERN void XTcl_HandleFree _ANSI_ARGS_((void_pt headerPtr, X void_pt entryPtr)); X XEXTERN void_pt XTcl_HandleTblInit _ANSI_ARGS_((CONST char *handleBase, X int entrySize, X int initEntries)); X XEXTERN void XTcl_HandleTblRelease _ANSI_ARGS_((void_pt headerPtr)); X XEXTERN int XTcl_HandleTblUseCount _ANSI_ARGS_((void_pt headerPtr, X int amount)); X XEXTERN void_pt XTcl_HandleWalk _ANSI_ARGS_((void_pt headerPtr, X int *walkKeyPtr)); X XEXTERN void XTcl_WalkKeyToHandle _ANSI_ARGS_((void_pt headerPtr, X int walkKey, X char *handlePtr)); X XEXTERN void_pt XTcl_HandleXlate _ANSI_ARGS_((Tcl_Interp *interp, X void_pt headerPtr, X CONST char *handle)); X XEXTERN int XTcl_MathError _ANSI_ARGS_((char *functionName, X int errorType)); X XEXTERN int XTcl_SigNameToNum _ANSI_ARGS_((char *sigName)); X XEXTERN void XTcl_Startup _ANSI_ARGS_((Tcl_Interp *interp, X int argc, X CONST char **argv, X CONST char *defaultFile)); X XEXTERN int XTcl_System _ANSI_ARGS_((Tcl_Interp *interp, X char *command)); X X#endif END_OF_FILE if test 4591 -ne `wc -c <'extended/src/tclExtend.h'`; then echo shar: \"'extended/src/tclExtend.h'\" unpacked with wrong size! fi # end of 'extended/src/tclExtend.h' fi if test -f 'extended/tcllib/TclInit.tcl' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/tcllib/TclInit.tcl'\" else echo shar: Extracting \"'extended/tcllib/TclInit.tcl'\" $4434 characters$ sed "s/^X//" >'extended/tcllib/TclInit.tcl' <<'END_OF_FILE' X# TclInit.tcl -- Extended Tcl initialization (see tclshell man page) X Xglobal env TCLENV Xset TCLENV(inUnknown) 0 Xset TCLENV(packageIndexesLoaded) 0 X X# X# Define a package (called from .tndx file only) X# Xproc TCLSH:defpkg {packageName libName offset length args} { X global TCLENV X set TCLENV(PKG:$packageName) [list $libName $offset $length] X foreach i $args { X set TCLENV(PROC:$i) [list P $packageName] X } X} X X# X# Load Ousterhout style index. X# Xproc TCLSH:LoadOusterIndex {dir} { X global TCLENV X X set fileHdl [open $dir/tclIndex] X while {[gets $fileHdl line] >= 0} { X if {([string index $line 0] == "#") || ([llength $line] != 2)} { X continue} X set filename [lindex $line 1] X if {"$filename" == "init.tcl"} { X continue} X set TCLENV(PROC:[lindex $line 0]) [list F $filename] X X } X close $fileHdl X} X X# X# Load a package library index. X# Xproc loadlibindex {libFile} { X set indexFile [file root $libFile].tndx X if {![file readable $indexFile] || ([file mtime $indexFile] < X [file mtime $libFile])} { X demand_load buildpackageindex X buildpackageindex $libFile X } X source $indexFile X} X X# X# Load library indexes along path. X# Xproc TCLSH:LoadPackageIndexes {} { X global TCLPATH X foreach dir $TCLPATH { X foreach libFile [glob -nocomplain $dir/*.tlib] { X loadlibindex $libFile X } X if {[file readable $dir/tclIndex]} { X TCLSH:LoadOusterIndex $dir X } X } X} X X# X# Unknown command trap handler. X# Xproc unknown {cmdName args} { X global TCLENV X if $TCLENV(inUnknown) { X error "recursive unknown command trap: \"$cmdName\""} X set TCLENV(inUnknown) 1 X X if [demand_load $cmdName] { X set TCLENV(inUnknown) 0 X return [uplevel 1 [list eval $cmdName $args]] X } X X global env interactiveSession noAutoExec X X if {$interactiveSession && ([info level] == 1) && ([info script] == "") && X (!([info exists noAutoExec] && [set noAutoExec]))} { X if {[file rootname $cmdName] == "$cmdName"} { X if [info exists env(PATH)] { X set binpath [searchpath [split $env(PATH) :] $cmdName] X } else { X set binpath [searchpath "." $cmdName] X } X } else { X set binpath $cmdName X } X if {[file executable $binpath]} { X uplevel 1 [list system [concat $cmdName $args]] X set TCLENV(inUnknown) 0 X return X } X } X set TCLENV(inUnknown) 0 X error "invalid command name: \"$cmdName\"" X} X X# X# Search a path list for a file. X# Xproc searchpath {pathlist file} { X foreach dir $pathlist { X if {"$dir" == ""} {set dir .} X if [file exists $dir/$file] { X return $dir/$file X } X } X return {} X} X X# X# Define a proc to be available for demand_load. X# Xproc autoload {filenam args} { X global TCLENV X foreach i $args { X set TCLENV(PROC:$i) [list F $filenam] X } X} X X# X# Load a proc from library or autoload file. X# Xproc demand_load {name} { X global TCLENV X if [info exists TCLENV(PROC:$name)] { X set autoloadRecord $TCLENV(PROC:$name) X if {[lindex $autoloadRecord 0] == "F"} { X load [lindex $autoloadRecord 1] X } else { X set pkgInfo $TCLENV(PKG:[lindex $autoloadRecord 1]) X uplevel #0 sourcepart [lindex $pkgInfo 0] [lindex $pkgInfo 1] [lindex $pkgInfo 2] X if {"[info procs $name]" == ""} { X return 0} X } X return 1 X } X X # Slow path load index file and try again. X X if {!$TCLENV(packageIndexesLoaded)} { X TCLSH:LoadPackageIndexes X set TCLENV(packageIndexesLoaded) 1 X return [demand_load $name] X } X return 0 X} X X# X# Search TCLPATH for a file to source. X# Xproc load {name} { X global TCLPATH errorCode X set where [searchpath $TCLPATH $name] X if [lempty $where] { X error "couldn't find $name in Tcl search path" "" "TCLSH FILE_NOT_FOUND" X } X uplevel #0 source $where X} X Xautoload buildidx.tcl buildpackageindex X X# == Put any code you want all Tcl programs to include here. == X Xif !$interactiveSession return X X# == Interactive Tcl session initialization == X Xif [file exists ~/.tclrc] {source ~/.tclrc} X Xset TCLENV(topLevelPromptHook) {global programName; concat "$programName>" } X Xset TCLENV(downLevelPromptHook) {concat "=>"} X END_OF_FILE if test 4434 -ne `wc -c <'extended/tcllib/TclInit.tcl'`; then echo shar: \"'extended/tcllib/TclInit.tcl'\" unpacked with wrong size! fi # end of 'extended/tcllib/TclInit.tcl' fi if test -f 'extended/tcllib/help/commands/file' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/tcllib/help/commands/file'\" else echo shar: Extracting \"'extended/tcllib/help/commands/file'\" $4731 characters$ sed "s/^X//" >'extended/tcllib/help/commands/file' <<'END_OF_FILE' X file option name ?arg arg ...? X Operate on a file or a file name. Name is the name of X a file; if it starts with a tilde, then tilde X substitution is done before executing the command (see X the manual entry for Tcl_TildeSubst for details). X Option indicates what to do with the file name. Any X unique abbreviation for option is acceptable. The X valid options are: X X file atime name X Return a decimal string giving the time at which X file name was last accessed. The time is measured X in the standard UNIX fashion as seconds from a X fixed starting time (often January 1, 1970). If X the file doesn't exist or its access time cannot X be queried then an error is generated. X X file dirname name X Return all of the characters in name up to but not X including the last slash character. If there are X no slashes in name then return ``.''. If the last X slash in name is its first character, then return X ``/''. X X file executable name X Return 1 if file name is executable by the current X user, 0 otherwise. X X file exists name X Return 1 if file name exists and the current user X has search privileges for the directories leading X to it, 0 otherwise. X X file extension name X Return all of the characters in name after and X including the last dot in name. If there is no X dot in name then return the empty string. X X file isdirectory name X Return 1 if file name is a directory, 0 otherwise. X X file isfile name X Return 1 if file name is a regular file, 0 X otherwise. X X file mtime name X Return a decimal string giving the time at which X file name was last modified. The time is measured X in the standard UNIX fashion as seconds from a X fixed starting time (often January 1, 1970). If X the file doesn't exist or its modified time cannot X be queried then an error is generated. X X file owned name X Return 1 if file name is owned by the current X user, 0 otherwise. X X file readable name X Return 1 if file name is readable by the current X user, 0 otherwise. X X file rootname name X Return all of the characters in name up to but not X including the last ``.'' character in the name. X If name doesn't contain a dot, then return name. X X file size name X Return a decimal string giving the size of file X name in bytes. If the file doesn't exist or its X size cannot be queried then an error is generated. X X file stat namevarName X Invoke the stat kernel call on name, and use the X variable given by varName to hold information X returned from the kernel call. VarName is treated X as an array variable, and the following elements X of that variable are set: atime, ctime, dev, gid, X ino, mode, mtime, nlink, size, uid. Each element X is a decimal string with the value of the X corresponding field from the stat return X structure; see the manual entry for stat for X details on the meanings of the values. This X command returns an empty string. X X file tail name X Return all of the characters in name after the X last slash. If name contains no slashes then X return name. X X file writable name X Return 1 if file name is writable by the current X user, 0 otherwise. X X The file commands that return 0/1 results are often X used in conditional or looping commands, for example: X X if {![file exists foo]} then {error {bad file name}} X X END_OF_FILE if test 4731 -ne `wc -c <'extended/tcllib/help/commands/file'`; then echo shar: \"'extended/tcllib/help/commands/file'\" unpacked with wrong size! fi # end of 'extended/tcllib/help/commands/file' fi if test -f 'extended/tcllib/help/intro/regexps' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/tcllib/help/intro/regexps'\" else echo shar: Extracting \"'extended/tcllib/help/intro/regexps'\" $4341 characters$ sed "s/^X//" >'extended/tcllib/help/intro/regexps' <<'END_OF_FILE' X REGULAR EXPRESSIONS X Tcl provides two commands that support string matching using X egrep-style regular expressions: regexp and regsub. Regular X expressions are implemented using Henry Spencer's package, X and the description of regular expressions below is copied X verbatim from his manual entry. X X A regular expression is zero or more branches, separated by X ``|''. It matches anything that matches one of the X branches. X X A branch is zero or more pieces, concatenated. It matches a X match for the first, followed by a match for the second, X etc. X X A piece is an atom possibly followed by ``*'', ``+'', or X ``?''. An atom followed by ``*'' matches a sequence of 0 or X more matches of the atom. An atom followed by ``+'' matches X a sequence of 1 or more matches of the atom. An atom X followed by ``?'' matches a match of the atom, or the null X string. X X An atom is a regular expression in parentheses (matching a X match for the regular expression), a range (see below), X ``.'' (matching any single character), ``^'' (matching the X null string at the beginning of the input string), ``$'' X (matching the null string at the end of the input string), a X ``\'' followed by a single character (matching that X character), or a single character with no other significance X (matching that character). X X A range is a sequence of characters enclosed in ``[]''. It X normally matches any single character from the sequence. If X the sequence begins with ``^'', it matches any single X character not from the rest of the sequence. If two X characters in the sequence are separated by ``-'', this is X shorthand for the full list of ASCII characters between them X (e.g. ``[0-9]'' matches any decimal digit). To include a X literal ``]'' in the sequence, make it the first character X (following a possible ``^''). To include a literal ``-'', X make it the first or last character. X X If a regular expression could match two different parts of a X string, it will match the one which begins earliest. If X both begin in the same place but match different lengths, or X match the same length in different ways, life gets messier, X as follows. X X In general, the possibilities in a list of branches are X considered in left-to-right order, the possibilities for X ``*'', ``+'', and ``?'' are considered longest-first, nested X constructs are considered from the outermost in, and X concatenated constructs are considered leftmost-first. The X match that will be chosen is the one that uses the earliest X possibility in the first choice that has to be made. If X there is more than one choice, the next will be made in the X same manner (earliest possibility) subject to the decision X on the first choice. And so forth. X X For example, ``(ab|a)b*c'' could match ``abc'' in one of two X ways. The first choice is between ``ab'' and ``a''; since X ``ab'' is earlier, and does lead to a successful overall X match, it is chosen. Since the ``b'' is already spoken for, X the ``b*'' must match its last possibility-the empty X string-since it must respect the earlier choice. X X In the particular case where no ``|''s are present and there X is only one ``*'', ``+'', or ``?'', the net effect is that X the longest possible match will be chosen. So ``ab*'', X presented with ``xabbbby'', will match ``abbbb''. Note that X if ``ab*'' is tried against ``xabyabbbz'', it will match X ``ab'' just after ``x'', due to the begins-earliest rule. X (In effect, the decision on where to start the match is the X first choice to be made, hence subsequent choices must X respect it even if this leads them to less-preferred X alternatives.) END_OF_FILE if test 4341 -ne `wc -c <'extended/tcllib/help/intro/regexps'`; then echo shar: \"'extended/tcllib/help/intro/regexps'\" unpacked with wrong size! fi # end of 'extended/tcllib/help/intro/regexps' fi if test -f 'extended/tests/cmdtrace.test' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/tests/cmdtrace.test'\" else echo shar: Extracting \"'extended/tests/cmdtrace.test'\" $4633 characters$ sed "s/^X//" >'extended/tests/cmdtrace.test' <<'END_OF_FILE' X# X# cmdtrace.test X# X# Tests for the cmdtrace command. X#--------------------------------------------------------------------------- X# Copyright 1991 Karl Lehenbauer and Mark Diekhans. X# X# Permission to use, copy, modify, and distribute this software and its X# documentation for any purpose and without fee is hereby granted, provided X# that the above copyright notice appear in all copies. Karl Lehenbauer and X# Mark Diekhans make no representations about the suitability of this X# software for any purpose. It is provided "as is" without express or X# implied warranty. X# X Xif {[string compare test [info procs test]] == 1} then {source defs} X X# X# Proc to do something to trace. X# Xproc DoStuff {} { X set foo [replicate "-TheString-" 10] X set baz $foo X set wap 1 X if {$wap} { X set wap 0 X } else { X set wap 1 X } X} Xproc DoStuff1 {} {DoStuff} Xproc DoStuff2 {} {DoStuff1} Xproc DoStuff3 {} {DoStuff2} Xproc DoStuff4 {} {DoStuff3} X X# X# Proc to retrieve the output of a trace. It determines the level of the first X# line. This is used to strip off level number and identation from each line. X# so that all lines will be indented the same amount. It also closes the X# trace file. X Xproc GetTrace {cmdtraceFH} { X set result {} X seek $cmdtraceFH 0 start X if {([gets $cmdtraceFH line] < 2) || X ([scan $line "%d" level] != 1)} { X error "*Incorrect format for first line of the trace*" X } X set nuke [expr ($level*2)+2] X seek $cmdtraceFH 0 start X while {[gets $cmdtraceFH line] >= 0} { X set linelen [clength $line] X if {$linelen == 0} { X continue} X if {$linelen < $nuke} { X error "invalid trace line: `$line'"} X append result "[crange $line $nuke end]\n" X } X close $cmdtraceFH X return $result X} X Xtest cmdtrace-1.1 {command trace: evaluated, truncated} { X set cmdtraceFH [open CMDTRACE.OUT w+] X cmdtrace on $cmdtraceFH X DoStuff4 X cmdtrace off X GetTrace $cmdtraceFH X} {DoStuff4 X DoStuff3 X DoStuff2 X DoStuff1 X DoStuff X replicate -TheString- 10 X set foo -TheString--TheString--TheString--TheStr... X set baz -TheString--TheString--TheString--TheStr... X set wap 1 X if $wap {\n set wap 0\n } else {\n set wap 1\n } X set wap 0 Xcmdtrace off X} X Xtest cmdtrace-1.2 {command trace: not evaluated, truncated} { X set cmdtraceFH [open CMDTRACE.OUT w+] X cmdtrace on $cmdtraceFH noeval flush X DoStuff4 X cmdtrace off X GetTrace $cmdtraceFH X} "DoStuff4 X DoStuff3 X DoStuff2 X DoStuff1 X DoStuff X replicate \"-TheString-\" 10 X set foo \[replicate \"-TheString-\" 10\] X set baz \$foo X set wap 1 X if {\$wap} {\\n set wap 0\\n } else {\\n set wap 1... X set wap 0 Xcmdtrace off X" X Xtest cmdtrace-1.3 {command trace: evaluated, not truncated} { X set cmdtraceFH [open CMDTRACE.OUT w+] X cmdtrace on $cmdtraceFH notruncate X DoStuff4 X cmdtrace off X GetTrace $cmdtraceFH X} {DoStuff4 X DoStuff3 X DoStuff2 X DoStuff1 X DoStuff X replicate -TheString- 10 X set foo -TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString- X set baz -TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString--TheString- X set wap 1 X if $wap {\n set wap 0\n } else {\n set wap 1\n } X set wap 0 Xcmdtrace off X} X Xtest cmdtrace-1.4 {command trace: not evaluated, not truncated} { X set cmdtraceFH [open CMDTRACE.OUT w+] X cmdtrace on $cmdtraceFH notruncate noeval flush X DoStuff4 X cmdtrace off X GetTrace $cmdtraceFH X} {DoStuff4 X DoStuff3 X DoStuff2 X DoStuff1 X DoStuff X replicate "-TheString-" 10 X set foo [replicate "-TheString-" 10] X set baz $foo X set wap 1 X if {$wap} {\n set wap 0\n } else {\n set wap 1\n } X set wap 0 Xcmdtrace off X} X Xtest cmdtrace-1.5 {command trace argument error checking} { X list [catch {cmdtrace foo} msg] $msg X} {1 {expected integer but got "foo"}} X Xtest cmdtrace-1.6 {command trace argument error checking} { X list [catch {cmdtrace on foo} msg] $msg X} {1 {cmdtrace:invalid option: expected one of noeval, notruncate, flush or a file handle}} X Xtest cmdtrace-1.6 {command trace argument error checking} { X catch {close file20} X list [catch {cmdtrace on file20} msg] $msg X} {1 {file "file20" isn't open}} X Xunlink CMDTRACE.OUT END_OF_FILE if test 4633 -ne `wc -c <'extended/tests/cmdtrace.test'`; then echo shar: \"'extended/tests/cmdtrace.test'\" unpacked with wrong size! fi # end of 'extended/tests/cmdtrace.test' fi echo shar: End of archive 8 $of 23$. cp /dev/null ark8isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 23 archives. echo "Now cd to "extended", edit the makefile, then do a "make"" rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.