Usenet 1994 January

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

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

Wrap

Text File | 1991-11-19 | 50.2 KB | 1,473 lines

Newsgroups: comp.sources.misc From: karl@sugar.neosoft.com (Karl Lehenbauer) Subject: v26i011: tclx - extensions and on-line help for tcl 6.1, Part11/23 Message-ID: <1991Nov19.005615.8995@sparky.imd.sterling.com> X-Md4-Signature: dca3169a9ef38cc92288aa68ccb614d2 Date: Tue, 19 Nov 1991 00:56:15 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer) Posting-number: Volume 26, Issue 11 Archive-name: tclx/part11 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 11 (of 23)." # Contents: extended/man/Handles.man extended/src/createExtd.c # extended/src/debug.c extended/src/id.c # extended/tcllib/help/commands/trace # Wrapped by karl@one on Wed Nov 13 21:50:23 1991 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'extended/man/Handles.man' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/man/Handles.man'\" else echo shar: Extracting \"'extended/man/Handles.man'\" $9032 characters$ sed "s/^X//" >'extended/man/Handles.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 Handles tcl X.ad b X.BS X'@index: Tcl_HandleAlloc Tcl_HandleFree Tcl_HandleTblInit Tcl_HandleTblRelease Tcl_HandleTblUseCount Tcl_HandleWalk Tcl_HandleXlate X.SH NAME XTcl_HandleAlloc, Tcl_HandleFree, Tcl_HandleTblInit, XTcl_HandleTblRelease, Tcl_HandleTblUseCount Tcl_HandleWalk, XTcl_HandleXlate \- Dynamic, handle addressable tables. X X.SH SYNOPSIS X.nf X\fB#include <tclExtend.h>\fR X.sp Xvoid_pt X\fBTcl_HandleTblInit\fR (\fIhandleBase, entrySize, initEntries\fR) X.sp Xint X\fBTcl_HandleTblUseCount\fR (\fIheaderPtr, amount\fR) X.sp Xvoid X\fBTcl_HandleTblRelease\fR (\fIheaderPtr\fR) X.sp Xvoid_pt X\fBTcl_HandleAlloc\fR (\fIheaderPtr, handlePtr\fR) X.sp Xvoid X\fBTcl_HandleFree\fR (\fIheaderPtr, entryPtr\fR) X.sp Xvoid_pt X\fBTcl_HandleWalk\fR (\fIheaderPtr, walkKeyPtr\fR) X.sp Xvoid X\fBTcl_WalkKeyToHandle\fR (\fIheaderPtr, walkKey, handlePtr\fR) X.sp Xvoid_pt X\fBTcl_HandleXlate\fR (\fIinterp, headerPtr, handle\fR) X.SH ARGUMENTS X.AS Tcl_Interp *walkKeyPtr X.AP char *handleBase in XBase name for the handle, numeric entry number will be appended. X.AP int entrySize in XSize of the table entries, in bytes. X.AP int initEntries in XInitial number of entries to allocate. X.AP int amount in XAmount to alter the use count by. X.AP void_pt headerPtr in XPointer to the header. X.AP char *handlePtr out XThe handle name is returned here. It must be large enough to hold the handle Xbase name with a number appended. X.AP Tcl_Interp *interp in XInterpreter to use for error reporting. X.AP char *handle in XName of handle to operate on. X.AP void_pt entryPtr in XPointer to a handle table entry. X.AP int *walkKeyPtr i/o XKey used to walk the table, initialize to -1 before the first call. X.AP int walkKey in XKey returned from walking the table. X.BE X X.SH DESCRIPTION X.PP XThe Tcl handle facility provides a way to manage table entries that may be Xreferenced by a textual handle from Tcl code. This is provided for Xapplications that need to create data structures in one command, return a Xreference (i.e. pointer) to that particular data structure and then access Xthat data structure in other commands. An example application is file handles. X.PP XA handle consists of a base name, which is some unique, meaningful name, such Xas `\fBfile\fR' and a numeric value appended to the base name (e.g. `file3'). XThe handle facility is designed to provide a standard mechanism for building XTcl commands that allocate and access table entries based on an entry index. XThe tables are expanded when needed, consequently pointers to entries should Xnot be kept, as they will become invalid when the table is expanded. If the Xtable entries are large or pointers must be kept to the entries, then the Xthe entries should be allocated separately and pointers kept in the handle Xtable. A use count is kept on the table. This use count is intended to Xdetermine when a table shared by multiple commands is to be release. X.PP X\fBTcl_HandleTblInit\fR creates and initialize a Tcl dynamic handle table. XThe specified initial number of entries will be allocated and added to the free Xlist. The use count will be set to one. X.PP X\fBTcl_HandleTblUseCount\fR alters the use count on a table and returns the Xnew value. The use count has \fIamount\fR added to it, where \fIamount\fR may Xbe positive, zero or negative. A zero value retrieves the current use count. XThis is normally used to increment the use count when multiple commands are Xsharing the table. X.PP X\fBTcl_HandleTblRelease\fR decrements the use count on a table. If it becomes Xzero (or negative), the the table will be released. Note that no clean up is Xdone on the table entry client supplied data. If clean up must be done, Xthen \fBTcl_HandleTblUseCount\fR can be used to decrement the use count. XWhen it goes to zero, the table may be walked and then released. X\fIHeaderPtr\fR is declared as \fBClientData\fR so that the procedure may Xbe passed as a command deletion procedure. X.PP X\fBTcl_HandleAlloc\fR allocates an entry and associates a handle with it. XThe handle is returned to the buffer pointed to by \fIhandlePtr\fR can then Xbe used to access the entry. The buffer must be large enough to accommodate Xthe base handle name with 2 to 4 digits appended along with a terminating null Xbyte. XA pointer is returned to the allocated entry. If \fBTcl_HandleFree\fR Xhas not been called since initialization, handles will be handed out Xsequentially from zero. This behavior is useful in setting Xup initial entries, such as ``\fBstdin\fR'' for a file table. X.PP X\fBTcl_HandleXlate\fR translates a handle to a pointer to the corresponding Xtable entry. If the handle is not allocated (open) or is invalid, NULL is Xreturned and an error message is set in \fIinterp->result\fR. X.PP X\fBTcl_HandleWalk\fR walks through and finds every allocated entry in a table. XEntries may be deallocated during a walk, but should not be allocated. X\fBTcl_HandleWalk\fR Xwill return a pointer to the entry, or NULL if no more entries are available. XThe integer pointed to by \fBwalkKeyPtr\fR should be set to `-1' before the Xfirst call, and then the pointer passed to each subsequent call left Xunmodified. X.PP X\fBTcl_WalkKeyToHandle\fR converts a walk key, as returned from a call to X\fBTcl_HandleWalk\fR into a handle. X.PP X\fBTcl_HandleFree\fR frees a handle table entry. X.SH KEYWORDS Xhandle, table, allocate END_OF_FILE if test 9032 -ne `wc -c <'extended/man/Handles.man'`; then echo shar: \"'extended/man/Handles.man'\" unpacked with wrong size! fi # end of 'extended/man/Handles.man' fi if test -f 'extended/src/createExtd.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/createExtd.c'\" else echo shar: Extracting \"'extended/src/createExtd.c'\" $9419 characters$ sed "s/^X//" >'extended/src/createExtd.c' <<'END_OF_FILE' X/* X * createExtd.c X * X * Contains a routine to create an interpreter and initialize all the Extended X * Tcl commands. It is is a seperate file so that an application may create X * the interpreter and add in only a subset of the Extended 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 Xint matherr (); X X X/* X *---------------------------------------------------------------------- X * X * Tcl_CreateExtendedInterp -- X * X * Create a new TCL command interpreter and initialize all of the X * extended Tcl commands.. X * X * Results: X * The return value is a token for the interpreter. X *---------------------------------------------------------------------- X */ XTcl_Interp * XTcl_CreateExtendedInterp () X{ X Tcl_Interp *interp; X int (*bringIn)(); X X interp = Tcl_CreateInterp (); X X /* X * This is a little kludge to make sure matherr is brought in from the X * Tcl library if it is not already defined. This could be done on the X * link line, but this makes sure it happens. X */ X bringIn = matherr; X X /* X * from tclCkalloc.c (now part of the UCB Tcl). X */ X#ifdef TCL_MEM_DEBUG X Tcl_InitMemory (interp); X#endif X X /* X * from chmod.c X */ X Tcl_CreateCommand (interp, "chgrp", Tcl_ChgrpCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "chmod", Tcl_ChmodCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "chown", Tcl_ChownCmd, (ClientData)NULL, X (void (*)())NULL); X X /* X * from clock.c X */ X Tcl_CreateCommand (interp, "getclock", Tcl_GetclockCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "fmtclock", Tcl_FmtclockCmd, X (ClientData)NULL, (void (*)())NULL); X X /* X * from cmdloop.c X */ X Tcl_CreateCommand (interp, "commandloop", Tcl_CommandloopCmd, X (ClientData)NULL, (void (*)())NULL); X X /* X * from debug.c X */ X Tcl_InitDebug (interp); X X /* X * from filescan.c X */ X Tcl_InitFilescan (interp); X X /* X * from fmath.c X */ X Tcl_CreateCommand(interp, "acos", Tcl_AcosCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "asin", Tcl_AsinCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "atan", Tcl_AtanCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "cos", Tcl_CosCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "sin", Tcl_SinCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "tan", Tcl_TanCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "cosh", Tcl_CoshCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "sinh", Tcl_SinhCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "tanh", Tcl_TanhCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "exp", Tcl_ExpCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "log", Tcl_LogCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "log10", Tcl_Log10Cmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "sqrt", Tcl_SqrtCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "fabs", Tcl_FabsCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "floor", Tcl_FloorCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "ceil", Tcl_CeilCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "fmod", Tcl_FmodCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "pow", Tcl_PowCmd, X (ClientData)NULL, (void (*)())NULL); X X /* X * from general.c X */ X Tcl_CreateCommand(interp, "echo", Tcl_EchoCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "infox", Tcl_InfoxCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "loop", Tcl_LoopCmd, X (ClientData)NULL, (void (*)())NULL); X X /* X * from id.c X */ X Tcl_CreateCommand (interp, "id", Tcl_IdCmd, (ClientData)NULL, X (void (*)())NULL); X X /* X * from iocmds.c X */ X Tcl_CreateCommand (interp, "bsearch", Tcl_BsearchCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "dup", Tcl_DupCmd, X (ClientData) NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "pipe", Tcl_PipeCmd, X (ClientData) NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "copyfile", Tcl_CopyfileCmd, X (ClientData) NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "fstat", Tcl_FstatCmd, X (ClientData) NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "fcntl", Tcl_FcntlCmd, X (ClientData) NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "select", Tcl_SelectCmd, X (ClientData) NULL, (void (*)())NULL); X X /* X * from list.c X */ X Tcl_CreateCommand(interp, "lvarpop", Tcl_LvarpopCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "lempty", Tcl_LemptyCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "keyldel", Tcl_KeyldelCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "keylget", Tcl_KeylgetCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "keylset", Tcl_KeylsetCmd, X (ClientData)NULL, (void (*)())NULL); X X /* X * from math.c X */ X Tcl_CreateCommand (interp, "max", Tcl_MaxCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "min", Tcl_MinCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "random", Tcl_RandomCmd, (ClientData)NULL, X (void (*)())NULL); X X /* X * from signal.c X */ X Tcl_InitSignalHandling (interp); X X /* X * from string.c X */ X Tcl_CreateCommand(interp, "cindex", Tcl_CindexCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "clength", Tcl_ClengthCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "crange", Tcl_CrangeCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "csubstr", Tcl_CrangeCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand(interp, "replicate", Tcl_ReplicateCmd, X (ClientData)NULL, (void (*)())NULL); X Tcl_CreateCommand (interp, "translit", Tcl_TranslitCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "ctype", Tcl_CtypeCmd, X (ClientData)NULL, (void (*)())NULL); X X /* X * from unixcmds.c X */ X Tcl_CreateCommand (interp, "execvp", Tcl_ExecvpCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "fork", Tcl_ForkCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "kill", Tcl_KillCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "system", Tcl_SystemCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "times", Tcl_TimesCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "umask", Tcl_UmaskCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "wait", Tcl_WaitCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "link", Tcl_LinkCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "unlink", Tcl_UnlinkCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "mkdir", Tcl_MkdirCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "rmdir", Tcl_RmdirCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "alarm", Tcl_AlarmCmd, (ClientData)NULL, X (void (*)())NULL); X Tcl_CreateCommand (interp, "sleep", Tcl_SleepCmd, (ClientData)NULL, X (void (*)())NULL); X return interp; X} END_OF_FILE if test 9419 -ne `wc -c <'extended/src/createExtd.c'`; then echo shar: \"'extended/src/createExtd.c'\" unpacked with wrong size! fi # end of 'extended/src/createExtd.c' fi if test -f 'extended/src/debug.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/debug.c'\" else echo shar: Extracting \"'extended/src/debug.c'\" $9678 characters$ sed "s/^X//" >'extended/src/debug.c' <<'END_OF_FILE' X/* X * debug.c -- X * X * Tcl command execution trace 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 X#include "tclExtdInt.h" X X/* X * Clientdata structure for trace commands. X */ X#define ARG_TRUNCATE_SIZE 40 X#define CMD_TRUNCATE_SIZE 60 X Xstruct traceInfo_t { X Tcl_Interp *interp; X Tcl_Trace traceHolder; X int noEval; X int noTruncate; X int flush; X int depth; X FILE *filePtr; X }; Xtypedef struct traceInfo_t *traceInfo_pt; X X/* X * Prototypes of internal functions. X */ Xstatic void XPrintStr _ANSI_ARGS_((FILE *filePtr, X char *string, X int numChars)); X Xstatic void XPrintArg _ANSI_ARGS_((FILE *filePtr, X char *argStr, X int noTruncate)); X Xstatic void XTraceRoutine _ANSI_ARGS_((ClientData clientData, X Tcl_Interp *interp, X int level, X char *command, X int (*cmdProc)(), X ClientData cmdClientData, X int argc, X char *argv[])); X Xstatic void XCleanUpDebug _ANSI_ARGS_((ClientData clientData)); X X/* X *---------------------------------------------------------------------- X * X * PrintStr -- X * Print an string, truncating it to the specified number of characters. X * If the string contains newlines, \n is substituted. X * X *---------------------------------------------------------------------- X */ Xstatic void XPrintStr (filePtr, string, numChars) X FILE *filePtr; X char *string; X int numChars; X{ X int idx; X X for (idx = 0; idx < numChars; idx++) { X if (string [idx] == '\n') { X putc ('\\', filePtr); X putc ('n', filePtr); X } else X putc (string [idx], filePtr); X } X if (numChars < strlen (string)) X fprintf (filePtr, "..."); X} X X/* X *---------------------------------------------------------------------- X * X * PrintArg -- X * Print an argument string, truncating and adding "..." if its longer X * then ARG_TRUNCATE_SIZE. If the string contains white spaces, quote X * it with angle brackets. X * X *---------------------------------------------------------------------- X */ Xstatic void XPrintArg (filePtr, argStr, noTruncate) X FILE *filePtr; X char *argStr; X int noTruncate; X{ X int idx, argLen, printLen; X int quote_it; X X argLen = strlen (argStr); X printLen = argLen; X if ((!noTruncate) && (printLen > ARG_TRUNCATE_SIZE)) X printLen = ARG_TRUNCATE_SIZE; X X quote_it = (printLen == 0); X X for (idx = 0; idx < printLen; idx++) X if (isspace (argStr [idx])) { X quote_it = TRUE; X break; X } X X if (quote_it) X putc ('{', filePtr); X PrintStr (filePtr, argStr, printLen); X if (quote_it) X putc ('}', filePtr); X} X X/* X *---------------------------------------------------------------------- X * X * TraceRoutine -- X * Routine called by Tcl_Eval to trace a command. X * X *---------------------------------------------------------------------- X */ Xstatic void XTraceRoutine (clientData, interp, level, command, cmdProc, cmdClientData, X argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int level; X char *command; X int (*cmdProc)(); X ClientData cmdClientData; X int argc; X char *argv[]; X{ X traceInfo_pt traceInfoPtr = (traceInfo_pt) clientData; X int idx, cmdLen, printLen; X X fprintf (traceInfoPtr->filePtr, "%2d", level); X X if (level > 20) level = 20; X for (idx = 0; idx < level; idx++) X fprintf (traceInfoPtr->filePtr, " "); X X if (traceInfoPtr->noEval) { X cmdLen = printLen = strlen (command); X if ((!traceInfoPtr->noTruncate) && (printLen > CMD_TRUNCATE_SIZE)) X printLen = CMD_TRUNCATE_SIZE; X X PrintStr (traceInfoPtr->filePtr, command, printLen); X } else { X for (idx = 0; idx < argc; idx++) { X if (idx > 0) X putc (' ', traceInfoPtr->filePtr); X PrintArg (traceInfoPtr->filePtr, argv[idx], X traceInfoPtr->noTruncate); X } X } X X putc ('\n', traceInfoPtr->filePtr); X if (traceInfoPtr->flush) X fflush (traceInfoPtr->filePtr); X return; X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_CmdtraceCmd -- X * Implements the TCL trace command: X * cmdtrace level|on [noeval] [notruncate] X * cmdtrace off X * cmdtrace depth X * X * Results: X * Standard TCL results. X * X *---------------------------------------------------------------------- X */ Xstatic int XTcl_CmdtraceCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X traceInfo_pt infoPtr = (traceInfo_pt) clientData; X int idx; X char *fileHandle; X X if (argc < 2) X goto argumentError; X X /* X * Handle `depth' sub-command. X */ X if (STREQU (argv[1], "depth")) { X if (argc != 2) X goto argumentError; X sprintf(interp->result, "%d", infoPtr->depth); X return TCL_OK; X } X X /* X * If a trace is in progress, delete it now. X */ X if (infoPtr->traceHolder != NULL) { X Tcl_DeleteTrace(interp, infoPtr->traceHolder); X infoPtr->depth = 0; X infoPtr->traceHolder = NULL; X } X X /* X * Handle off sub-command. X */ X if (STREQU (argv[1], "off")) { X if (argc != 2) X goto argumentError; X return TCL_OK; X } X X infoPtr->noEval = FALSE; X infoPtr->noTruncate = FALSE; X infoPtr->flush = FALSE; X infoPtr->filePtr = stdout; X fileHandle = NULL; X X for (idx = 2; idx < argc; idx++) { X if (STREQU (argv[idx], "notruncate")) { X if (infoPtr->noTruncate) X goto argumentError; X infoPtr->noTruncate = TRUE; X continue; X } X if (STREQU (argv[idx], "noeval")) { X if (infoPtr->noEval) X goto argumentError; X infoPtr->noEval = TRUE; X continue; X } X if (STREQU (argv[idx], "flush")) { X if (infoPtr->flush) X goto argumentError; X infoPtr->flush = TRUE; X continue; X } X if (STRNEQU (argv [idx], "std", 3) || X STRNEQU (argv [idx], "file", 4)) { X if (fileHandle != NULL) X goto argumentError; X fileHandle = argv [idx]; X continue; X } X goto invalidOption; X } X X if (STREQU (argv[1], "on")) { X infoPtr->depth = MAXINT; X } else { X if (Tcl_GetInt (interp, argv[1], &(infoPtr->depth)) != TCL_OK) X return TCL_ERROR; X } X if (fileHandle != NULL) { X OpenFile *tclFilePtr; X X if (TclGetOpenFile (interp, fileHandle, &tclFilePtr) != TCL_OK) X return TCL_ERROR; X if (!tclFilePtr->writable) { X Tcl_AppendResult (interp, "file not writable: ", fileHandle, X (char *) NULL); X return TCL_ERROR; X } X infoPtr->filePtr = tclFilePtr->f; X } X X infoPtr->traceHolder = X Tcl_CreateTrace (interp, infoPtr->depth, TraceRoutine, X (ClientData)infoPtr); X return TCL_OK; X XargumentError: X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " level | on [noeval] [notruncate] [flush] ", X "[handle] | off | depth", (char *) NULL); X return TCL_ERROR; X XinvalidOption: X Tcl_AppendResult (interp, argv [0], ":invalid option: expected ", X "one of noeval, notruncate, flush or a ", X "file handle", (char *) NULL); X return TCL_ERROR; X} X X/* X *---------------------------------------------------------------------- X * X * CleanUpDebug -- X * X * Release the client data area when the trace command is deleted. X * X *---------------------------------------------------------------------- X */ Xstatic void XCleanUpDebug (clientData) X ClientData clientData; X{ X traceInfo_pt infoPtr = (traceInfo_pt) clientData; X X if (infoPtr->traceHolder != NULL) X Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHolder); X ckfree ((char *) infoPtr); X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_InitDebug -- X * X * Initialize the TCL debugging commands. X * X *---------------------------------------------------------------------- X */ Xvoid XTcl_InitDebug (interp) X Tcl_Interp *interp; X{ X traceInfo_pt infoPtr; X X infoPtr = (traceInfo_pt)ckalloc (sizeof (struct traceInfo_t)); X X infoPtr->interp=interp; /* Save just so we can delete traces at the end */ X infoPtr->traceHolder = NULL; X infoPtr->noEval = FALSE; X infoPtr->noTruncate = FALSE; X infoPtr->flush = FALSE; X infoPtr->depth = 0; X X Tcl_CreateCommand (interp, "cmdtrace", Tcl_CmdtraceCmd, X (ClientData)infoPtr, CleanUpDebug); X} X X END_OF_FILE if test 9678 -ne `wc -c <'extended/src/debug.c'`; then echo shar: \"'extended/src/debug.c'\" unpacked with wrong size! fi # end of 'extended/src/debug.c' fi if test -f 'extended/src/id.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/id.c'\" else echo shar: Extracting \"'extended/src/id.c'\" $9404 characters$ sed "s/^X//" >'extended/src/id.c' <<'END_OF_FILE' X/* X * id.c -- X * X * Tcl commands to access getuid, setuid, getgid, setgid and friends. 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 * Prototypes of internal functions. X */ Xint XUseridToUsernameResult _ANSI_ARGS_((Tcl_Interp *interp, X int userId)); X Xint XUsernameToUseridResult _ANSI_ARGS_((Tcl_Interp *interp, X char *userName)); X Xint XGroupidToGroupnameResult _ANSI_ARGS_((Tcl_Interp *interp, X int groupId)); X Xint XGroupnameToGroupidResult _ANSI_ARGS_((Tcl_Interp *interp, X char *groupName)); X X X/* X *---------------------------------------------------------------------- X * X * Tcl_IdCmd -- X * Implements the TCL id command: X * X * id user [name] X * id convert user <name> X * X * id userid [uid] X * id convert userid <uid> X * X * id group [name] X * id convert group <name> X * X * id groupid [gid] X * id convert groupid <gid> X * X * id process X * id process parent X * id process group X * id process group set X * X * id effective user X * id effective userid X * X * id effective group X * id effective groupid X * X * Results: X * Standard TCL results, may return the UNIX system error message. X * X *---------------------------------------------------------------------- X */ X Xstatic int XUseridToUsernameResult (interp, userId) X Tcl_Interp *interp; X int userId; X{ X struct passwd *pw = getpwuid (userId); X if (pw == NULL) { X char numBuf [32]; X X sprintf (numBuf, "%d", userId); X Tcl_AppendResult (interp, "unknown user id: ", numBuf, (char *) NULL); X return TCL_ERROR; X } X strcpy (interp->result, pw->pw_name); X return TCL_OK; X} X Xstatic int XUsernameToUseridResult (interp, userName) X Tcl_Interp *interp; X char *userName; X{ X struct passwd *pw = getpwnam (userName); X if (pw == NULL) { X Tcl_AppendResult (interp, "unknown user id: ", userName, X (char *) NULL); X return TCL_ERROR; X } X sprintf (interp->result, "%d", pw->pw_uid); X return TCL_OK; X} X Xstatic int XGroupidToGroupnameResult (interp, groupId) X Tcl_Interp *interp; X int groupId; X{ X struct group *grp = getgrgid (groupId); X if (grp == NULL) { X char numBuf [32]; X X sprintf (numBuf, "%d", groupId); X Tcl_AppendResult (interp, "unknown group id: ", numBuf, (char *) NULL); X return TCL_ERROR; X } X strcpy (interp->result, grp->gr_name); X return TCL_OK; X} X Xstatic int XGroupnameToGroupidResult (interp, groupName) X Tcl_Interp *interp; X char *groupName; X{ X struct group *grp = getgrnam (groupName); X if (grp == NULL) { X Tcl_AppendResult (interp, "unknown group id: ", groupName, X (char *) NULL); X return TCL_ERROR; X } X sprintf (interp->result, "%d", grp->gr_gid); X return TCL_OK; X} X Xint XTcl_IdCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X struct passwd *pw; X struct group *grp; X int uid, gid; X X if (argc < 2) goto bad_args; X X /* X * If the first argument is "convert", handle the conversion. X */ X if (STREQU (argv[1], "convert")) { X if (argc != 4) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " convert arg arg", (char *) NULL); X return TCL_ERROR; X } X X if (STREQU (argv[2], "user")) X return UsernameToUseridResult (interp, argv[3]); X X if (STREQU (argv[2], "userid")) { X if (Tcl_GetInt (interp, argv[3], &uid) != TCL_OK) X return TCL_ERROR; X return UseridToUsernameResult (interp, uid); X } X X if (STREQU (argv[2], "group")) X return GroupnameToGroupidResult (interp, argv[3]); X X if (STREQU (argv[2], "groupid")) { X if (Tcl_GetInt (interp, argv[3], &gid) != TCL_OK) return TCL_ERROR; X return GroupidToGroupnameResult (interp, gid); X X } X goto bad_three_arg; X } X X /* X * If the first argument is "effective", return the effective user ID, X * name, group ID or name. X */ X if (STREQU (argv[1], "effective")) { X if (argc != 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " effective arg", (char *) NULL); X return TCL_ERROR; X } X X if (STREQU (argv[2], "user")) X return UseridToUsernameResult (interp, geteuid ()); X X if (STREQU (argv[2], "userid")) { X sprintf (interp->result, "%d", geteuid ()); X return TCL_OK; X } X X if (STREQU (argv[2], "group")) X return GroupidToGroupnameResult (interp, getegid ()); X X if (STREQU (argv[2], "groupid")) { X sprintf (interp->result, "%d", getegid ()); X return TCL_OK; X } X goto bad_three_arg; X } X X /* X * If the first argument is "process", return the process ID, parent's X * process ID, process group or set the process group depending on args. X */ X if (STREQU (argv[1], "process")) { X if (argc == 2) { X sprintf (interp->result, "%d", getpid ()); X return TCL_OK; X } X X if (STREQU (argv[2], "parent")) { X if (argc != 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " process parent", (char *) NULL); X return TCL_ERROR; X } X sprintf (interp->result, "%d", getppid ()); X return TCL_OK; X } X if (STREQU (argv[2], "group")) { X if (argc == 3) { X sprintf (interp->result, "%d", getpgrp ()); X return TCL_OK; X } X if ((argc != 4) || !STREQU (argv[3], "set")) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " process group [set]", (char *) NULL); X return TCL_ERROR; X } X setpgrp (); X return TCL_OK; X } X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " process [parent|group|group set]", (char *) NULL); X return TCL_ERROR; X } X X /* X * Handle setting or returning the user ID or group ID (by name or number). X */ X if (argc > 3) X goto bad_args; X X if (STREQU (argv[1], "user")) { X if (argc == 2) { X return UseridToUsernameResult (interp, getuid ()); X } else { X pw = getpwnam (argv[2]); X if (pw == NULL) X goto name_doesnt_exist; X if (setuid (pw->pw_uid) < 0) X goto cannot_set_name; X return TCL_OK; X } X } X X if (STREQU (argv[1], "userid")) { X if (argc == 2) { X sprintf (interp->result, "%d", getuid ()); X return TCL_OK; X } else { X if (Tcl_GetInt (interp, argv[2], &uid) != TCL_OK) X return TCL_ERROR; X if (setuid (uid) < 0) goto cannot_set_name; X return TCL_OK; X } X } X X if (STREQU (argv[1], "group")) { X if (argc == 2) { X return GroupidToGroupnameResult (interp, getgid ()); X } else { X grp = getgrnam (argv[2]); X if (grp == NULL) goto name_doesnt_exist; X if (setgid (grp->gr_gid) < 0) goto cannot_set_name; X return TCL_OK; X } X } X X if (STREQU (argv[1], "groupid")) { X if (argc == 2) { X sprintf (interp->result, "%d", getgid ()); X return TCL_OK; X } else { X if (Tcl_GetInt (interp, argv[2], &gid) != TCL_OK) X return TCL_ERROR; X if (setgid (gid) < 0) goto cannot_set_name; X return TCL_OK; X } X } X Tcl_AppendResult (interp, "bad arg: ", argv [0], X " second arg must be convert, effective, process, ", X "user, userid, group or groupid", (char *) NULL); X return TCL_ERROR; X X X bad_three_arg: X Tcl_AppendResult (interp, "bad arg: ", argv [0], ": ", argv[1], X ": third arg must be user, userid, group or groupid", X (char *) NULL); X return TCL_ERROR; X bad_args: X Tcl_AppendResult (interp, "wrong # args: ", argv [0], " arg [arg..]", X (char *) NULL); X return TCL_ERROR; X X name_doesnt_exist: X Tcl_AppendResult (interp, argv[0], ": ", argv[1], argv[2], (char *) NULL); X return TCL_ERROR; X X cannot_set_name: X Tcl_AppendResult (interp, argv [0], ": ", Tcl_UnixError (interp), X (char *) NULL); X return TCL_ERROR; X} END_OF_FILE if test 9404 -ne `wc -c <'extended/src/id.c'`; then echo shar: \"'extended/src/id.c'\" unpacked with wrong size! fi # end of 'extended/src/id.c' fi if test -f 'extended/tcllib/help/commands/trace' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/tcllib/help/commands/trace'\" else echo shar: Extracting \"'extended/tcllib/help/commands/trace'\" $8226 characters$ sed "s/^X//" >'extended/tcllib/help/commands/trace' <<'END_OF_FILE' X trace option ?arg arg ...? X Cause Tcl commands to be executed whenever certain X operations are invoked. At present, only variable X tracing is implemented. The legal option's (which may X be abbreviated) are: X X trace variable name ops command X Arrange for command to be executed whenever X variable name is accessed in one of the ways given X by ops. Name may refer to a normal variable, an X element of an array, or to an array as a whole X (i.e. name may be just the name of an array, with X no parenthesized index). If name refers to a X whole array, then command is invoked whenever any X element of the array is manipulated. X X Ops indicates which operations are of interest, X and consists of one or more of the following X letters: X X r X Invoke command whenever the variable is X read. X X w X Invoke command whenever the variable is X written. X X u X Invoke command whenever the variable is X unset. Variables can be unset X explicitly with the unset command, or X implicitly when procedures return (all X of their local variables are unset). X Variables are also unset when X interpreters are deleted, but traces X will not be invoked because there is no X interpreter in which to execute them. X X When the trace triggers, three arguments are X appended to command so that the actual command is X as follows: X X command name1 name2 op X X Name1 and name2 give the name(s) for the variable X being accessed: if the variable is a scalar then X name1 gives the variable's name and name2 is an X empty string; if the variable is an array element X then name1 gives the name of the array and name2 X gives the index into the array; if an entire array X is being deleted and the trace was registered on X the overall array, rather than a single element, X then name1 gives the array name and name2 is an X empty string. Op indicates what operation is X being performed on the variable, and is one of r, X w, or u as defined above. X X Command executes in the same context as the code X that invoked the traced operation: if the X variable was accessed as part of a Tcl procedure, X then command will have access to the same local X variables as code in the procedure. This context X may be different than the context in which the X trace was created. Note that name1 may not X necessarily be the same as the name used to set X the trace on the variable; differences can occur X if the access is made through a variable defined X with the upvar command. X X For read and write traces, command can modify the X variable to affect the result of the traced X operation. If command modifies the value of a X variable during a read trace, then the value X returned by the traced read operation will be the X value of the variable after command completes. X For write traces, command is invoked after the X variable's value has been changed; it can write a X new value into the variable to override the X original value specified in the write operation. X The value returned by the traced write operation X will be the value of the variable when command X completes. If command returns an error during a X read or write trace, then the traced operation is X aborted with an error. This mechanism can be used X to implement read-only variables, for example. X Command's result is always ignored. X X While command is executing during a read or write X trace, traces on the variable are temporarily X disabled. This means that reads and writes X invoked by command will occur directly, without X invoking command (or any other traces) again. It X is illegal to unset a variable while a trace is X active for it. It is also illegal to unset an X array if there are traces active for any of the X array's elements. X X When an unset trace is invoked, the variable has X already been deleted: it will appear to be X undefined with no traces. If an unset occurs X because of a procedure return, then the trace will X be invoked in the variable context of the X procedure being returned to: the stack frame of X the returning procedure will no longer exist. X Traces are not disabled during unset traces, so if X an unset trace command creates a new trace and X accesses the variable, the trace will be invoked. X X If there are multiple traces on a variable they X are invoked in order of creation, most-recent X first. If one trace returns an error, then no X further traces are invoked for the variable. If X an array element has a trace set, and there is X also a trace set on the array as a whole, the X trace on the overall array is invoked before the X one on the element. X X Once created, the trace remains in effect either X until the trace is removed with the trace vdelete X command described below, until the variable is X unset, or until the interpreter is deleted. X Unsetting an element of array will remove any X traces on that element, but will not remove traces X on the overall array. X X This command returns an empty string. X X trace vdelete name ops command X If there is a trace set on variable name with the X operations and command given by ops and command, X then the trace is removed, so that command will X never again be invoked. Returns an empty string. X X trace vinfo name X Returns a list containing one element for each X trace currently set on variable name. Each X element of the list is itself a list containing X two elements, which are the ops and command X associated with the trace. If name doesn't exist X or doesn't have any traces set, then the result of X the command will be an empty string. END_OF_FILE if test 8226 -ne `wc -c <'extended/tcllib/help/commands/trace'`; then echo shar: \"'extended/tcllib/help/commands/trace'\" unpacked with wrong size! fi # end of 'extended/tcllib/help/commands/trace' fi echo shar: End of archive 11 $of 23$. cp /dev/null ark11isdone 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.