git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxfsca.c

   1 /*
   2  * tclXfilescan.c --
   3  *
   4  * Tcl file scanning: regular expression matching on lines of a file.
   5  * Implements awk.
   6  *-----------------------------------------------------------------------------
   7  * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
   8  *
   9  * Permission to use, copy, modify, and distribute this software and its
  10  * documentation for any purpose and without fee is hereby granted, provided
  11  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12  * Mark Diekhans make no representations about the suitability of this
  13  * software for any purpose.  It is provided "as is" without express or
  14  * implied warranty.
  15  *-----------------------------------------------------------------------------
  16  * $Id: tclXfilescan.c,v 2.0 1992/10/16 04:50:43 markd Rel $
  17  *-----------------------------------------------------------------------------
  18  */
  19
  20 #include "tclxint.h"
  21 #include "regexp.h"
  22
  23 /*
  24  * A scan context describes a collection of match patterns and commands,
  25  * along with a match default command to apply to a file on a scan.
  26  */
  27
  28 #define CONTEXT_A_CASE_INSENSITIVE_FLAG 2
  29 #define MATCH_CASE_INSENSITIVE_FLAG 4
  30
  31 typedef struct matchDef_t {
  32     regexp_t            regExpInfo;
  33     char               *command;
  34     struct matchDef_t  *nextMatchDefPtr;
  35     short               matchflags;
  36     } matchDef_t;
  37 typedef struct matchDef_t *matchDef_pt;
  38
  39 typedef struct scanContext_t {
  40     matchDef_pt  matchListHead;
  41     matchDef_pt  matchListTail;
  42     char        *defaultAction;
  43     short        flags;
  44     } scanContext_t;
  45 typedef struct scanContext_t *scanContext_pt;
  46
  47 /*
  48  * Global data structure, pointer to by clientData.
  49  */
  50
  51 typedef struct {
  52     int             useCount;      /* Commands that current share globals */
  53     void_pt         tblHdrPtr;     /* Scan context handle table           */
  54     char            curName [16];  /* Current context name.               */
  55     } scanGlob_t;
  56 typedef scanGlob_t *scanGlob_pt;
  57
  58 /*
  59  * Prototypes of internal functions.
  60  */
  61 static int
  62 CleanUpContext _ANSI_ARGS_((scanGlob_pt    scanGlobPtr,
  63                             scanContext_pt contextPtr));
  64
  65 static int
  66 CreateScanContext _ANSI_ARGS_((Tcl_Interp  *interp,
  67                                scanGlob_pt  scanGlobPtr));
  68
  69 static int
  70 SelectScanContext _ANSI_ARGS_((Tcl_Interp  *interp,
  71                                scanGlob_pt  scanGlobPtr,
  72                                char        *contextHandle));
  73
  74 static int
  75 Tcl_Delete_scancontextCmd _ANSI_ARGS_((Tcl_Interp  *interp,
  76                                        scanGlob_pt  scanGlobPtr,
  77                                        char        *contextHandle));
  78
  79 static int
  80 SetMatchVar _ANSI_ARGS_((Tcl_Interp *interp,
  81                          char       *fileLine,
  82                          long        fileOffset,
  83                          long        scanLineNum,
  84                          char       *fileHandle));
  85
  86 static void
  87 FileScanCleanUp _ANSI_ARGS_((ClientData clientData));
  88
  89 \f
  90 /*
  91  *-----------------------------------------------------------------------------
  92  *
  93  * CleanUpContext
  94  *     Release all resources allocated to the specified scan context
  95  *     entry.  The entry itself is not released.
  96  *-----------------------------------------------------------------------------
  97  */
  98 static int
  99 CleanUpContext (scanGlobPtr, contextPtr)
 100     scanGlob_pt    scanGlobPtr;
 101     scanContext_pt contextPtr;
 102 {
 103     matchDef_pt  matchPtr, oldMatchPtr;
 104
 105     for (matchPtr = contextPtr->matchListHead; matchPtr != NULL;) {
 106         Tcl_RegExpClean (&matchPtr->regExpInfo);
 107         if (matchPtr->command != NULL)
 108             ckfree(matchPtr->command);
 109         oldMatchPtr = matchPtr;
 110         matchPtr = matchPtr->nextMatchDefPtr;
 111         ckfree ((char *) oldMatchPtr);
 112         }
 113     contextPtr->matchListHead = NULL;
 114     contextPtr->matchListTail = NULL;
 115
 116     if (contextPtr->defaultAction != NULL) {
 117         ckfree(contextPtr->defaultAction);
 118         contextPtr->defaultAction = NULL;
 119     }
 120 }
 121 \f
 122 /*
 123  *-----------------------------------------------------------------------------
 124  *
 125  * CreateScanContext --
 126  *     Create a new scan context, implements the subcommand:
 127  *         scancontext create
 128  *
 129  *-----------------------------------------------------------------------------
 130  */
 131 static int
 132 CreateScanContext (interp, scanGlobPtr)
 133     Tcl_Interp  *interp;
 134     scanGlob_pt  scanGlobPtr;
 135 {
 136     scanContext_pt contextPtr;
 137
 138     contextPtr = (scanContext_pt)Tcl_HandleAlloc (scanGlobPtr->tblHdrPtr,
 139                                                   scanGlobPtr->curName);
 140     contextPtr->flags = 0;
 141     contextPtr->matchListHead = NULL;
 142     contextPtr->matchListTail = NULL;
 143     contextPtr->defaultAction = NULL;
 144
 145     Tcl_SetResult (interp, scanGlobPtr->curName, TCL_STATIC);
 146     return TCL_OK;
 147 }
 148 \f
 149 /*
 150  *-----------------------------------------------------------------------------
 151  *
 152  * DeleteScanContext --
 153  *     Deletes the specified scan context, implements the subcommand:
 154  *         scancontext delete contexthandle
 155  *
 156  *-----------------------------------------------------------------------------
 157  */
 158 static int
 159 DeleteScanContext (interp, scanGlobPtr, contextHandle)
 160     Tcl_Interp  *interp;
 161     scanGlob_pt  scanGlobPtr;
 162     char        *contextHandle;
 163 {
 164     scanContext_pt contextPtr;
 165
 166     if ((contextPtr = Tcl_HandleXlate (interp, scanGlobPtr->tblHdrPtr,
 167                                        contextHandle)) == NULL)
 168         return TCL_ERROR;
 169
 170     CleanUpContext (scanGlobPtr, contextPtr);
 171     Tcl_HandleFree (scanGlobPtr->tblHdrPtr, contextPtr);
 172
 173     return TCL_OK;
 174 }
 175 \f
 176 /*
 177  *-----------------------------------------------------------------------------
 178  *
 179  * Tcl_ScancontextCmd --
 180  *     Implements the TCL scancontext Tcl command, which has the
 181  *     following forms.
 182  *         scancontext create
 183  *         scancontext delete
 184  *
 185  * Results:
 186  *    Standard TCL results.
 187  *
 188  *-----------------------------------------------------------------------------
 189  */
 190 static int
 191 Tcl_ScancontextCmd (clientData, interp, argc, argv)
 192     char       *clientData;
 193     Tcl_Interp *interp;
 194     int         argc;
 195     char      **argv;
 196 {
 197     scanGlob_pt  scanGlobPtr = (scanGlob_pt) clientData;
 198
 199     if (argc < 2) {
 200         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " option",
 201                           (char *) NULL);
 202         return TCL_ERROR;
 203     }
 204     /*
 205      * Create a new scan context.
 206      */
 207     if (STREQU (argv [1], "create")) {
 208         if (argc != 2) {
 209             Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " create",
 210                               (char *) NULL);
 211             return TCL_ERROR;
 212         }
 213         return CreateScanContext (interp, scanGlobPtr);
 214     }
 215
 216     /*
 217      * Delete a scan context.
 218      */
 219     if (STREQU (argv [1], "delete")) {
 220         if (argc != 3) {
 221             Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
 222                               "delete contexthandle", (char *) NULL);
 223             return TCL_ERROR;
 224         }
 225         return DeleteScanContext (interp, scanGlobPtr, argv [2]);
 226     }
 227
 228     Tcl_AppendResult (interp, "invalid argument, expected one of: ",
 229                       "create or delete", (char *) NULL);
 230     return TCL_ERROR;
 231 }
 232 \f
 233 /*
 234  *-----------------------------------------------------------------------------
 235  *
 236  * Tcl_ScanmatchCmd --
 237  *     Implements the TCL command:
 238  *         scanmatch [-nocase] contexthandle [regexp] commands
 239  *     This uses both Boyer_Moore and regular expressions matching.
 240  *
 241  * Results:
 242  *    Standard TCL results.
 243  *
 244  *-----------------------------------------------------------------------------
 245  */
 246 static int
 247 Tcl_ScanmatchCmd (clientData, interp, argc, argv)
 248     char       *clientData;
 249     Tcl_Interp *interp;
 250     int         argc;
 251     char      **argv;
 252 {
 253     scanGlob_pt     scanGlobPtr = (scanGlob_pt) clientData;
 254     scanContext_pt  contextPtr;
 255     char           *result;
 256     matchDef_pt     newmatch;
 257     int             compFlags = REXP_BOTH_ALGORITHMS;
 258     int             firstArg = 1;
 259
 260     if (argc < 3)
 261         goto argError;
 262     if (STREQU (argv[1], "-nocase")) {
 263         compFlags |= REXP_NO_CASE;
 264         firstArg = 2;
 265     }
 266
 267     /*
 268      * If firstArg == 2 (-nocase), the both a regular expression and a command
 269      * string must be specified, otherwise the regular expression is optional.
 270      */
 271     if (((firstArg == 2) && (argc != 5)) || ((firstArg == 1) && (argc > 4)))
 272         goto argError;
 273
 274     if ((contextPtr = Tcl_HandleXlate (interp, scanGlobPtr->tblHdrPtr,
 275                                        argv [firstArg])) == NULL)
 276         return TCL_ERROR;
 277
 278     /*
 279      * Handle the default case (no regular expression).
 280      */
 281     if (argc == 3) {
 282         if (contextPtr->defaultAction) {
 283             Tcl_AppendResult (interp, argv [0], ": default match already ",
 284                               "specified in this scan context", (char *) NULL);
 285             return TCL_ERROR;
 286         }
 287         contextPtr->defaultAction = ckalloc (strlen (argv [2]) + 1);
 288         strcpy (contextPtr->defaultAction, argv [2]);
 289
 290         return TCL_OK;
 291     }
 292
 293     /*
 294      * Add a regular expression to the context.
 295      */
 296
 297     newmatch = (matchDef_pt) ckalloc(sizeof (matchDef_t));
 298     newmatch->matchflags = 0;
 299
 300     if (compFlags & REXP_NO_CASE) {
 301         newmatch->matchflags |= MATCH_CASE_INSENSITIVE_FLAG;
 302         contextPtr->flags |= CONTEXT_A_CASE_INSENSITIVE_FLAG;
 303     }
 304
 305     if (Tcl_RegExpCompile (interp, &newmatch->regExpInfo, argv [firstArg + 1],
 306                            compFlags) != TCL_OK) {
 307         ckfree ((char *) newmatch);
 308         return (TCL_ERROR);
 309     }
 310
 311     newmatch->command = ckalloc (strlen (argv[firstArg + 2]) + 1);
 312     strcpy(newmatch->command, argv [firstArg + 2]);
 313
 314     /*
 315      * Link in the new match.
 316      */
 317     newmatch->nextMatchDefPtr = NULL;
 318     if (contextPtr->matchListHead == NULL)
 319         contextPtr->matchListHead = newmatch;
 320     else
 321         contextPtr->matchListTail->nextMatchDefPtr = newmatch;
 322     contextPtr->matchListTail = newmatch;
 323
 324     return TCL_OK;
 325
 326 argError:
 327     Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
 328                       " [-nocase] contexthandle [regexp] command",
 329                       (char *) NULL);
 330     return TCL_ERROR;
 331 }
 332 \f
 333 /*
 334  *-----------------------------------------------------------------------------
 335  *
 336  * SetMatchVar --
 337  *     Sets the TCL array variable matchInfo to contain information
 338  *     about the line that is matched.
 339  * Results:
 340  *     TCL_OK if all is ok, TCL_ERROR if an error occures setting the
 341  *     variables.
 342  * Side effects:
 343  *     A TCL array variable is created or altered.
 344  *
 345  *-----------------------------------------------------------------------------
 346  */
 347 static int
 348 SetMatchVar (interp, fileLine, fileOffset, scanLineNum, fileHandle)
 349     Tcl_Interp *interp;
 350     char       *fileLine;
 351     long        fileOffset;
 352     long        scanLineNum;
 353     char       *fileHandle;
 354 {
 355     char numBuf [20];
 356
 357     if (Tcl_SetVar2 (interp, "matchInfo", "line", fileLine,
 358                      TCL_LEAVE_ERR_MSG) == NULL)
 359         return TCL_ERROR;
 360
 361     sprintf (numBuf, "%ld", fileOffset);
 362     if (Tcl_SetVar2 (interp, "matchInfo", "offset", numBuf,
 363                      TCL_LEAVE_ERR_MSG) == NULL)
 364         return TCL_ERROR;
 365
 366     sprintf (numBuf, "%ld", scanLineNum);
 367     if (Tcl_SetVar2 (interp, "matchInfo", "linenum", numBuf,
 368                      TCL_LEAVE_ERR_MSG) == NULL)
 369         return TCL_ERROR;
 370
 371     if (Tcl_SetVar2 (interp, "matchInfo", "handle", fileHandle,
 372                      TCL_LEAVE_ERR_MSG) == NULL)
 373         return TCL_ERROR;
 374     return TCL_OK;
 375 }
 376 \f
 377 /*
 378  *-----------------------------------------------------------------------------
 379  *
 380  * Tcl_ScanfileCmd --
 381  *     Implements the TCL command:
 382  *         scanfile contexthandle filehandle
 383  *
 384  * Results:
 385  *    Standard TCL results.
 386  *
 387  *-----------------------------------------------------------------------------
 388  */
 389 static int
 390 Tcl_ScanfileCmd (clientData, interp, argc, argv)
 391     char       *clientData;
 392     Tcl_Interp *interp;
 393     int         argc;
 394     char      **argv;
 395 {
 396     scanGlob_pt     scanGlobPtr = (scanGlob_pt) clientData;
 397     scanContext_pt  contextPtr;
 398     dynamicBuf_t    dynBuf, lowerDynBuf;
 399     OpenFile       *filePtr;
 400     matchDef_pt     matchPtr;
 401     int             result;
 402     int             matchedAtLeastOne;
 403     long            fileOffset;
 404     long            matchOffset;
 405     long            scanLineNum = 0;
 406     char           *fileHandle;
 407
 408     if ((argc < 2) || (argc > 3)) {
 409         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
 410                           " contexthandle filehandle", (char *) NULL);
 411         return TCL_ERROR;
 412     }
 413     if ((contextPtr = Tcl_HandleXlate (interp, scanGlobPtr->tblHdrPtr,
 414                                        argv [1])) == NULL)
 415         return TCL_ERROR;
 416
 417     if (TclGetOpenFile (interp, argv [2], &filePtr) != TCL_OK)
 418             return TCL_ERROR;
 419
 420     if (contextPtr->matchListHead == NULL) {
 421         Tcl_AppendResult (interp, "no patterns in current scan context",
 422                           (char *) NULL);
 423         return TCL_ERROR;
 424     }
 425
 426     Tcl_DynBufInit (&dynBuf);
 427     Tcl_DynBufInit (&lowerDynBuf);
 428
 429     result = TCL_OK;  /* Assume the best */
 430
 431     fileOffset = ftell (filePtr->f);  /* Get starting offset */
 432
 433     while ((result == TCL_OK)) {
 434         int storedThisLine = FALSE;
 435
 436         switch (Tcl_DynamicFgets (&dynBuf, filePtr->f, FALSE)) {
 437           case -1:  /* Error */
 438             interp->result = Tcl_UnixError (interp);
 439             goto scanExit;
 440
 441           case 0:  /* EOF */
 442             goto scanExit;
 443         }
 444         scanLineNum++;
 445         matchOffset = fileOffset;
 446         fileOffset += strlen(dynBuf.ptr) + 1;
 447         storedThisLine = 0;
 448         matchedAtLeastOne = 0;
 449         if (contextPtr->flags & CONTEXT_A_CASE_INSENSITIVE_FLAG) {
 450             lowerDynBuf.len = 0;
 451             Tcl_DynBufAppend (&lowerDynBuf, dynBuf.ptr);
 452             Tcl_DownShift (lowerDynBuf.ptr, lowerDynBuf.ptr);
 453         }
 454         for (matchPtr = contextPtr->matchListHead; matchPtr != NULL;
 455                  matchPtr = matchPtr->nextMatchDefPtr) {
 456
 457             if (!Tcl_RegExpExecute (interp, &matchPtr->regExpInfo, dynBuf.ptr,
 458                                     lowerDynBuf.ptr))
 459                 continue;  /* Try next match pattern */
 460
 461             matchedAtLeastOne = TRUE;
 462             if (!storedThisLine) {
 463                 result = SetMatchVar (interp, dynBuf.ptr, matchOffset,
 464                                       scanLineNum, argv[2]);
 465                 if (result != TCL_OK)
 466                     goto scanExit;
 467                 storedThisLine = TRUE;
 468             }
 469
 470             result = Tcl_Eval(interp, matchPtr->command, 0, (char **)NULL);
 471             if (result == TCL_ERROR) {
 472                 Tcl_AddErrorInfo (interp,
 473                     "\n    while executing a match command");
 474                 goto scanExit;
 475             }
 476             if (result == TCL_CONTINUE) {
 477                 /*
 478                  * Don't process any more matches for this line.
 479                  */
 480                 result = TCL_OK;
 481                 goto matchLineExit;
 482             }
 483             if (result == TCL_BREAK) {
 484                 /*
 485                  * Terminate scan.
 486                  */
 487                 result = TCL_OK;
 488                 goto scanExit;
 489             }
 490         }
 491
 492         matchLineExit:
 493         /*
 494          * Process default action if required.
 495          */
 496         if ((contextPtr->defaultAction != NULL) && (!matchedAtLeastOne)) {
 497
 498             result = SetMatchVar (interp, dynBuf.ptr, matchOffset,
 499                                   scanLineNum, argv[2]);
 500             if (result != TCL_OK)
 501                 goto scanExit;
 502
 503             result = Tcl_Eval (interp, contextPtr->defaultAction, 0,
 504                                (char **)NULL);
 505             if (result == TCL_CONTINUE)
 506                 result = TCL_OK;    /* This doesn't mean anything, but  */
 507                                     /* don't break the user.            */
 508             if (result == TCL_ERROR)
 509                 Tcl_AddErrorInfo (interp,
 510                     "\n    while executing a match default command");
 511         }
 512     }
 513 scanExit:
 514     Tcl_DynBufFree (&dynBuf);
 515     Tcl_DynBufFree (&lowerDynBuf);
 516     if (result == TCL_RETURN)
 517         result = TCL_OK;
 518     return result;
 519 }
 520 \f
 521 /*
 522  *-----------------------------------------------------------------------------
 523  *
 524  *  FileScanCleanUp --
 525  *      Decrements the use count on the globals when a command is deleted.
 526  *      If it goes to zero, all resources are released.
 527  *
 528  *-----------------------------------------------------------------------------
 529  */
 530 static void
 531 FileScanCleanUp (clientData)
 532     ClientData clientData;
 533 {
 534     scanGlob_pt    scanGlobPtr = (scanGlob_pt) clientData;
 535     scanContext_pt contextPtr;
 536     int            walkKey;
 537
 538     scanGlobPtr->useCount--;
 539     if (scanGlobPtr->useCount > 0)
 540         return;
 541
 542     walkKey = -1;
 543     while ((contextPtr = Tcl_HandleWalk (scanGlobPtr->tblHdrPtr,
 544             &walkKey)) != NULL)
 545         CleanUpContext (scanGlobPtr, contextPtr);
 546
 547     Tcl_HandleTblRelease (scanGlobPtr->tblHdrPtr);
 548     ckfree ((char *) scanGlobPtr);
 549 }
 550 \f
 551 /*
 552  *-----------------------------------------------------------------------------
 553  *
 554  *  Tcl_InitFilescan --
 555  *      Initialize the TCL file scanning facility..
 556  *
 557  *-----------------------------------------------------------------------------
 558  */
 559 void
 560 Tcl_InitFilescan (interp)
 561 Tcl_Interp *interp;
 562 {
 563     scanGlob_pt    scanGlobPtr;
 564     void_pt        fileCbTblPtr;
 565
 566     scanGlobPtr = (scanGlob_pt) ckalloc (sizeof (scanGlob_t));
 567     scanGlobPtr->tblHdrPtr =
 568         Tcl_HandleTblInit ("context", sizeof (scanContext_t), 5);
 569
 570     /*
 571      * Initialize the commands.
 572      */
 573     scanGlobPtr->useCount = 3;  /* Number of commands */
 574
 575     Tcl_CreateCommand (interp, "scanfile", Tcl_ScanfileCmd,
 576                        (ClientData)scanGlobPtr, FileScanCleanUp);
 577     Tcl_CreateCommand (interp, "scanmatch", Tcl_ScanmatchCmd,
 578                        (ClientData)scanGlobPtr, FileScanCleanUp);
 579     Tcl_CreateCommand (interp, "scancontext", Tcl_ScancontextCmd,
 580                        (ClientData)scanGlobPtr, FileScanCleanUp);
 581 }
 582