Newsgroups: comp.sources.misc From: karl@sugar.neosoft.com (Karl Lehenbauer) Subject: v26i014: tclx - extensions and on-line help for tcl 6.1, Part14/23 Message-ID: <1991Nov19.135427.1116@sparky.imd.sterling.com> X-Md4-Signature: f458dc7ae25b454bf9ce981e47366fa3 Date: Tue, 19 Nov 1991 13:54:27 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer) Posting-number: Volume 26, Issue 14 Archive-name: tclx/part14 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 'extended/man/Memory.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 Memory tcl X.BS X'@index: memory ckalloc ckfree Tcl_DisplayMemory Tcl_InitMemory Tcl_ValidateAllMemory X.SH NAME Xckalloc, memory, ckfree, Tcl_DisplayMemory, Tcl_InitMemory, XTcl_ValidateAllMemory - Validated memory allocation interface. X.SH SYNOPSIS X.B memory \fBinfo\fR X.br X.B memory \fBtrace\fR [\fBon|off\fR] X.br X.B memory \fBvalidate\fR [\fBon|off\fR] X.br X.B memory \fBtrace_on_at_malloc\fR \fInnn\fR X.br X.B memory \fBbreak_on_malloc\fR \fInnn\fR X.br X.B memory \fBdisplay\fR \fIfile\fR X.br X.sp 2 X.nf X\fB#include \fR or \fB\fR X.sp Xchar * X\fBckalloc\fR (\fIsize\fR) X.sp Xvoid X\fBckfree\fR (\fIptr\fR) X.sp Xvoid X\fBTcl_DisplayMemory\fR (fileName) X.sp Xvoid X\fBTcl_InitMemory\fR (\fIinterp\fR) X.sp Xvoid X\fBTcl_ValidateAllMemory\fR (\fIfile, line\fR) X.SH ARGUMENTS X.AS Tcl_Interp *fileName X.AP uint size in XThe size of the memory block to be allocated. X.AP char *ptr in XThe address of a block to free, as returned by ckalloc. X.AP Tcl_Interp *interp in XA pointer to the Tcl interpreter. X.AP char *file in XThe filename of the caller of Tcl_ValidateAllMemory. X.AP int line in XThe line number of the caller of Tcl_ValidateAllMemory. X.AP char *fileName in XFile to display list of active memory. X.BE X X.SH DESCRIPTION X.PP XThe macro X\fBckalloc\fR allocates memory, in the same manner as \fBmalloc\fR, with the Xfollowing differences: One, \fBckalloc\fR checks the value returned from X\fBmalloc\fR (it calls \fBmalloc\fR for you) and panics if the allocation Xrequest fails. Two, if enabled at compile time, a version of \fBckalloc\fR Xwith special memory debugging capabilities replaces the normal version of X\fBckalloc\fR, which aids in detecting memory overwrites and leaks (repeated Xallocations not matched by corresponding frees). X.PP X\fBckfree\fR frees memory allocated by \fBckalloc\fR. Like \fBckalloc\fR, Xwhen memory debugging is enabled, \fBckfree\fR has enhanced capabilities Xfor detecting memory overwrites and leaks. X.PP XIt is very important that you use \fBckalloc\fR when you need to allocate Xmemory, and that you use \fBckfree\fR to free it. Should you use \fBmalloc\fR Xto allocate and \fBckfree\fR to free, spurious memory Xvalidation errors will occur when memory debugging is enabled. Should you Xuse \fBfree\fR to free memory allocated by \fBckalloc\fR, memory corruption Xwill occur when memory debugging is enabled. Any memory that is to be become Xthe property of the Tcl interpreter, such as result space, must be allocated Xwith \fBckalloc\fR. If it is absolutely necessary for an application to Xpass back \fBmalloc\fRed memory to Tcl, it will work only if Tcl is complied Xwith the \fBTCL_MEM_DEBUG\fR flag turned off. If you convert your application to Xuse this facility, it will help you find memory over runs and lost memory. XNote that memory allocated by a C library routine requiring freeing should Xstill be freed with \fBfree\fR, since it calls \fBmalloc\fR rather than X\fBckalloc\fR to do the allocation. X' X.SH FINDING MEMORY LEAKS X.PP XThe function \fBTcl_DisplayMemory\fR will display a list of all currently Xallocated memory to the specified file. The following information is Xdisplayed for each allocated block of memory: starting and ending addresses X(excluding guard zone), size, source file where \fBckalloc\fR was called to Xallocate the block and line number in that file. It is especially useful to Xcall \fBTcl_DisplayMemory\fR after the Tcl interpreter has been deleted. X' X.SH ENABLING MEMORY DEBUGGING X.PP XTo enable memory debugging, Tcl should be recompiled from scratch with X\fBTCL_MEM_DEBUG\fR defined. This will also compile in Xa non-stub version of \fBTcl_InitMemory\fR Xto add the \fBmemory\fR command to Tcl. X.PP X\fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined Xfor all modules that are going to be linked together. If they are not, link Xerrors will occur, with either \fBTclDbCkfree\fR and \fBTcl_DbCkalloc\fR or X\fBTcl_Ckalloc\fR and \fBTcl_Ckfree\fR being undefined. X' X.SH GUARD ZONES X.PP XWhen memory debugging is enabled, whenever a call to \fBckalloc\fR is Xmade, slightly more memory than requested is allocated so the memory debugging Xcode can keep track Xof the allocated memory, and also Xeight-byte ``guard zones'' are placed in front of and behind the space that Xwill be returned to the caller. (The size of the guard zone is defined Xby the C #define \fBGUARD_SIZE\fR in \fIbaseline/src/ckalloc.c\fR -- it Xcan be extended if you suspect large overwrite problems, at some cost in Xperformance.) A known pattern is written into the guard zones and, Xon a call to \fBckfree\fR, the guard zones of the space being freed Xare checked to see if either zone has been modified in any way. XIf one has been, the guard bytes and their new contents are identified, Xand a ``low guard failed'' or ``high guard failed'' message is issued. XThe ``guard failed'' message includes the address of the memory packet Xand the file name and line number of the code that called \fBckfree\fR. XThis allows you to detect the common sorts of one-off problems, where Xnot enough space was allocated to contain the data written, for example. X' X.SH THE MEMORY COMMAND X'@help: misc/memory X'@brief: display and debug memory problems X' X.TP X.B memory \fIoptions\fR X.br XThe Tcl \fBmemory\fR command gives the Tcl developer control of Tcl's memory Xdebugging capabilities. The memory command has several suboptions, which are Xdescribed below. It is only available when Tcl has been compiled with memory Xdebugging enabled. X' X.TP X.B memory \fBinfo\fR X.br XProduces a report containing the total allocations and frees since XTcl began, the current packets allocated (the current Xnumber of calls to \fBckalloc\fR not met by a corresponding call Xto \fBckfree\fR), the current bytes allocated, and the maximum number Xof packets and bytes allocated. X' X.TP X.B memory \fBtrace\fR [\fBon|off\fR] X.br XTurns memory tracing on or off. XWhen memory tracing is on, every call to \fBckalloc\fR causes a line of Xtrace information to be written to \fIstderr\fR, consisting of the Xword \fIckalloc\fR, followed by the address returned, the amount of Xmemory allocated, and the C filename and line number of the code performing Xthe allocation, for example... X.sp X \fBckalloc 40e478 98 tclProc.c 1406\fR X.sp XCalls to \fBckfree\fR are traced in the same manner, except that the Xword \fIckalloc\fR is replaced by the word \fIckfree\fR. X' X.TP X.B memory \fBvalidate\fR [\fBon|off\fR] X.br XTurns memory vaidation on or off. XWhen memory validation is enabled, on every call to X\fBckalloc\fR or \fBckfree\fR, the guard zones are checked for every Xpiece of memory currently in existence that was allocated by \fBckalloc\fR. XThis has a large performance impact and should only be used when Xoverwrite problems are strongly suspected. The advantage of enabling Xmemory validation is that a guard zone overwrite can be detected on Xthe first call to \fBckalloc\fR or \fBckfree\fR after the overwrite Xoccurred, rather than when the specific memory with the overwritten Xguard zone(s) is freed, which may occur long after the overwrite occurred. X' X.TP X.B memory \fBtrace_on_at_malloc\fR \fInnn\fR X.br XEnable memory tracing after \fInnn\fR \fBckallocs\fR have been performed. XFor example, if you enter \fBmemory trace_on_at_malloc 100\fR, Xafter the 100th call to \fBckalloc\fR, memory trace information will begin Xbeing displayed for all allocations and frees. Since there can be a lot Xof memory activity before a problem occurs, judicious use of this option Xcan reduce the slowdown caused by tracing (and the amount of trace information Xproduced), if you can identify a number of allocations that occur before Xthe problem sets in. The current number of memory allocations that have Xoccured since Tcl started is printed on a guard zone failure. X.TP X.B memory \fBbreak_on_malloc\fR \fInnn\fR X.br XAfter the \fBnnn\fR allocations have been performed, \fBckallocs\fR Xoutput a message to this effect and that it is now attempting to enter Xthe C debugger. Tcl will then issue a \fISIGINT\fR signal against itself. XIf you are running Tcl under a C debugger, it should then enter the debugger Xcommand mode. X' X.TP X.B memory \fBdisplay\fR \fIfile\fR X.br XWrite a list of all currently allocated memory to the specified file. X'@endhelp X' X.SH DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS X.PP XNormally, Tcl compiled with memory debugging enabled will make it easy to isolate Xa corruption problem. Turning on memory validation with the memory command Xcan help isolate difficult problems. XIf you suspect (or know) that corruption is Xoccurring before the Tcl interpreter comes up far enough for you to Xissue commands, you can set \fBMEM_VALIDATE\fR define, recompile XtclCkalloc.c and rebuild Tcl. This will enable memory validation Xfrom the first call to \fBckalloc\fR, again, at a large performance impact. X.PP XIf you are desperate and validating memory on every call to \fBckalloc\fR Xand \fBckfree\fR isn't enough, you can explicitly call X\fBTcl_ValidateAllMemory\fR directly at any point. It takes a \fIchar *\fR Xand an \fIint\fR which are normally the filename and line number of the Xcaller, but they can actually be anything you want. Remember to remove Xthe calls after you find the problem. X' X.SH KEYWORDS Xckalloc, ckfree, free, memory, malloc END_OF_FILE if test 12997 -ne `wc -c <'extended/man/Memory.man'`; then echo shar: \"'extended/man/Memory.man'\" unpacked with wrong size! fi # end of 'extended/man/Memory.man' fi if test -f 'extended/src/string.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/src/string.c'\" else echo shar: Extracting \"'extended/src/string.c'\" \(13318 characters\) sed "s/^X//" >'extended/src/string.c' <<'END_OF_FILE' X/* X * string.c -- X * X * Extended TCL string and character manipulation 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 X/* X * Prototypes of internal functions. X */ Xunsigned int XExpandString _ANSI_ARGS_((unsigned char *s, X unsigned char buf[])); X X X/* X *---------------------------------------------------------------------- X * X * Tcl_CindexCmd -- X * Implements the cindex TCL command: X * cindex string index X * X * Results: X * Returns the character indexed by index (zero based) from X * string. X * X *---------------------------------------------------------------------- X */ Xint XTcl_CindexCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X unsigned index; X X if (argc != 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], " string index", X (char *) NULL); X return TCL_ERROR; X } X X if (Tcl_GetUnsigned (interp, argv[2], &index) != TCL_OK) X return TCL_ERROR; X if (index >= strlen (argv [1])) X return TCL_OK; X X interp->result [0] = argv[1][index]; X interp->result [1] = 0; X return TCL_OK; X X} /* Tcl_CindexCmd */ X X/* X *---------------------------------------------------------------------- X * X * Tcl_ClengthCmd -- X * Implements the clength TCL command: X * clength string X * X * Results: X * Returns the length of string in characters. X * X *---------------------------------------------------------------------- X */ Xint XTcl_ClengthCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X X if (argc != 2) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], " string", X (char *) NULL); X return TCL_ERROR; X } X X sprintf (interp->result, "%d", strlen (argv[1])); X return TCL_OK; X X} /* Tcl_ClengthCmd */ X X/* X *---------------------------------------------------------------------- X * X * Tcl_CrangeCmd -- X * Implements the crange and csubstr TCL commands: X * crange string first last X * csubstr string first length X * X * Results: X * Standard Tcl result. X *---------------------------------------------------------------------- X */ Xint XTcl_CrangeCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X unsigned fullLen, first; X unsigned subLen; X char *strPtr; X char holdChar; X int isRange = (argv [0][1] == 'r'); /* csubstr or crange */ X X if (argc != 4) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " string first ", X (isRange) ? "last" : "length", X (char *) NULL); X return TCL_ERROR; X } X X if (Tcl_GetUnsigned (interp, argv[2], &first) != TCL_OK) X return TCL_ERROR; X X fullLen = strlen (argv [1]); X if (first >= fullLen) X return TCL_OK; X X if (STREQU (argv[3], "end")) X subLen = fullLen - first; X else { X if (Tcl_GetUnsigned (interp, argv[3], &subLen) != TCL_OK) X return TCL_ERROR; X X if (isRange) { X if (subLen < first) { X Tcl_AppendResult (interp, "last is before first", X (char *) NULL); X return TCL_ERROR; X } X subLen = subLen - first +1; X } X X if (first + subLen > fullLen) X subLen = fullLen - first; X } X X strPtr = argv [1] + first; X X holdChar = strPtr [subLen]; X strPtr [subLen] = '\0'; X Tcl_SetResult (interp, strPtr, TCL_VOLATILE); X strPtr [subLen] = holdChar; X X return TCL_OK; X X} /* Tcl_CrangeCmd */ X X/* X *---------------------------------------------------------------------- X * X * Tcl_ReplicateCmd -- X * Implements the replicate TCL command: X * replicate string count X * See the string(TCL) manual page. X * X * Results: X * Returns string replicated count times. X * X *---------------------------------------------------------------------- X */ Xint XTcl_ReplicateCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X unsigned repCount; X register char *srcPtr, *scanPtr, *newPtr; X register int newLen, cnt; X X if (argc != 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " string count", (char *) NULL); X return TCL_ERROR; X } X X if (Tcl_GetUnsigned (interp, argv[2], &repCount) != TCL_OK) X return TCL_ERROR; X X srcPtr = argv [1]; X newLen = strlen (srcPtr) * repCount; X if (newLen >= TCL_RESULT_SIZE) X Tcl_SetResult (interp, ckalloc ((unsigned) newLen + 1), TCL_DYNAMIC); X X newPtr = interp->result; X for (cnt = 0; cnt < repCount; cnt++) { X for (scanPtr = srcPtr; *scanPtr != 0; scanPtr++) X *newPtr++ = *scanPtr; X } X *newPtr = 0; X X return TCL_OK; X X} /* Tcl_ReplicateCmd */ X X/* X *---------------------------------------------------------------------- X * X * ExpandString -- X * Build an expand version of a translit range specification. X * X * Results: X * TRUE it the expansion is ok, FALSE it its too long. X * X *---------------------------------------------------------------------- X */ X#define MAX_EXPANSION 255 X Xstatic unsigned int XExpandString (s, buf) X unsigned char *s; X unsigned char buf[]; X{ X int i, j; X X i = 0; X while((*s !=0) && i < MAX_EXPANSION) { X if(s[1] == '-' && s[2] > s[0]) { X for(j = s[0]; j <= s[2]; j++) X buf[i++] = j; X s += 3; X } else X buf[i++] = *s++; X } X buf[i] = 0; X return (i < MAX_EXPANSION); X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_TranslitCmd -- X * Implements the TCL translit command: X * translit inrange outrange string X * X * Results: X * Standard TCL results. X * X *---------------------------------------------------------------------- X */ Xint XTcl_TranslitCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X unsigned char from [MAX_EXPANSION+1]; X unsigned char to [MAX_EXPANSION+1]; X unsigned char map [MAX_EXPANSION+1]; X unsigned char *s, *t; X int i; X X if (argc != 4) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], X " from to string", (char *) NULL); X return TCL_ERROR; X } X X if (!ExpandString (argv[1], from)) { X interp->result = "inrange expansion too long"; X return TCL_ERROR; X } X X if (!ExpandString (argv[2], to)) { X interp->result = "outrange expansion too long"; X return TCL_ERROR; X } X X for(i = 0; i <= MAX_EXPANSION ; i++) X map[i] = i; X X for(i = 0; to[i] != 0; i++) X if(from[i]) X map[from[i]] = to[i]; X else X break; X if(to[i] != 0) { X interp->result = "inrange longer than outrange"; X return TCL_ERROR; X } X X for(; from[i]; i++) X map[from[i]] = 0; X X for (s = t = (unsigned char *)argv[3]; *s; s++) { X if(map[*s]) X *t++ = map[*s]; X } X *t = 0; X X Tcl_SetResult (interp, argv[3], TCL_VOLATILE); X X return TCL_OK; X} X X/* X *---------------------------------------------------------------------- X * X * Tcl_CtypeCmd -- X * X * This function implements the 'ctype' command: X * ctype class string X * X * Where class is one of the following: X * digit, xdigit, lower, upper, alpha, alnum, X * space, cntrl, punct, print, graph, ascii, char or ord. X * X * Results: X * One or zero: Depending if all the characters in the string are of X * the desired class. Char and ord provide conversions and return the X * converted value. X * X *---------------------------------------------------------------------- X */ Xint XTcl_CtypeCmd (clientData, interp, argc, argv) X ClientData clientData; X Tcl_Interp *interp; X int argc; X char **argv; X{ X register char *class; X register char *scanPtr; X X if (argc != 3) { X Tcl_AppendResult (interp, "wrong # args: ", argv [0], " class string", X (char *) NULL); X return TCL_ERROR; X } X X class = argv [1]; X X /* X * Handle conversion requests. X */ X if (STREQU (class, "char")) { X int number; X X if (Tcl_GetInt (interp, argv [2], &number) != TCL_OK) X return TCL_ERROR; X if ((number < 0) || (number > 255)) { X Tcl_AppendResult (interp, "number must be in the range 0..255", X (char *) NULL); X return TCL_ERROR; X } X X interp->result [0] = number; X interp->result [1] = 0; X return TCL_OK; X } X X if (STREQU (class, "ord")) { X if (strlen (argv [2]) != 1) { X Tcl_AppendResult (interp, "string to convert must be only one", X " character", (char *) NULL); X return TCL_ERROR; X } X X sprintf(interp->result, "%d", (int)(*argv[2])); X return TCL_OK; X } X X /* X * Select based on the first letter of the 'class' argument to chose the X * macro to test characters with. In some cases another character must be X * switched on to determine which macro to use. This is gross, but better X * we only have to do a string compare once to test if class is correct. X */ X if ((class [2] == 'n') && STREQU (class, "alnum")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isalnum (*scanPtr)) X break; X } X goto returnResult; X } X if ((class [2] == 'p') && STREQU (class, "alpha")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (! isalpha (*scanPtr)) X break; X } X goto returnResult; X } X if ((class [1] == 's') && STREQU (class, "ascii")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isascii (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "cntrl")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!iscntrl (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "digit")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isdigit (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "graph")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isgraph (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "lower")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!islower (*scanPtr)) X break; X } X goto returnResult; X } X if ((class [1] == 'r') && STREQU (class, "print")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isprint (*scanPtr)) X break; X } X goto returnResult; X } X if ((class [1] == 'u') && STREQU (class, "punct")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!ispunct (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "space")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isspace (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "upper")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isupper (*scanPtr)) X break; X } X goto returnResult; X } X if (STREQU (class, "xdigit")) { X for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) { X if (!isxdigit (*scanPtr)) X break; X } X goto returnResult; X } X /* X * No match on subcommand. X */ X Tcl_AppendResult (interp, "unrecognized class specification: \"", class, X "\", expected one of: alnum, alpha, ascii, char, ", X "cntrl, digit, graph, lower, ord, print, punct, space, ", X "upper or xdigit", (char *) NULL); X return TCL_ERROR; X X /* X * Return true or false, depending if the end was reached. Always return X * false for a null string. X */ XreturnResult: X interp->result [0] = (*scanPtr == 0 && scanPtr != argv [2]) ? '1' : '0'; X interp->result [1] = 0; X return TCL_OK; X X} X END_OF_FILE if test 13318 -ne `wc -c <'extended/src/string.c'`; then echo shar: \"'extended/src/string.c'\" unpacked with wrong size! fi # end of 'extended/src/string.c' fi if test -f 'extended/tclsrc/installTcl.tcl' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'extended/tclsrc/installTcl.tcl'\" else echo shar: Extracting \"'extended/tclsrc/installTcl.tcl'\" \(13571 characters\) sed "s/^X//" >'extended/tclsrc/installTcl.tcl' <<'END_OF_FILE' X#============================================================================== X# installTcl.tcl -- X# X# Tcl program to install Tcl onto the system. It is run in the following X# manner: X# X# tcl installTcl.tcl configFile X# X# configFile is a Tcl file that is sourced and contains and sets the following X# variables: See the makefile for the definition of each of the variables: X# X# o TCL_UCB_DIR X# o TCL_DEFAULT X# o TCL_OWNER X# o TCL_GROUP X# o TCL_BINDIR X# o TCL_LIBDIR X# o TCL_INCLUDEDIR X# o TCL_TCLDIR X# o TCL_MAN_INSTALL X# o TCL_MAN_BASEDIR X# o TCL_MAN_SECTION X# o TCL_MAN_STYLE X# o TCL_MAN_INDEX X# o TCL_MAN_INDEX_MERGE X# X# Notes: X# Must be run in the Tcl top level directory. X#:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: X X#------------------------------------------------------------------------------ X# GiveAwayFile -- X# Give away a file to the Tcl owner and group and set its permissions. X# X# Globals: X# TCL_OWNER - Owner name for Tcl files. X# TCL_GROUP - Group nmae for Tcl file. X#------------------------------------------------------------------------------ X Xproc GiveAwayFile {file} { X global TCL_OWNER TCL_GROUP X X if {[file isdirectory $file]} { X chmod a+rx,go-w $file X } else { X chmod a+r,go-w $file X } X chown [list $TCL_OWNER $TCL_GROUP] $file X X} ;# GiveAwayFile X X#------------------------------------------------------------------------------ X# MakePath -- X# X# Make sure all directories in a directory path exists, if not, create them. X#------------------------------------------------------------------------------ Xproc MakePath {pathlist} { X foreach path $pathlist { X set exploded_path [split $path /] X set thisdir {} X foreach element $exploded_path { X append thisdir $element X if {![file isdirectory $thisdir]} { X mkdir $thisdir X GiveAwayFile $thisdir X } X append thisdir / X } X } X} X X#------------------------------------------------------------------------------ X# CopyFile -- X# X# Copy the specified file and change the ownership. If target is a directory, X# then the file is copied to it, other target is a new file name. X#------------------------------------------------------------------------------ X Xproc CopyFile {sourceFile target} { X X if {[file isdirectory $target]} { X set targetFile "$target/[file tail $sourceFile]" X } else { X set targetFile $target X } X X set sourceFH [open $sourceFile r] X set targetFH [open $targetFile w] X copyfile $sourceFH $targetFH X close $sourceFH X close $targetFH X GiveAwayFile $targetFile X X} ;# CopyFile X X#------------------------------------------------------------------------------ X# CopySubDir -- X# X# Recursively copy part of a directory tree, changing ownership and X# permissions. This is a utility routine that actually does the copying. X#------------------------------------------------------------------------------ X Xproc CopySubDir {sourceDir destDir} { X foreach sourceFile [glob -nocomplain $sourceDir/*] { X X if [file isdirectory $sourceFile] { X set destFile $destDir/[file tail $sourceFile] X if {![file exists $destFile]} { X mkdir $destFile} X GiveAwayFile $destFile X CopySubDir $sourceFile $destFile X } else { X CopyFile $sourceFile $destDir X } X } X} ;# CopySubDir X X#------------------------------------------------------------------------------ X# CopyDir -- X# X# Recurisvely copy a directory tree. X#------------------------------------------------------------------------------ X Xproc CopyDir {sourceDir destDir} { X X set cwd [pwd] X if ![file exists $sourceDir] { X error "\"$sourceDir\" does not exist" X } X if ![file isdirectory $sourceDir] { X error "\"$sourceDir\" isn't a directory" X } X if {![file exists $destDir]} { X mkdir $destDir X GiveAwayFile $destDir X } X if ![file isdirectory $destDir] { X error "\"$destDir\" isn't a directory" X } X cd $sourceDir X set status [catch {CopySubDir . $destDir} msg] X cd $cwd X if {$status != 0} { X global errorInfo errorCode X error $msg $errorInfo $errorCode X } X} X X#------------------------------------------------------------------------------ X# GenDefaultFile -- X# X# Generate the tcl defaults file. X#------------------------------------------------------------------------------ X Xproc GenDefaultFile {defaultFileBase sourceDir} { X X set defaultFile "$defaultFileBase[infox version]" X X if ![file writable [file dirname $defaultFile]] { X puts stderr "Can't create $defaultFile -- directory is not writable" X puts stderr "Please reinstall with correct permissions or rebuild" X puts stderr "Tcl to select a default file where the directory path" X puts stderr "you specify is writable by you." X puts stderr "" X puts stderr "Tcl will still be runnable from the current directory," X puts stderr "but maybe not any others..." X puts stderr "" X exit 1 X } X X set fp [open $defaultFile w] X X puts $fp "# Extended Tcl [infox version] default file" X puts $fp "" X puts $fp "set TCLINIT $sourceDir/TclInit.tcl" X puts $fp "" X puts $fp "set TCLPATH $sourceDir" X X close $fp X GiveAwayFile $defaultFile X X} ;# GenDefaultFile X X#------------------------------------------------------------------------------ X# InstallShortMan -- X# Install a manual page on a system that does not have long file names, X# optionally adding an entry to the man index. X# X# Parameters: X# o sourceDir - Directory containing the file. X# o manNames - Name entry created from the name line of the file by X# buildhelp. Has file name and the names it is to be known by. X# o indexFileHdl - File handle of the current index file being created, or X# empty if no index is to be created. X# Globals X# o TCL_MAN_BASEDIR - Base manual directory where all of the man.* and cat.* X# directories live. X# o TCL_MAN_SECTION - The section that the manual file is to go in. X# o TCL_MAN_SEPARATOR - The name separator between the directory and the X# section. X#------------------------------------------------------------------------------ X Xproc InstallShortMan {sourceDir manNames indexFileHdl} { X global TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR X X set srcManFilePath "$sourceDir/[lindex $manNames 0]" X set manFileBase [file tail [file root $srcManFilePath]] X X set destManDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION" X X CopyFile $srcManFilePath "$destManDir/$manFileBase.$TCL_MAN_SECTION" X X if {![lempty $indexFileHdl]} { X foreach name [lindex $manNames 1] { X puts $indexFileHdl "$name\t$manFileBase\t$TCL_MAN_SECTION" X } X } X X} ;# InstallShortMan X X#------------------------------------------------------------------------------ X# InstallShortManPages -- X# Install the manual pages using the short file name scheme. X#------------------------------------------------------------------------------ X Xproc InstallShortManPages {} { X global TCL_UCB_DIR TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR X global TCL_MAN_INDEX TCL_MAN_INDEX_MERGE X X set targetDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION" X X MakePath $TCL_MAN_BASEDIR X MakePath $targetDir X MakePath "$TCL_MAN_BASEDIR/cat$TCL_MAN_SEPARATOR$TCL_MAN_SECTION" X X if {$TCL_MAN_INDEX} { X set tclIndexFile $TCL_MAN_BASEDIR/index.TCL X set indexFileHdl [open $tclIndexFile w] X } else { X set indexFileHdl {} X } X X # Install all of the actual files. X X echo " Installing Tcl 6.1 man files to $targetDir" X X for_file manNames "ucbsrc/ucbman.names" { X InstallShortMan $TCL_UCB_DIR/doc $manNames $indexFileHdl X } X X echo " Installing Extended Tcl man files to $targetDir" X X for_file manNames "man/extdman.names" { X InstallShortMan man $manNames $indexFileHdl X } X X if {$TCL_MAN_INDEX} { X close $indexFileHdl X GiveAwayFile $tclIndexFile X } X X # Merge the manual index, if requested. X X if {$TCL_MAN_INDEX_MERGE} { X set indexFile $TCL_MAN_BASEDIR/index X if {![file exists $indexFile]} { X echo "" X echo [replicate "*" 60] X echo "* `$indexFile' man index file found." X echo "* you may not have manual indexs on this system." X echo "* File `$tclIndexFile' built," X echo "* but indexes not merged." X echo [replicate "*" 60] X echo "" X } else { X echo " Generating new manual index: $indexFile" X exec cat $indexFile $tclIndexFile | sort -u > ${indexFile}.new X exec mv $indexFile ${indexFile}.bak X exec mv ${indexFile}.new $indexFile X GiveAwayFile $indexFile X } X } X} ;# InstallShortManPages X X#------------------------------------------------------------------------------ X# InstallLongMan -- X# Install a manual page on a system that does have long file names. X# X# Parameters: X# o sourceDir - Directory containing the file. X# o manNames - Name entry created from the name line of the file by X# buildhelp. Has file name and the names it is to be known by. X# Globals X# o TCL_MAN_BASEDIR - Base manual directory where all of the man.* and cat.* X# directories live. X# o TCL_MAN_SECTION - The section that the manual file is to go in. X# o TCL_MAN_SEPARATOR - The name separator between the directory and the X# section. X#------------------------------------------------------------------------------ X Xproc InstallLongMan {sourceDir manNames} { X global TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR X X set srcManFilePath "$sourceDir/[lindex $manNames 0]" X set manFileBase [file tail [file root $srcManFilePath]] X X set manLongNames [lindex $manNames 1] X X set destManDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION" X set destManFile "$destManDir/[lvarpop manLongNames].$TCL_MAN_SECTION" X X # Copy file to the first name in the list. X X CopyFile $srcManFilePath $destManFile X X # Link it to the rest of the names in the list. X X foreach manEntry $manLongNames { X link $destManFile "$destManDir/$manEntry.$TCL_MAN_SECTION" X } X X} ;# InstallLongMan X X#------------------------------------------------------------------------------ X# InstallLongManPages -- X# Install the manual pages using the long file name scheme. X#------------------------------------------------------------------------------ X Xproc InstallLongManPages {} { X global TCL_UCB_DIR TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR X X set targetDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION" X X MakePath $TCL_MAN_BASEDIR X MakePath $targetDir X MakePath "$TCL_MAN_BASEDIR/cat$TCL_MAN_SEPARATOR$TCL_MAN_SECTION" X X # Install all of the actual files. X X echo " Installing Tcl 6.1 man files to $targetDir" X X for_file manNames "ucbsrc/ucbman.names" { X InstallLongMan $TCL_UCB_DIR/doc $manNames X } X X echo " Installing Extended Tcl man files to $targetDir" X X for_file manNames "man/extdman.names" { X InstallLongMan man $manNames X } X X} ;# InstallLongManPages X X#------------------------------------------------------------------------------ X# Main program code. X#------------------------------------------------------------------------------ X Xecho "" Xecho ">>> Installing Extended Tcl [infox version] <<<" X Xset argc [llength $argv] Xif {$argc != 1} { X puts stderr "usage: tcl installTcl.tcl configFile" X exit 1 X} X Xglobal TCL_UCB_DIR TCL_DEFAULT TCL_OWNER TCL_GROUP TCL_BINDIR Xglobal TCL_LIBDIR TCL_INCLUDEDIR TCL_TCLDIR TCL_MAN_INSTALL Xglobal TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR TCL_MAN_STYLE Xglobal TCL_MAN_INDEX TCL_MAN_INDEX_MERGE X Xsource $argv X Xglobal G_longFileNames X X X# X# Determine if long file names are available X# Xset status [catch {set tmpFH [open $libDir/AVeryVeryBigFileName w]}] Xif {$status != 0} { X set G_longFileNames 0 X} else { X close $tmpFH X unlink $libDir/AVeryVeryBigFileName X set G_longFileNames 1 X} X X# X# Make sure all directories exists that we will be installing in. X# X XMakePath [list $TCL_TCLDIR [file dirname $TCL_DEFAULT] $TCL_BINDIR] XMakePath [list $TCL_LIBDIR $TCL_INCLUDEDIR $TCL_TCLDIR] X Xecho " Creating default file: $TCL_DEFAULT[infox version]" XGenDefaultFile $TCL_DEFAULT $TCL_TCLDIR X Xecho " Installing `tcl' program in: $TCL_BINDIR" XCopyFile tcl $TCL_BINDIR Xchmod +rx $TCL_BINDIR/tcl X Xecho " Installing `libtcl.a' library in: $TCL_LIBDIR" XCopyFile libtcl.a $TCL_LIBDIR X Xecho " Installing Tcl .h files in: $TCL_INCLUDEDIR" XCopyFile $TCL_UCB_DIR/tcl.h $TCL_INCLUDEDIR XCopyFile src/tclExtend.h $TCL_INCLUDEDIR XCopyFile src/tcl++.h $TCL_INCLUDEDIR X Xecho " Installing Tcl source files in: $TCL_TCLDIR" Xforeach srcFile [glob tcllib/*] { X if {![file isdirectory $srcFile]} { X CopyFile $srcFile $TCL_TCLDIR X } X} X Xecho " Installing Tcl help files in: $TCL_TCLDIR/help" XCopyDir tcllib/help $TCL_TCLDIR/help X Xforeach file [glob $TCL_TCLDIR/*.tlib] { X buildpackageindex $file X} X Xif {$TCL_MAN_INSTALL} { X case $TCL_MAN_STYLE in { X {short} InstallShortManPages X {long} InstallLongManPages X default {error "invalid value for TCL_MAN_STYLE: `$TCL_MAN_STYLE'"} X } X} X Xecho " *** TCL IS NOW INSTALLED ***" X END_OF_FILE if test 13571 -ne `wc -c <'extended/tclsrc/installTcl.tcl'`; then echo shar: \"'extended/tclsrc/installTcl.tcl'\" unpacked with wrong size! fi # end of 'extended/tclsrc/installTcl.tcl' fi echo shar: End of archive 14 \(of 23\). cp /dev/null ark14isdone 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.