1/*
2 * tclXfilescan.c --
3 *
4 * Tcl file scanning: regular expression matching on lines of a file.
5 * Implements awk.
6 *-----------------------------------------------------------------------------
7 * Copyright 1991-1999 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 1.4 2005/04/26 20:01:33 hobbs Exp $
17 *-----------------------------------------------------------------------------
18 */
19
20#include "tclExtdInt.h"
21
22/*
23 * A scan context describes a collection of match patterns and commands,
24 * along with a match default command to apply to a file on a scan.
25 */
26
27typedef struct matchDef_t {
28    Tcl_RegExp          regExp;
29    Tcl_Obj            *regExpObj;
30    Tcl_Obj            *command;
31    struct matchDef_t  *nextMatchDefPtr;
32} matchDef_t;
33
34typedef struct scanContext_t {
35    matchDef_t  *matchListHead;
36    matchDef_t  *matchListTail;
37    Tcl_Obj     *defaultAction;
38    char         contextHandle [16];
39    Tcl_Channel  copyFileChannel;
40    int          fileOpen;
41} scanContext_t;
42
43/*
44 * Data kept on a specific scan.
45 */
46typedef struct {
47    int               storedLine;   /* Has the current line been stored in
48                                       matchInfo? */
49    scanContext_t    *contextPtr;   /* Current scan context. */
50    Tcl_Channel       channel;      /* The channel being scanned. */
51    char             *line;         /* The line from the file. */
52    Tcl_UniChar      *uniLine;      /* UniCode (wide) char line. */
53    int               uniLineLen;
54    off_t             offset;       /* The offset into the file. */
55    long              bytesRead;    /* Number of translated bytes read.*/
56    long              lineNum;      /* Current scanned line in the file. */
57    matchDef_t       *matchPtr;     /* The current match, or NULL for the
58                                       default. */
59} scanData_t;
60
61/*
62 * Prototypes of internal functions.
63 */
64static void
65CleanUpContext _ANSI_ARGS_((void_pt         scanTablePtr,
66                            scanContext_t  *contextPtr));
67
68static int
69ScanContextCreate _ANSI_ARGS_((Tcl_Interp  *interp,
70                               void_pt      scanTablePtr));
71
72static int
73ScanContextDelete _ANSI_ARGS_((Tcl_Interp  *interp,
74                               void_pt      scanTablePtr,
75                               Tcl_Obj     *contextHandleObj));
76
77static int
78ScanContextCopyFile _ANSI_ARGS_((Tcl_Interp  *interp,
79                                 void_pt      scanTablePtr,
80                                 Tcl_Obj     *contextHandleObj,
81                                 Tcl_Obj     *fileHandleObj));
82
83static int
84TclX_ScancontextObjCmd _ANSI_ARGS_((ClientData  clientData,
85                                    Tcl_Interp *interp,
86                                    int         objc,
87                                    Tcl_Obj    *CONST objv[]));
88
89static int
90TclX_ScanmatchObjCmd _ANSI_ARGS_((ClientData  clientData,
91                                  Tcl_Interp *interp,
92                                  int         objc,
93                                  Tcl_Obj    *CONST objv[]));
94
95static void
96CopyFileCloseHandler _ANSI_ARGS_((ClientData clientData));
97
98static int
99SetCopyFileObj _ANSI_ARGS_((Tcl_Interp    *interp,
100                            scanContext_t *contextPtr,
101                            Tcl_Obj       *fileHandleObj));
102
103static void
104ClearCopyFile _ANSI_ARGS_((scanContext_t *contextPtr));
105
106static int
107SetMatchInfoVar _ANSI_ARGS_((Tcl_Interp *interp,
108                             scanData_t *scanData));
109
110static int
111ScanFile _ANSI_ARGS_((Tcl_Interp    *interp,
112                      scanContext_t *contextPtr,
113                      Tcl_Channel    channel));
114
115static void
116ScanFileCloseHandler _ANSI_ARGS_((ClientData clientData));
117
118static int
119TclX_ScanfileObjCmd _ANSI_ARGS_((ClientData  clientData,
120                                 Tcl_Interp *interp,
121                                 int         objc,
122                                 Tcl_Obj    *CONST objv[]));
123
124static void
125FileScanCleanUp _ANSI_ARGS_((ClientData  clientData,
126                             Tcl_Interp *interp));
127
128
129/*-----------------------------------------------------------------------------
130 * CleanUpContext --
131 *
132 *   Release all resources allocated to the specified scan context.  Doesn't
133 * free the table entry.
134 *-----------------------------------------------------------------------------
135 */
136static void
137CleanUpContext (scanTablePtr, contextPtr)
138    void_pt        scanTablePtr;
139    scanContext_t *contextPtr;
140{
141    matchDef_t  *matchPtr, *oldMatchPtr;
142
143    for (matchPtr = contextPtr->matchListHead; matchPtr != NULL;) {
144        Tcl_DecrRefCount(matchPtr->regExpObj);
145        if (matchPtr->command != NULL)
146            Tcl_DecrRefCount (matchPtr->command);
147        oldMatchPtr = matchPtr;
148        matchPtr = matchPtr->nextMatchDefPtr;
149        ckfree ((char *) oldMatchPtr);
150    }
151    if (contextPtr->defaultAction != NULL) {
152        Tcl_DecrRefCount (contextPtr->defaultAction);
153    }
154    ClearCopyFile (contextPtr);
155    ckfree ((char *) contextPtr);
156}
157
158/*-----------------------------------------------------------------------------
159 * ScanContextCreate --
160 *
161 *   Create a new scan context, implements the subcommand:
162 *         scancontext create
163 *-----------------------------------------------------------------------------
164 */
165static int
166ScanContextCreate (interp, scanTablePtr)
167    Tcl_Interp  *interp;
168    void_pt      scanTablePtr;
169{
170    scanContext_t *contextPtr, **tableEntryPtr;
171
172    contextPtr = (scanContext_t *) ckalloc (sizeof (scanContext_t));
173    contextPtr->matchListHead = NULL;
174    contextPtr->matchListTail = NULL;
175    contextPtr->defaultAction = NULL;
176    contextPtr->copyFileChannel = NULL;
177
178    tableEntryPtr = (scanContext_t **)
179        TclX_HandleAlloc (scanTablePtr,
180                          contextPtr->contextHandle);
181    *tableEntryPtr = contextPtr;
182
183    Tcl_SetStringObj (Tcl_GetObjResult (interp),
184                      contextPtr->contextHandle, -1);
185    return TCL_OK;
186}
187
188/*-----------------------------------------------------------------------------
189 * ScanContextDelete --
190 *
191 *   Deletes the specified scan context, implements the subcommand:
192 *         scancontext delete contexthandle
193 *-----------------------------------------------------------------------------
194 */
195static int
196ScanContextDelete (interp, scanTablePtr, contextHandleObj)
197    Tcl_Interp  *interp;
198    void_pt      scanTablePtr;
199    Tcl_Obj     *contextHandleObj;
200{
201    scanContext_t **tableEntryPtr;
202    char           *contextHandle;
203
204    contextHandle = Tcl_GetStringFromObj (contextHandleObj, NULL);
205
206    tableEntryPtr = (scanContext_t **) TclX_HandleXlate (interp,
207                                                         scanTablePtr,
208                                                         contextHandle);
209    if (tableEntryPtr == NULL)
210        return TCL_ERROR;
211
212    CleanUpContext (scanTablePtr, *tableEntryPtr);
213    TclX_HandleFree (scanTablePtr, tableEntryPtr);
214
215    return TCL_OK;
216}
217
218/*-----------------------------------------------------------------------------
219 * CopyFileCloseHandler --
220 *   Close handler for the copyfile.  Turns off copying to the file.
221 * Parameters:
222 *   o clientData (I) - Pointer to the scan context.
223 *-----------------------------------------------------------------------------
224 */
225static void
226CopyFileCloseHandler (clientData)
227    ClientData clientData;
228{
229    ((scanContext_t *) clientData)->copyFileChannel = NULL;
230}
231
232/*-----------------------------------------------------------------------------
233 * SetCopyFileObj --
234 *   Set the copy file handle for a context.
235 * Parameters:
236 *   o interp - The Tcl interpreter, errors are returned in result.
237 *   o contextPtr - Pointer to the scan context.
238 *   o fileHandleObj - Object containing file handle of the copy file.
239 * Returns:
240 *   TCL_OK or TCL_ERROR.
241 *-----------------------------------------------------------------------------
242 */
243static int
244SetCopyFileObj (interp, contextPtr, fileHandleObj)
245    Tcl_Interp    *interp;
246    scanContext_t *contextPtr;
247    Tcl_Obj       *fileHandleObj;
248{
249    Tcl_Channel copyFileChannel;
250
251    copyFileChannel = TclX_GetOpenChannelObj (interp, fileHandleObj,
252                                              TCL_WRITABLE);
253    if (copyFileChannel == NULL)
254        return TCL_ERROR;
255
256    /*
257     * Delete the old copyfile and set the new one.
258     */
259    if (contextPtr->copyFileChannel != NULL) {
260        Tcl_DeleteCloseHandler (contextPtr->copyFileChannel,
261                                CopyFileCloseHandler,
262                                (ClientData) contextPtr);
263    }
264    Tcl_CreateCloseHandler (copyFileChannel,
265                            CopyFileCloseHandler,
266                            (ClientData) contextPtr);
267    contextPtr->copyFileChannel = copyFileChannel;
268    return TCL_OK;
269}
270
271/*-----------------------------------------------------------------------------
272 * ClearCopyFile --
273 *   Clear the copy file handle for a context.
274 * Parameters:
275 *   o contextPtr (I) - Pointer to the scan context.
276 *-----------------------------------------------------------------------------
277 */
278static void
279ClearCopyFile (contextPtr)
280    scanContext_t *contextPtr;
281{
282    if (contextPtr->copyFileChannel != NULL) {
283        Tcl_DeleteCloseHandler (contextPtr->copyFileChannel,
284                                CopyFileCloseHandler,
285                                (ClientData) contextPtr);
286        contextPtr->copyFileChannel = NULL;
287    }
288}
289
290/*-----------------------------------------------------------------------------
291 * ScanContextCopyFile --
292 *
293 *   Access or set the copy file handle for the specified scan context,
294 * implements the subcommand:
295 *         scancontext copyfile contexthandle ?filehandle?
296 *-----------------------------------------------------------------------------
297 */
298static int
299ScanContextCopyFile (interp, scanTablePtr, contextHandleObj, fileHandleObj)
300    Tcl_Interp  *interp;
301    void_pt      scanTablePtr;
302    Tcl_Obj     *contextHandleObj;
303    Tcl_Obj     *fileHandleObj;
304{
305    scanContext_t *contextPtr, **tableEntryPtr;
306    char         *contextHandle;
307
308    contextHandle = Tcl_GetStringFromObj (contextHandleObj, NULL);
309
310    tableEntryPtr = (scanContext_t **) TclX_HandleXlate (interp,
311                                                         scanTablePtr,
312                                                         contextHandle);
313    if (tableEntryPtr == NULL)
314        return TCL_ERROR;
315    contextPtr = *tableEntryPtr;
316
317    /*
318     * Return the copy file handle if not specified.
319     */
320    if (fileHandleObj == NULL) {
321	Tcl_SetStringObj (Tcl_GetObjResult (interp),
322                          Tcl_GetChannelName (contextPtr->copyFileChannel),
323			  -1);
324        return TCL_OK;
325    }
326
327    return SetCopyFileObj (interp, contextPtr, fileHandleObj);
328}
329
330
331/*-----------------------------------------------------------------------------
332 * TclX_ScancontextObjCmd --
333 *
334 *   Implements the TCL scancontext Tcl command, which has the following forms:
335 *         scancontext create
336 *         scancontext delete
337 *-----------------------------------------------------------------------------
338 */
339static int
340TclX_ScancontextObjCmd (clientData, interp, objc, objv)
341    ClientData  clientData;
342    Tcl_Interp *interp;
343    int         objc;
344    Tcl_Obj    *CONST objv[];
345{
346    char *command;
347    char *subCommand;
348
349    if (objc < 2)
350	return TclX_WrongArgs (interp, objv [0], "option ...");
351
352    command = Tcl_GetStringFromObj (objv [0], NULL);
353    subCommand = Tcl_GetStringFromObj (objv [1], NULL);
354
355    /*
356     * Create a new scan context.
357     */
358    if (STREQU (subCommand, "create")) {
359        if (objc != 2)
360	    return TclX_WrongArgs (interp, objv [0], "create");
361
362        return ScanContextCreate (interp,
363                                  (void_pt) clientData);
364    }
365
366    /*
367     * Delete a scan context.
368     */
369    if (STREQU (subCommand, "delete")) {
370        if (objc != 3)
371	    return TclX_WrongArgs (interp, objv [0], "delete contexthandle");
372
373        return ScanContextDelete (interp,
374                                  (void_pt) clientData,
375                                  objv [2]);
376    }
377
378    /*
379     * Access or set the copyfile.
380     */
381    if (STREQU (subCommand, "copyfile")) {
382        if ((objc < 3) || (objc > 4))
383	    return TclX_WrongArgs (interp, objv [0],
384                              "copyfile contexthandle ?filehandle?");
385
386        return ScanContextCopyFile (interp,
387                                    (void_pt) clientData,
388                                    objv [2],
389                                    (objc == 4) ? objv [3] : NULL);
390    }
391
392    TclX_AppendObjResult (interp, "invalid argument, expected one of: ",
393                          "\"create\", \"delete\", or \"copyfile\"",
394                          (char *) NULL);
395    return TCL_ERROR;
396}
397
398/*-----------------------------------------------------------------------------
399 * TclX_ScanmatchObjCmd --
400 *
401 *   Implements the TCL command:
402 *         scanmatch ?-nocase? contexthandle ?regexp? command
403 *-----------------------------------------------------------------------------
404 */
405static int
406TclX_ScanmatchObjCmd (clientData, interp, objc, objv)
407    ClientData  clientData;
408    Tcl_Interp *interp;
409    int         objc;
410    Tcl_Obj    *CONST objv[];
411{
412    scanContext_t  *contextPtr, **tableEntryPtr;
413    matchDef_t     *newmatch;
414    int             regExpFlags = TCL_REG_ADVANCED;
415    int             firstArg = 1;
416
417    if (objc < 3)
418        goto argError;
419
420    if (STREQU (Tcl_GetStringFromObj (objv[1], NULL), "-nocase")) {
421        regExpFlags |= TCL_REG_NOCASE;
422        firstArg = 2;
423    }
424
425    /*
426     * If firstArg == 2 (-nocase), the both a regular expression and a command
427     * string must be specified, otherwise the regular expression is optional.
428     */
429    if (((firstArg == 2) && (objc != 5)) || ((firstArg == 1) && (objc > 4)))
430        goto argError;
431
432    tableEntryPtr = (scanContext_t **)
433        TclX_HandleXlateObj (interp,
434                             (void_pt) clientData,
435                             objv [firstArg]);
436    if (tableEntryPtr == NULL)
437        return TCL_ERROR;
438    contextPtr = *tableEntryPtr;
439
440    /*
441     * Handle the default case (no regular expression).
442     */
443    if (objc == 3) {
444        if (contextPtr->defaultAction) {
445            Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
446                                    Tcl_GetStringFromObj (objv[0], NULL),
447                                    ": default match already specified in this scan context",
448                                    (char *) NULL);
449            return TCL_ERROR;
450        }
451	Tcl_IncrRefCount (objv [2]);
452        contextPtr->defaultAction = objv [2];
453
454        return TCL_OK;
455    }
456
457    /*
458     * Add a regular expression to the context.
459     */
460
461    newmatch = (matchDef_t *) ckalloc(sizeof (matchDef_t));
462
463    newmatch->regExp = (Tcl_RegExp)
464        Tcl_GetRegExpFromObj(interp, objv[firstArg + 1], regExpFlags);
465    if (newmatch->regExp == NULL) {
466        ckfree ((char *) newmatch);
467	return TCL_ERROR;
468    }
469
470    newmatch->regExpObj = objv[firstArg + 1],
471    Tcl_IncrRefCount (newmatch->regExpObj);
472    newmatch->command = objv [firstArg + 2];
473    Tcl_IncrRefCount (newmatch->command);
474
475    /*
476     * Link in the new match.
477     */
478    newmatch->nextMatchDefPtr = NULL;
479    if (contextPtr->matchListHead == NULL)
480        contextPtr->matchListHead = newmatch;
481    else
482        contextPtr->matchListTail->nextMatchDefPtr = newmatch;
483    contextPtr->matchListTail = newmatch;
484
485    return TCL_OK;
486
487argError:
488    return TclX_WrongArgs (interp, objv [0],
489                           "?-nocase? contexthandle ?regexp? command");
490}
491
492/*-----------------------------------------------------------------------------
493 * SetMatchInfoVar --
494 *
495 *   Sets the Tcl array variable "matchInfo" to contain information about the
496 * current match.  This function is optimize to store per line information
497 * only once.
498 *
499 * Parameters:
500 *   o interp - The Tcl interpreter to set the matchInfo variable in.
501 *     Errors are returned in result.
502 *   o scanData - Data about the current line being scanned.
503 *     been stored.
504 *-----------------------------------------------------------------------------
505 */
506static int
507SetMatchInfoVar (interp, scanData)
508    Tcl_Interp *interp;
509    scanData_t *scanData;
510{
511    static char *MATCHINFO = "matchInfo";
512    int idx, start, end;
513    char *value;
514    Tcl_DString valueBuf;
515    char key [32];
516    Tcl_Obj *valueObjPtr, *indexObjv [2];
517    Tcl_RegExpInfo regExpInfo;
518
519    Tcl_DStringInit(&valueBuf);
520
521    /*
522     * Save information about the current line, if it hasn't been saved.
523     */
524    if (!scanData->storedLine) {
525        scanData->storedLine = TRUE;
526
527        Tcl_UnsetVar (interp, MATCHINFO, 0);
528
529        if (Tcl_SetVar2 (interp, MATCHINFO, "line", scanData->line,
530                         TCL_LEAVE_ERR_MSG) == NULL)
531            goto errorExit;
532
533        valueObjPtr = Tcl_NewLongObj ((long) scanData->offset);
534        if (Tcl_SetVar2Ex(interp, MATCHINFO, "offset", valueObjPtr,
535                          TCL_LEAVE_ERR_MSG) == NULL) {
536            Tcl_DecrRefCount (valueObjPtr);
537            goto errorExit;
538        }
539
540#if 0
541        /*
542         * FIX: Don't expose till we decide on semantics: Should it include the
543         * current line?  All the pieces are here, include doc and tests, just
544         * disabled.
545         */
546        valueObjPtr = Tcl_NewLongObj ((long) scanData->bytesRead);
547        if (Tcl_SetObjVar2 (interp, MATCHINFO, "bytesread", valueObjPtr,
548                            TCL_LEAVE_ERR_MSG) == NULL) {
549            Tcl_DecrRefCount (valueObjPtr);
550            goto errorExit;
551        }
552#endif
553        valueObjPtr = Tcl_NewIntObj ((long) scanData->lineNum);
554        if (Tcl_SetVar2Ex(interp, MATCHINFO, "linenum", valueObjPtr,
555                          TCL_LEAVE_ERR_MSG) == NULL) {
556            Tcl_DecrRefCount (valueObjPtr);
557            goto errorExit;
558        }
559
560        if (Tcl_SetVar2 (interp, MATCHINFO, "context",
561                         scanData->contextPtr->contextHandle,
562                         TCL_LEAVE_ERR_MSG) == NULL)
563            goto errorExit;
564
565        if (Tcl_SetVar2 (interp, MATCHINFO, "handle",
566                         Tcl_GetChannelName (scanData->channel),
567                         TCL_LEAVE_ERR_MSG) == NULL)
568            goto errorExit;
569
570    }
571
572    if (scanData->contextPtr->copyFileChannel != NULL) {
573        if (Tcl_SetVar2 (interp, MATCHINFO, "copyHandle",
574                         Tcl_GetChannelName (scanData->contextPtr->copyFileChannel),
575                         TCL_LEAVE_ERR_MSG) == NULL)
576            goto errorExit;
577    }
578
579    if (scanData->matchPtr == NULL) {
580        goto exitPoint;
581    }
582
583    Tcl_RegExpGetInfo(scanData->matchPtr->regExp, &regExpInfo);
584    for (idx = 0; idx < regExpInfo.nsubs; idx++) {
585	start = regExpInfo.matches[idx+1].start;
586	end = regExpInfo.matches[idx+1].end;
587
588        sprintf (key, "subindex%d", idx);
589        indexObjv [0] = Tcl_NewIntObj (start);
590        if (start < 0) {
591            indexObjv [1] = Tcl_NewIntObj (-1);
592        } else {
593            indexObjv [1] = Tcl_NewIntObj (end-1);
594        }
595        valueObjPtr = Tcl_NewListObj (2, indexObjv);
596        if (Tcl_SetVar2Ex(interp, MATCHINFO, key, valueObjPtr,
597                            TCL_LEAVE_ERR_MSG) == NULL) {
598            Tcl_DecrRefCount (valueObjPtr);
599            goto errorExit;
600        }
601
602        sprintf (key, "submatch%d", idx);
603        Tcl_DStringSetLength(&valueBuf, 0);
604        value = Tcl_UniCharToUtfDString(scanData->uniLine + start, end - start,
605                                        &valueBuf);
606        valueObjPtr = Tcl_NewStringObj(value, (end - start));
607
608        if (Tcl_SetVar2Ex(interp, MATCHINFO, key, valueObjPtr,
609                            TCL_LEAVE_ERR_MSG) == NULL) {
610            Tcl_DecrRefCount (valueObjPtr);
611            goto errorExit;
612        }
613    }
614
615  exitPoint:
616    Tcl_DStringFree(&valueBuf);
617    return TCL_OK;
618
619  errorExit:
620    Tcl_DStringFree(&valueBuf);
621    return TCL_ERROR;
622}
623
624/*-----------------------------------------------------------------------------
625 * ScanFile --
626 *
627 *   Scan a file given a scancontext.
628 *-----------------------------------------------------------------------------
629 */
630static int
631ScanFile (interp, contextPtr, channel)
632    Tcl_Interp    *interp;
633    scanContext_t *contextPtr;
634    Tcl_Channel    channel;
635{
636    Tcl_DString lineBuf, uniLineBuf;
637    int result, matchedAtLeastOne;
638    scanData_t data;
639    int matchStat;
640
641    if (contextPtr->matchListHead == NULL) {
642        TclX_AppendObjResult (interp, "no patterns in current scan context",
643                              (char *) NULL);
644        return TCL_ERROR;
645    }
646
647    data.storedLine = FALSE;
648    data.contextPtr = contextPtr;
649    data.channel = channel;
650    data.bytesRead = 0;
651    data.lineNum = 0;
652
653    Tcl_DStringInit (&lineBuf);
654    Tcl_DStringInit (&uniLineBuf);
655
656    result = TCL_OK;
657    while (TRUE) {
658        if (!contextPtr->fileOpen)
659            goto scanExit;  /* Closed by a callback */
660
661        data.offset = (off_t) Tcl_Tell (channel);
662        Tcl_DStringSetLength (&lineBuf, 0);
663        if (Tcl_Gets (channel, &lineBuf) < 0) {
664            if (Tcl_Eof (channel) || Tcl_InputBlocked (channel))
665                goto scanExit;
666            Tcl_SetStringObj (Tcl_GetObjResult (interp),
667                              Tcl_PosixError (interp), -1);
668            result = TCL_ERROR;
669            goto scanExit;
670        }
671
672
673        data.line = Tcl_DStringValue(&lineBuf);
674        data.bytesRead += (lineBuf.length + 1);  /* Include EOLN */
675        data.lineNum++;
676        data.storedLine = FALSE;
677
678        /* Convert to UTF to UniCode */
679        Tcl_DStringSetLength (&uniLineBuf, 0);
680        data.uniLine = Tcl_UtfToUniCharDString(Tcl_DStringValue(&lineBuf),
681                                               Tcl_DStringLength(&lineBuf),
682                                               &uniLineBuf);
683        data.uniLineLen = Tcl_DStringLength(&uniLineBuf) / sizeof(Tcl_UniChar);
684
685        matchedAtLeastOne = FALSE;
686
687        for (data.matchPtr = contextPtr->matchListHead;
688             data.matchPtr != NULL;
689             data.matchPtr = data.matchPtr->nextMatchDefPtr) {
690
691            matchStat = Tcl_RegExpExec(interp,
692		    data.matchPtr->regExp,
693		    Tcl_DStringValue(&lineBuf),
694		    Tcl_DStringValue(&lineBuf));
695            if (matchStat < 0) {
696                result = TCL_ERROR;
697                goto scanExit;
698            }
699            if (matchStat == 0) {
700                continue;  /* Try next match pattern */
701            }
702            matchedAtLeastOne = TRUE;
703
704            result = SetMatchInfoVar (interp, &data);
705            if (result != TCL_OK)
706                goto scanExit;
707
708            result = Tcl_EvalObj (interp, data.matchPtr->command);
709            if (result == TCL_ERROR) {
710                Tcl_AddObjErrorInfo (interp,
711                    "\n    while executing a match command", -1);
712                goto scanExit;
713            }
714            if (result == TCL_CONTINUE) {
715                /*
716                 * Don't process any more matches for this line.
717                 */
718                goto matchLineExit;
719            }
720            if ((result == TCL_BREAK) || (result == TCL_RETURN)) {
721                /*
722                 * Terminate scan.
723                 */
724                result = TCL_OK;
725                goto scanExit;
726            }
727        }
728
729      matchLineExit:
730        /*
731         * Process default action if required.
732         */
733        if ((contextPtr->defaultAction != NULL) && (!matchedAtLeastOne)) {
734            data.matchPtr = NULL;
735            result = SetMatchInfoVar(interp,
736                                     &data);
737            if (result != TCL_OK)
738                goto scanExit;
739
740            result = Tcl_EvalObj (interp, contextPtr->defaultAction);
741            if (result == TCL_ERROR) {
742                Tcl_AddObjErrorInfo (interp,
743                    "\n    while executing a match default command", -1);
744                goto scanExit;
745            }
746            if ((result == TCL_BREAK) || (result == TCL_RETURN)) {
747                /*
748                 * Terminate scan.
749                 */
750                result = TCL_OK;
751                goto scanExit;
752            }
753        }
754
755	if ((contextPtr->copyFileChannel != NULL) && (!matchedAtLeastOne)) {
756	    if ((Tcl_Write (contextPtr->copyFileChannel, Tcl_DStringValue(&lineBuf),
757                            Tcl_DStringLength(&lineBuf)) < 0) ||
758                (TclX_WriteNL (contextPtr->copyFileChannel) < 0)) {
759                Tcl_SetStringObj (Tcl_GetObjResult (interp),
760                                  Tcl_PosixError (interp), -1);
761		return TCL_ERROR;
762	    }
763	}
764    }
765
766  scanExit:
767    Tcl_DStringFree (&lineBuf);
768    Tcl_DStringFree (&uniLineBuf);
769    if (result == TCL_ERROR)
770        return TCL_ERROR;
771    return TCL_OK;
772}
773
774/*-----------------------------------------------------------------------------
775 * ScanFileCloseHandler --
776 *   Close handler for the file being scanned.  Marks it as not open.
777 * Parameters:
778 *   o clientData (I) - Pointer to the scan context.
779 *-----------------------------------------------------------------------------
780 */
781static void
782ScanFileCloseHandler (clientData)
783    ClientData clientData;
784{
785    ((scanContext_t *) clientData)->fileOpen = FALSE;
786}
787
788/*-----------------------------------------------------------------------------
789 * TclX_ScanfileObjCmd --
790 *
791 *   Implements the TCL command:
792 *        scanfile ?-copyfile copyhandle? contexthandle filehandle
793 *-----------------------------------------------------------------------------
794 */
795static int
796TclX_ScanfileObjCmd (clientData, interp, objc, objv)
797    ClientData  clientData;
798    Tcl_Interp *interp;
799    int         objc;
800    Tcl_Obj    *CONST objv[];
801{
802    scanContext_t *contextPtr, **tableEntryPtr;
803    Tcl_Obj       *contextHandleObj, *fileHandleObj, *copyFileHandleObj;
804    Tcl_Channel    channel;
805    int            status;
806
807    if ((objc != 3) && (objc != 5))
808        goto argError;
809
810    if (objc == 3) {
811	contextHandleObj = objv [1];
812	fileHandleObj = objv [2];
813	copyFileHandleObj = NULL;
814    } else {
815	if (!STREQU (Tcl_GetStringFromObj (objv[1], NULL), "-copyfile"))
816            goto argError;
817	copyFileHandleObj = objv [2];
818	contextHandleObj = objv [3];
819	fileHandleObj = objv [4];
820    }
821
822    tableEntryPtr = (scanContext_t **)
823        TclX_HandleXlateObj (interp,
824                             (void_pt) clientData,
825                             contextHandleObj);
826    if (tableEntryPtr == NULL)
827        return TCL_ERROR;
828    contextPtr = *tableEntryPtr;
829
830    channel = TclX_GetOpenChannelObj (interp, fileHandleObj, TCL_READABLE);
831    if (channel == NULL)
832        return TCL_ERROR;
833
834    if (copyFileHandleObj != NULL) {
835        if (SetCopyFileObj (interp, contextPtr, copyFileHandleObj) == TCL_ERROR)
836            return TCL_ERROR;
837    }
838
839    /*
840     * Scan the file, protecting it with a close handler.
841     * Watch for case where ScanFile may close the file during scan.
842     * [Bug 1045190]
843     */
844    contextPtr->fileOpen = TRUE;
845    Tcl_CreateCloseHandler (channel,
846                            ScanFileCloseHandler,
847                            (ClientData) contextPtr);
848    status = ScanFile(interp, contextPtr, channel);
849    if (contextPtr->fileOpen == TRUE) {
850	Tcl_DeleteCloseHandler(channel, ScanFileCloseHandler,
851		(ClientData) contextPtr);
852    }
853
854    /*
855     * If we set the copyfile, disassociate it from the context.
856     */
857    if (copyFileHandleObj != NULL) {
858        ClearCopyFile (contextPtr);
859    }
860    return status;
861
862  argError:
863    return TclX_WrongArgs (interp, objv [0],
864		           "?-copyfile filehandle? contexthandle filehandle");
865}
866
867/*-----------------------------------------------------------------------------
868 * FileScanCleanUp --
869 *
870 *    Called when the interpreter is deleted to cleanup all filescan
871 * resources
872 *-----------------------------------------------------------------------------
873 */
874static void
875FileScanCleanUp (clientData, interp)
876    ClientData  clientData;
877    Tcl_Interp *interp;
878{
879    scanContext_t **tableEntryPtr;
880    int             walkKey;
881
882    walkKey = -1;
883    while (TRUE) {
884        tableEntryPtr =
885            (scanContext_t **) TclX_HandleWalk ((void_pt) clientData,
886                                                &walkKey);
887        if (tableEntryPtr == NULL)
888            break;
889        CleanUpContext ((void_pt) clientData, *tableEntryPtr);
890    }
891    TclX_HandleTblRelease ((void_pt) clientData);
892}
893
894/*-----------------------------------------------------------------------------
895 *  TclX_FilescanInit --
896 *
897 *    Initialize the TCL file scanning facility..
898 *-----------------------------------------------------------------------------
899 */
900void
901TclX_FilescanInit (interp)
902    Tcl_Interp *interp;
903{
904    void_pt  scanTablePtr;
905
906    scanTablePtr = TclX_HandleTblInit ("context",
907                                       sizeof (scanContext_t *),
908                                       10);
909
910    Tcl_CallWhenDeleted (interp, FileScanCleanUp, (ClientData) scanTablePtr);
911
912    /*
913     * Initialize the commands.
914     */
915    Tcl_CreateObjCommand (interp,
916			  "scanfile",
917			  TclX_ScanfileObjCmd,
918                          (ClientData) scanTablePtr,
919                          (Tcl_CmdDeleteProc*) NULL);
920
921    Tcl_CreateObjCommand (interp,
922			  "scanmatch",
923			  TclX_ScanmatchObjCmd,
924                          (ClientData) scanTablePtr,
925			  (Tcl_CmdDeleteProc*) NULL);
926
927    Tcl_CreateObjCommand (interp,
928			  "scancontext",
929			  TclX_ScancontextObjCmd,
930                          (ClientData) scanTablePtr,
931			  (Tcl_CmdDeleteProc*) NULL);
932}
933
934
935
936