Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume26/tclx/part18

Text File | 1991-11-19 | 37.9 KB | 1,231 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v26i018:  tclx - extensions and on-line help for tcl 6.1, Part18/23
Message-ID: <[e-mail]>
X-Md4-Signature: 90a3e37a1a942fd4e204c8a6ea32ee0f
Date: Tue, 19 Nov 1991 13:56:31 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 26, Issue 18
Archive-name: tclx/part18
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 18 (of 23)."
# Contents:  extended/src/extendUtil.c extended/src/filescan.c
# Wrapped by karl@one on Wed Nov 13 21:50:30 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'extended/src/extendUtil.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'extended/src/extendUtil.c'\"
else
echo shar: Extracting \"'extended/src/extendUtil.c'\" \(16951 characters\)
sed "s/^X//" >'extended/src/extendUtil.c' <<'END_OF_FILE'
X/*
X * extendUtil.c
X *
X * Utility functions for Extended Tcl.
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#ifdef TCL_NO_TOLOWER_MACRO
X#  define _tolower tolower
X#  define _toupper toupper
X#endif
X
X/*
X * Prototypes of internal functions.
X */
Xvoid
XExpandDynBuf _ANSI_ARGS_((dynamicBuf_t *dynBufPtr,
X                          int           appendSize));
X
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StrToLong --
X *      Convert an Ascii string to an long number of the specified base.
X *
X * Parameters:
X *   o string (I) - String containing a number.
X *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
X *     based on the leading characters of the number.  Zero to let the number
X *     determine the base.
X *   o longPtr (O) - Place to return the converted number.  Will be
X *     unchanged if there is an error.
X *
X * Returns:
X *      Returns 1 if the string was a valid number, 0 invalid.
X *----------------------------------------------------------------------
X */
Xint
XTcl_StrToLong (string, base, longPtr)
X    CONST char *string;
X    int         base;
X    long       *longPtr;
X{
X    char *end;
X    long  num;
X
X    num = strtol(string, &end, base);
X    while ((*end != '\0') && isspace(*end)) {
X        end++;
X    }
X    if ((end == string) || (*end != 0))
X        return FALSE;
X    *longPtr = num;
X    return TRUE;
X
X} /* Tcl_StrToLong */
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StrToInt --
X *      Convert an Ascii string to an number of the specified base.
X *
X * Parameters:
X *   o string (I) - String containing a number.
X *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
X *     based on the leading characters of the number.  Zero to let the number
X *     determine the base.
X *   o intPtr (O) - Place to return the converted number.  Will be
X *     unchanged if there is an error.
X *
X * Returns:
X *      Returns 1 if the string was a valid number, 0 invalid.
X *----------------------------------------------------------------------
X */
Xint
XTcl_StrToInt (string, base, intPtr)
X    CONST char *string;
X    int         base;
X    int        *intPtr;
X{
X    char *end;
X    int   num;
X
X    num = strtol(string, &end, base);
X    while ((*end != '\0') && isspace(*end)) {
X        end++;
X    }
X    if ((end == string) || (*end != 0))
X        return FALSE;
X    *intPtr = num;
X    return TRUE;
X
X} /* Tcl_StrToInt */
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StrToUnsigned --
X *      Convert an Ascii string to an unsigned int of the specified base.
X *
X * Parameters:
X *   o string (I) - String containing a number.
X *   o base (I) - The base to use for the number 8, 10 or 16 or zero to decide
X *     based on the leading characters of the number.  Zero to let the number
X *     determine the base.
X *   o unsignedPtr (O) - Place to return the converted number.  Will be
X *     unchanged if there is an error.
X *
X * Returns:
X *      Returns 1 if the string was a valid number, 0 invalid.
X *----------------------------------------------------------------------
X */
Xint
XTcl_StrToUnsigned (string, base, unsignedPtr)
X    CONST char *string;
X    int         base;
X    unsigned   *unsignedPtr;
X{
X    char          *end;
X    unsigned long  num;
X
X    num = strtoul (string, &end, base);
X    while ((*end != '\0') && isspace(*end)) {
X        end++;
X    }
X    if ((end == string) || (*end != 0))
X        return FALSE;
X    *unsignedPtr = num;
X    return TRUE;
X
X} /* Tcl_StrToUnsigned */
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StrToDouble --
X *   Convert a string to a double percision floating point number.
X *
X * Parameters:
X *   string (I) - Buffer containing double value to convert.
X *   doublePtr (O) - The convert floating point number.
X * Returns:
X *   TRUE if the number is ok, FALSE if it is illegal.
X *-----------------------------------------------------------------------------
X */
Xint
XTcl_StrToDouble (string, doublePtr)
X    CONST char *string;
X    double     *doublePtr;
X{
X    char   *end;
X    double  num;
X
X    num = strtod (string, &end);
X    while ((*end != '\0') && isspace(*end)) {
X        end++;
X    }
X    if ((end == string) || (*end != 0))
X        return FALSE;
X
X    *doublePtr = num;
X    return TRUE;
X
X} /* Tcl_StrToDouble */
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DownShift --
X *     Utility procedure to down-shift a string.  It is written in such
X *     a way as that the target string maybe the same as the source string.
X *
X * Parameters:
X *   o targetStr (I) - String to store the down-shifted string in.  Must
X *     have enough space allocated to store the string.  If NULL is specified,
X *     then the string will be dynamicly allocated and returned as the
X *     result of the function. May also be the same as the source string to
X *     shift in place.
X *   o sourceStr (I) - The string to down-shift.
X *
X * Returns:
X *   A pointer to the down-shifted string
X *----------------------------------------------------------------------
X */
Xchar *
XTcl_DownShift (targetStr, sourceStr)
X    char       *targetStr;
X    CONST char *sourceStr;
X{
X    register char theChar;
X
X    if (targetStr == NULL)
X        targetStr = ckalloc (strlen ((char *) sourceStr) + 1);
X
X    for (; (theChar = *sourceStr) != '\0'; sourceStr++) {
X        if (isupper (theChar))
X            theChar = tolower (theChar);
X        *targetStr++ = theChar;
X    }
X    *targetStr = '\0';
X    return targetStr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UpShift --
X *     Utility procedure to up-shift a string.
X *
X * Parameters:
X *   o targetStr (I) - String to store the up-shifted string in.  Must
X *     have enough space allocated to store the string.  If NULL is specified,
X *     then the string will be dynamicly allocated and returned as the
X *     result of the function. May also be the same as the source string to
X *     shift in place.
X *   o sourceStr (I) - The string to up-shift.
X *
X * Returns:
X *   A pointer to the up-shifted string
X *----------------------------------------------------------------------
X */
Xchar *
XTcl_UpShift (targetStr, sourceStr)
X    char       *targetStr;
X    CONST char *sourceStr;
X{
X    register char theChar;
X
X    if (targetStr == NULL)
X        targetStr = ckalloc (strlen ((char *) sourceStr) + 1);
X
X    for (; (theChar = *sourceStr) != '\0'; sourceStr++) {
X        if (islower (theChar))
X            theChar = toupper (theChar);
X        *targetStr++ = theChar;
X    }
X    *targetStr = '\0';
X    return targetStr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ExpandDynBuf --
X *
X *    Expand a dynamic buffer so that it will have room to hold the
X *    specified additional space.  If `appendSize' is zero, the buffer
X *    size will just be doubled.
X *
X *----------------------------------------------------------------------
X */
Xstatic void
XExpandDynBuf (dynBufPtr, appendSize)
X    dynamicBuf_t *dynBufPtr;
X    int           appendSize;
X{
X    int   newSize;
X    char *oldBufPtr;
X
X    newSize = dynBufPtr->size * 2;
X    if (newSize < (dynBufPtr->used + appendSize)) {
X        newSize = dynBufPtr->used + appendSize;
X    }
X    oldBufPtr = dynBufPtr->ptr;
X    dynBufPtr->ptr = ckalloc (newSize);
X    memcpy (dynBufPtr->ptr, oldBufPtr, dynBufPtr->used);
X    if (oldBufPtr != dynBufPtr->buf)
X        ckfree ((char *) oldBufPtr);
X    dynBufPtr->size = newSize;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DynBufInit --
X *
X *    Initializes a dynamic buffer.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_DynBufInit (dynBufPtr)
X    dynamicBuf_t *dynBufPtr;
X{
X    dynBufPtr->buf [0] = '\0';
X    dynBufPtr->ptr = dynBufPtr->buf;
X    dynBufPtr->size = INIT_DYN_BUFFER_SIZE;
X    dynBufPtr->used = 0;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DynBufFree --
X *
X *    Clean up a dynamic buffer, release space if it was dynamicly
X *    allocated.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_DynBufFree (dynBufPtr)
X    dynamicBuf_t *dynBufPtr;
X{
X    if (dynBufPtr->ptr != dynBufPtr->buf)
X        ckfree (dynBufPtr->ptr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DynBufReturn --
X *
X *    Return the contents of the dynamic buffer as an interpreter result.
X *    The dynamic buffer must be re-initialized to reuse it.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_DynBufReturn (interp, dynBufPtr)
X    Tcl_Interp    *interp;
X    dynamicBuf_t *dynBufPtr;
X{
X    if (dynBufPtr->ptr != dynBufPtr->buf)
X        Tcl_SetResult (interp, dynBufPtr->ptr, TCL_DYNAMIC);
X    else
X        Tcl_SetResult (interp, dynBufPtr->ptr, TCL_VOLATILE);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DynBufAppend --
X *
X *    Append the specified string to the dynamic buffer, expanding if
X *    necessary. Assumes the string in the buffer is zero terminated.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_DynBufAppend (dynBufPtr, newStr)
X    dynamicBuf_t *dynBufPtr;
X    char         *newStr;
X{
X    int newLen, currentUsed;
X
X    newLen = strlen (newStr) + 1;
X    currentUsed = (dynBufPtr->used == 0) ? 0 : dynBufPtr->used - 1;
X    if ((currentUsed + newLen) > dynBufPtr->size)
X        ExpandDynBuf (dynBufPtr, newLen);  /* Don't double count '\0' */
X    strcpy (dynBufPtr->ptr + currentUsed, newStr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DynamicFgets --
X *
X *    Reads a line from a file into a dynamic buffer.  The buffer will be
X *    expanded, if necessary and reads are done until EOL or EOF is reached.
X *    Any data already in the buffer will be overwritten.  Even if an error
X *    or EOF is encountered, the buffer should be cleaned up, as storage
X *    may have still been allocated.
X *
X * Results:
X *    If data was transfered, returns > 0, if EOF was encountered without
X *    transfering any data, returns 0.  If an error occured, returns, < 0.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_DynamicFgets (dynBufPtr, filePtr)
X    dynamicBuf_t *dynBufPtr;
X    FILE         *filePtr;
X{
X    int   readVal;
X
X    dynBufPtr->used = 0;
X
X    while (TRUE) {
X        if (dynBufPtr->used == dynBufPtr->size)
X            ExpandDynBuf (dynBufPtr, 0);
X
X        readVal = getc (filePtr);
X        if (readVal == '\n')      /* Is it a new-line? */
X            break;
X        if (readVal == EOF) {     /* Is it an EOF or an error? */
X            if (feof (filePtr)) {
X                break;
X            }
X            return -1;   /* Error */
X        }
X        dynBufPtr->ptr [dynBufPtr->used++] = readVal;
X    }
X    dynBufPtr->ptr [dynBufPtr->used++] = '\0';
X    return (readVal == EOF) ? 0 : 1;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GetLong --
X *
X *      Given a string, produce the corresponding long value.
X *
X * Results:
X *      The return value is normally TCL_OK;  in this case *intPtr
X *      will be set to the integer value equivalent to string.  If
X *      string is improperly formed then TCL_ERROR is returned and
X *      an error message will be left in interp->result.
X *
X * Side effects:
X *      None.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_GetLong(interp, string, longPtr)
X    Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
X    CONST char *string;         /* String containing a (possibly signed)
X                                 * integer in a form acceptable to strtol. */
X    long       *longPtr;        /* Place to store converted result. */
X{
X    char *end;
X    long  i;
X
X    i = strtol(string, &end, 0);
X    while ((*end != '\0') && isspace(*end)) {
X        end++;
X    }
X    if ((end == string) || (*end != 0)) {
X        Tcl_AppendResult (interp, "expected integer but got \"", string,
X                          "\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    *longPtr = i;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GetUnsigned --
X *
X *      Given a string, produce the corresponding unsigned integer value.
X *
X * Results:
X *      The return value is normally TCL_OK;  in this case *intPtr
X *      will be set to the integer value equivalent to string.  If
X *      string is improperly formed then TCL_ERROR is returned and
X *      an error message will be left in interp->result.
X *
X * Side effects:
X *      None.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_GetUnsigned(interp, string, unsignedPtr)
X    Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
X    CONST char *string;         /* String containing a (possibly signed)
X                                 * integer in a form acceptable to strtoul. */
X    unsigned   *unsignedPtr;    /* Place to store converted result. */
X{
X    char          *end;
X    unsigned long  i;
X
X    i = strtoul(string, &end, 0);
X    while ((*end != '\0') && isspace(*end)) {
X        end++;
X    }
X    if ((end == string) || (*end != 0)) {
X        Tcl_AppendResult (interp, "expected unsigned integer but got \"",
X                          string, "\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    *unsignedPtr = i;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ConvertFileHandle --
X *
X * Convert a file handle to its file number. The file handle maybe one
X * of "stdin", "stdout" or "stderr" or "fileNNN", were NNN is the file
X * number.  If the handle is invalid, -1 is returned and a error message
X * will be returned in interp->result.  This is used when the file may
X * not be currently open.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_ConvertFileHandle (interp, handle)
X    Tcl_Interp *interp;
X    char       *handle;
X{
X    int fileId = -1;
X
X    if (handle [0] == 's') {
X        if (STREQU (handle, "stdin"))
X            fileId = 0;
X        else if (STREQU (handle, "stdout"))
X            fileId = 1;
X        else if (STREQU (handle, "stderr"))
X            fileId = 2;
X    } else {
X       if (STRNEQU (handle, "file", 4))
X           Tcl_StrToInt (&handle [4], 10, &fileId);
X    }
X    if (fileId < 0)
X        Tcl_AppendResult (interp, "invalid file handle: ", handle,
X                          (char *) NULL);
X    return fileId;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_System --
X *     does the equivalent of the Unix "system" library call, but
X *     uses waitpid to wait on the correct process, rather than
X *     waiting on all processes and throwing the exit statii away
X *     for the processes it isn't interested in, plus does it with
X *     a Tcl flavor
X *
X * Results:
X *  Standard TCL results, may return the UNIX system error message.
X *
X *----------------------------------------------------------------------
X */
Xint
XTcl_System (interp, command)
X    Tcl_Interp *interp;
X    char       *command;
X{
X    int processID, waitStatus, processStatus;
X
X    if ((processID = Tcl_Fork()) < 0) {
X        Tcl_AppendResult (interp, "Tcl_System: fork error:",
X                          Tcl_UnixError (interp), (char*) NULL);
X        return -1;
X    }
X    if (processID == 0) {
X        int         closeFd, maxFiles;
X        struct stat statBuf;
X
X        /*
X         * Close all pipe file descriptors.  Yuk.
X         */
X        maxFiles = ulimit (4, 0);
X        for (closeFd = 3; closeFd < maxFiles; closeFd++)
X            if ((fstat (closeFd, &statBuf) >= 0) &&
X                    (S_IFIFO & statBuf.st_mode))
X                close(closeFd);
X
X        execl("/bin/sh", "sh", "-c", command, (char *)NULL);
X        _exit (256);
X    } else {
X        if (Tcl_WaitPids(1, &processID, &processStatus) == -1) {
X            Tcl_AppendResult (interp, "Tcl_System: wait error",
X                              Tcl_UnixError (interp), (char*) NULL);
X            return -1;
X        }
X        return(WEXITSTATUS(processStatus));
X    }
X}
END_OF_FILE
if test 16951 -ne `wc -c <'extended/src/extendUtil.c'`; then
    echo shar: \"'extended/src/extendUtil.c'\" unpacked with wrong size!
fi
# end of 'extended/src/extendUtil.c'
fi
if test -f 'extended/src/filescan.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'extended/src/filescan.c'\"
else
echo shar: Extracting \"'extended/src/filescan.c'\" \(17911 characters\)
sed "s/^X//" >'extended/src/filescan.c' <<'END_OF_FILE'
X/*
X * filescan.c --
X *
X * Tcl file scanning: regular expression matching on lines of a file.
X * Implements awk.
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#include "regexp.h"
X
X/*
X * A scan context describes a collection of match patterns and commands,
X * along with a match default command to apply to a file on a scan.
X */
X
X#define CONTEXT_A_CASE_INSENSITIVE_FLAG 2
X#define MATCH_CASE_INSENSITIVE_FLAG 4
X
Xtypedef struct matchDef_t {
X    regexp_t            regExpInfo;
X    char               *command;
X    struct matchDef_t  *nextMatchDefPtr;
X    short               matchflags;
X    } matchDef_t;
Xtypedef struct matchDef_t *matchDef_pt;
X
Xtypedef struct scanContext_t {
X    matchDef_pt  matchListHead;
X    matchDef_pt  matchListTail;
X    char        *defaultAction;
X    short        flags;
X    } scanContext_t;
Xtypedef struct scanContext_t *scanContext_pt;
X
X/*
X * Global data structure, pointer to by clientData.
X */
X
Xtypedef struct {
X    int             useCount;      /* Commands that current share globals */
X    void_pt         tblHdrPtr;     /* Scan context handle table           */
X    char            curName [16];  /* Current context name.               */
X    } scanGlob_t;
Xtypedef scanGlob_t *scanGlob_pt;
X
X/*
X * Prototypes of internal functions.
X */
Xint
XCleanUpContext _ANSI_ARGS_((scanGlob_pt    scanGlobPtr,
X                            scanContext_pt contextPtr));
X
Xint
XCreateScanContext _ANSI_ARGS_((Tcl_Interp  *interp,
X                               scanGlob_pt  scanGlobPtr));
X
Xint
XSelectScanContext _ANSI_ARGS_((Tcl_Interp  *interp,
X                               scanGlob_pt  scanGlobPtr,
X                               char        *contextHandle));
X
Xint
XTcl_Delete_scancontextCmd _ANSI_ARGS_((Tcl_Interp  *interp,
X                                       scanGlob_pt  scanGlobPtr,
X                                       char        *contextHandle));
X
Xint
XSetMatchVar _ANSI_ARGS_((Tcl_Interp *interp,
X                         char       *fileLine,
X                         long        fileOffset,
X                         long        scanLineNum,
X                         char       *fileHandle));
X
Xvoid
XFileScanCleanUp _ANSI_ARGS_((ClientData clientData));
X
X
X/*
X *----------------------------------------------------------------------
X *
X * CleanUpContext
X *     Release all resources allocated to the specified scan context
X *     entry.  The entry itself is not released.
X *----------------------------------------------------------------------
X */
Xstatic int
XCleanUpContext (scanGlobPtr, contextPtr)
X    scanGlob_pt    scanGlobPtr;
X    scanContext_pt contextPtr;
X{
X    matchDef_pt  matchPtr, oldMatchPtr;
X
X    for (matchPtr = contextPtr->matchListHead; matchPtr != NULL;) {
X        Tcl_RegExpClean (&matchPtr->regExpInfo);
X        if (matchPtr->command != NULL)
X            ckfree(matchPtr->command);
X        oldMatchPtr = matchPtr;
X        matchPtr = matchPtr->nextMatchDefPtr;
X        ckfree ((char *) oldMatchPtr);
X        }
X    contextPtr->matchListHead = NULL;
X    contextPtr->matchListTail = NULL;
X
X    if (contextPtr->defaultAction != NULL) {
X        ckfree(contextPtr->defaultAction);
X        contextPtr->defaultAction = NULL;
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * CreateScanContext --
X *     Create a new scan context, implements the subcommand:
X *         scancontext create
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XCreateScanContext (interp, scanGlobPtr)
X    Tcl_Interp  *interp;
X    scanGlob_pt  scanGlobPtr;
X{
X    scanContext_pt contextPtr;
X
X    contextPtr = (scanContext_pt)Tcl_HandleAlloc (scanGlobPtr->tblHdrPtr,
X                                                  scanGlobPtr->curName);
X    contextPtr->flags = 0;
X    contextPtr->matchListHead = NULL;
X    contextPtr->matchListTail = NULL;
X    contextPtr->defaultAction = NULL;
X
X    Tcl_SetResult (interp, scanGlobPtr->curName, TCL_STATIC);
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * DeleteScanContext --
X *     Deletes the specified scan context, implements the subcommand:
X *         scancontext delete contexthandle
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XDeleteScanContext (interp, scanGlobPtr, contextHandle)
X    Tcl_Interp  *interp;
X    scanGlob_pt  scanGlobPtr;
X    char        *contextHandle;
X{
X    scanContext_pt contextPtr;
X
X    if ((contextPtr = Tcl_HandleXlate (interp, scanGlobPtr->tblHdrPtr,
X                                       contextHandle)) == NULL)
X        return TCL_ERROR;
X
X    CleanUpContext (scanGlobPtr, contextPtr);
X    Tcl_HandleFree (scanGlobPtr->tblHdrPtr, contextPtr);
X
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ScancontextCmd --
X *     Implements the TCL scancontext Tcl command, which has the
X *     following forms.
X *         scancontext create
X *         scancontext delete
X *
X * Results:
X *    Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XTcl_ScancontextCmd (clientData, interp, argc, argv)
X    char       *clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    scanGlob_pt  scanGlobPtr = (scanGlob_pt) clientData;
X
X    if (argc < 2) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], " option",
X                          (char *) NULL);
X        return TCL_ERROR;
X    }
X    /*
X     * Create a new scan context.
X     */
X    if (STREQU (argv [1], "create")) {
X        if (argc != 2) {
X            Tcl_AppendResult (interp, "wrong # args: ", argv [0], " create",
X                              (char *) NULL);
X            return TCL_ERROR;
X        }
X        return CreateScanContext (interp, scanGlobPtr);
X    }
X
X    /*
X     * Delete a scan context.
X     */
X    if (STREQU (argv [1], "delete")) {
X        if (argc != 3) {
X            Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                              "delete contexthandle", (char *) NULL);
X            return TCL_ERROR;
X        }
X        return DeleteScanContext (interp, scanGlobPtr, argv [2]);
X    }
X
X    Tcl_AppendResult (interp, "invalid argument, expected one of: ",
X                      "create or delete", (char *) NULL);
X    return TCL_ERROR;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ScanmatchCmd --
X *     Implements the TCL command:
X *         scanmatch [-nocase] contexthandle [regexp] commands
X *     This uses both Boyer_Moore and regular expressions matching.
X *
X * Results:
X *    Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XTcl_ScanmatchCmd (clientData, interp, argc, argv)
X    char       *clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    scanGlob_pt     scanGlobPtr = (scanGlob_pt) clientData;
X    scanContext_pt  contextPtr;
X    char           *result;
X    matchDef_pt     newmatch;
X    int             compFlags = REXP_BOTH_ALGORITHMS;
X    int             firstArg = 1;
X
X    if (argc < 3)
X        goto argError;
X    if (STREQU (argv[1], "-nocase")) {
X        compFlags |= REXP_NO_CASE;
X        firstArg = 2;
X    }
X
X    /*
X     * If firstArg == 2 (-nocase), the both a regular expression and a command
X     * string must be specified, otherwise the regular expression is optional.
X     */
X    if (((firstArg == 2) && (argc != 5)) || ((firstArg == 1) && (argc > 4)))
X        goto argError;
X
X    if ((contextPtr = Tcl_HandleXlate (interp, scanGlobPtr->tblHdrPtr,
X                                       argv [firstArg])) == NULL)
X        return TCL_ERROR;
X
X    /*
X     * Handle the default case (no regular expression).
X     */
X    if (argc == 3) {
X        if (contextPtr->defaultAction) {
X            Tcl_AppendResult (interp, argv [0], ": default match already ",
X                              "specified in this scan context", (char *) NULL);
X            return TCL_ERROR;
X        }
X        contextPtr->defaultAction = ckalloc (strlen (argv [2]) + 1);
X        strcpy (contextPtr->defaultAction, argv [2]);
X
X        return TCL_OK;
X    }
X
X    /*
X     * Add a regular expression to the context.
X     */
X
X    newmatch = (matchDef_pt) ckalloc(sizeof (matchDef_t));
X    newmatch->matchflags = 0;
X
X    if (compFlags & REXP_NO_CASE) {
X        newmatch->matchflags |= MATCH_CASE_INSENSITIVE_FLAG;
X        contextPtr->flags |= CONTEXT_A_CASE_INSENSITIVE_FLAG;
X    }
X
X    if (Tcl_RegExpCompile (interp, &newmatch->regExpInfo, argv [firstArg + 1],
X                           compFlags) != TCL_OK) {
X        ckfree ((char *) newmatch);
X        return (TCL_ERROR);
X    }
X
X    newmatch->command = ckalloc (strlen (argv[firstArg + 2]) + 1);
X    strcpy(newmatch->command, argv [firstArg + 2]);
X
X    /*
X     * Link in the new match.
X     */
X    newmatch->nextMatchDefPtr = NULL;
X    if (contextPtr->matchListHead == NULL)
X        contextPtr->matchListHead = newmatch;
X    else
X        contextPtr->matchListTail->nextMatchDefPtr = newmatch;
X    contextPtr->matchListTail = newmatch;
X
X    return TCL_OK;
X
XargError:
X    Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                      " [-nocase] contexthandle [regexp] command",
X                      (char *) NULL);
X    return TCL_ERROR;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * SetMatchVar --
X *     Sets the TCL array variable matchInfo to contain information
X *     about the line that is matched.
X * Results:
X *     TCL_OK if all is ok, TCL_ERROR if an error occures setting the
X *     variables.
X * Side effects:
X *     A TCL array variable is created or altered.
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XSetMatchVar (interp, fileLine, fileOffset, scanLineNum, fileHandle)
X    Tcl_Interp *interp;
X    char       *fileLine;
X    long        fileOffset;
X    long        scanLineNum;
X    char       *fileHandle;
X{
X    char numBuf [20];
X
X    if (Tcl_SetVar2 (interp, "matchInfo", "line", fileLine,
X                     TCL_LEAVE_ERR_MSG) == NULL)
X        return TCL_ERROR;
X
X    sprintf (numBuf, "%ld", fileOffset);
X    if (Tcl_SetVar2 (interp, "matchInfo", "offset", numBuf,
X                     TCL_LEAVE_ERR_MSG) == NULL)
X        return TCL_ERROR;
X
X    sprintf (numBuf, "%ld", scanLineNum);
X    if (Tcl_SetVar2 (interp, "matchInfo", "linenum", numBuf,
X                     TCL_LEAVE_ERR_MSG) == NULL)
X        return TCL_ERROR;
X
X    if (Tcl_SetVar2 (interp, "matchInfo", "handle", fileHandle,
X                     TCL_LEAVE_ERR_MSG) == NULL)
X        return TCL_ERROR;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ScanfileCmd --
X *     Implements the TCL command:
X *         scanfile contexthandle filehandle
X *
X * Results:
X *    Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
Xstatic int
XTcl_ScanfileCmd (clientData, interp, argc, argv)
X    char       *clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    scanGlob_pt     scanGlobPtr = (scanGlob_pt) clientData;
X    scanContext_pt  contextPtr;
X    dynamicBuf_t    dynBuf, lowerDynBuf;
X    OpenFile       *filePtr;
X    matchDef_pt     matchPtr;
X    int             result;
X    int             matchedAtLeastOne;
X    long            fileOffset;
X    long            matchOffset;
X    long            scanLineNum = 0;
X    char           *fileHandle;
X
X    if ((argc < 2) || (argc > 3)) {
X        Tcl_AppendResult (interp, "wrong # args: ", argv [0],
X                          " contexthandle filehandle", (char *) NULL);
X        return TCL_ERROR;
X    }
X    if ((contextPtr = Tcl_HandleXlate (interp, scanGlobPtr->tblHdrPtr,
X                                       argv [1])) == NULL)
X        return TCL_ERROR;
X
X    if (TclGetOpenFile (interp, argv [2], &filePtr) != TCL_OK)
X            return TCL_ERROR;
X
X    if (contextPtr->matchListHead == NULL) {
X        Tcl_AppendResult (interp, "no patterns in current scan context",
X                          (char *) NULL);
X        return TCL_ERROR;
X    }
X
X    Tcl_DynBufInit (&dynBuf);
X    Tcl_DynBufInit (&lowerDynBuf);
X
X    result = TCL_OK;  /* Assume the best */
X
X    fileOffset = ftell (filePtr->f);  /* Get starting offset */
X
X    while ((result == TCL_OK)) {
X        int storedThisLine = FALSE;
X
X        switch (Tcl_DynamicFgets (&dynBuf, filePtr->f)) {
X            case -1:  /* Error */
X                Tcl_AppendResult (interp, argv [0], ": ", fileHandle, ": ",
X                                  Tcl_UnixError (interp), (char *) NULL);
X                goto scanExit;
X
X            case 0:  /* EOF */
X                goto scanExit;
X        }
X        scanLineNum++;
X        matchOffset = fileOffset;
X        fileOffset += strlen(dynBuf.ptr) + 1;
X        storedThisLine = 0;
X        matchedAtLeastOne = 0;
X        if (contextPtr->flags & CONTEXT_A_CASE_INSENSITIVE_FLAG) {
X            lowerDynBuf.used = 0;
X            Tcl_DynBufAppend (&lowerDynBuf, dynBuf.ptr);
X            Tcl_DownShift (lowerDynBuf.ptr, dynBuf.ptr);
X        }
X        for (matchPtr = contextPtr->matchListHead; matchPtr != NULL;
X                 matchPtr = matchPtr->nextMatchDefPtr) {
X
X            if (!Tcl_RegExpExecute (interp, &matchPtr->regExpInfo, dynBuf.ptr,
X                                    lowerDynBuf.ptr))
X                continue;  /* Try next match pattern */
X
X            matchedAtLeastOne = TRUE;
X            if (!storedThisLine) {
X                result = SetMatchVar (interp, dynBuf.ptr, matchOffset,
X                                      scanLineNum, argv[2]);
X                if (result != TCL_OK)
X                    goto scanExit;
X                storedThisLine = TRUE;
X            }
X
X            result = Tcl_Eval(interp, matchPtr->command, 0, (char **)NULL);
X            if (result == TCL_ERROR) {
X                Tcl_AddErrorInfo (interp,
X                    "\n    while executing a match command");
X                goto scanExit;
X            }
X            if (result == TCL_CONTINUE) {
X                /*
X                 * Don't process any more matches for this line.
X                 */
X                result = TCL_OK;
X                goto matchLineExit;
X            }
X            if (result == TCL_BREAK) {
X                /*
X                 * Terminate scan.
X                 */
X                result = TCL_OK;
X                goto scanExit;
X            }
X        }
X
X        matchLineExit:
X        /*
X         * Process default action if required.
X         */
X        if ((contextPtr->defaultAction != NULL) && (!matchedAtLeastOne)) {
X
X            result = SetMatchVar (interp, dynBuf.ptr, matchOffset,
X                                  scanLineNum, argv[2]);
X            if (result != TCL_OK)
X                goto scanExit;
X
X            result = Tcl_Eval (interp, contextPtr->defaultAction, 0,
X                               (char **)NULL);
X            if (result == TCL_CONTINUE)
X                result = TCL_OK;    /* This doesn't mean anything, but  */
X                                    /* don't break the user.            */
X            if (result == TCL_ERROR)
X                Tcl_AddErrorInfo (interp,
X                    "\n    while executing a match default command");
X        }
X    }
XscanExit:
X    Tcl_DynBufFree (&dynBuf);
X    Tcl_DynBufFree (&lowerDynBuf);
X    if (result == TCL_RETURN)
X        result = TCL_OK;
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X *  FileScanCleanUp --
X *      Decrements the use count on the globals when a command is deleted.
X *      If it goes to zero, all resources are released.
X *
X *----------------------------------------------------------------------
X */
Xstatic void
XFileScanCleanUp (clientData)
X    ClientData clientData;
X{
X    scanGlob_pt    scanGlobPtr = (scanGlob_pt) clientData;
X    scanContext_pt contextPtr;
X    int            walkKey;
X
X    scanGlobPtr->useCount--;
X    if (scanGlobPtr->useCount > 0)
X        return;
X
X    walkKey = -1;
X    while ((contextPtr = Tcl_HandleWalk (scanGlobPtr->tblHdrPtr,
X            &walkKey)) != NULL)
X        CleanUpContext (scanGlobPtr, contextPtr);
X
X    Tcl_HandleTblRelease (scanGlobPtr->tblHdrPtr);
X    ckfree ((char *) scanGlobPtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X *  Tcl_InitFilescan --
X *      Initialize the TCL file scanning facility..
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_InitFilescan (interp)
XTcl_Interp *interp;
X{
X    scanGlob_pt    scanGlobPtr;
X    void_pt        fileCbTblPtr;
X
X    scanGlobPtr = (scanGlob_pt) ckalloc (sizeof (scanGlob_t));
X    scanGlobPtr->tblHdrPtr =
X        Tcl_HandleTblInit ("context", sizeof (scanContext_t), 5);
X
X    /*
X     * Initialize the commands.
X     */
X    scanGlobPtr->useCount = 3;  /* Number of commands */
X
X    Tcl_CreateCommand (interp, "scanfile", Tcl_ScanfileCmd,
X                       (ClientData)scanGlobPtr, FileScanCleanUp);
X    Tcl_CreateCommand (interp, "scanmatch", Tcl_ScanmatchCmd,
X                       (ClientData)scanGlobPtr, FileScanCleanUp);
X    Tcl_CreateCommand (interp, "scancontext", Tcl_ScancontextCmd,
X                       (ClientData)scanGlobPtr, FileScanCleanUp);
X}
X
END_OF_FILE
if test 17911 -ne `wc -c <'extended/src/filescan.c'`; then
    echo shar: \"'extended/src/filescan.c'\" unpacked with wrong size!
fi
# end of 'extended/src/filescan.c'
fi
echo shar: End of archive 18 \(of 23\).
cp /dev/null ark18isdone
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: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].