home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src / tclXfilecmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-03  |  15.8 KB  |  529 lines  |  [TEXT/MPS ]

  1. #ifdef MPW
  2. #    pragma segment TCLExtend_2
  3. #endif
  4. /*
  5.  * tclXfilecmds.c
  6.  *
  7.  * Extended Tcl pipe, copyfile and lgets commands.
  8.  *-----------------------------------------------------------------------------
  9.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  10.  *
  11.  * Permission to use, copy, modify, and distribute this software and its
  12.  * documentation for any purpose and without fee is hereby granted, provided
  13.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14.  * Mark Diekhans make no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without express or
  16.  * implied warranty.
  17.  *-----------------------------------------------------------------------------
  18.  * $Id: tclXfilecmds.c,v 2.8 1993/08/31 23:03:20 markd Exp $
  19.  *-----------------------------------------------------------------------------
  20.  */
  21. /* 
  22.  *-----------------------------------------------------------------------------
  23.  * Note: List parsing code stolen from Tcl distribution file tclUtil.c.
  24.  *-----------------------------------------------------------------------------
  25.  * Copyright (c) 1987-1993 The Regents of the University of California.
  26.  * All rights reserved.
  27.  *
  28.  * Permission is hereby granted, without written agreement and without
  29.  * license or royalty fees, to use, copy, modify, and distribute this
  30.  * software and its documentation for any purpose, provided that the
  31.  * above copyright notice and the following two paragraphs appear in
  32.  * all copies of this software.
  33.  * 
  34.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  35.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  36.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  37.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  38.  *
  39.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  40.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  41.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  42.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  43.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  44.  *-----------------------------------------------------------------------------
  45.  */
  46.  
  47. #include "tclExtdInt.h"
  48.  
  49. /*
  50.  * Prototypes of internal functions.
  51.  */
  52. static int
  53. GetsListElement _ANSI_ARGS_((Tcl_Interp    *interp,
  54.                              FILE          *filePtr,
  55.                              Tcl_DString   *bufferPtr,
  56.                              int           *idxPtr));
  57.  
  58. /*
  59.  *-----------------------------------------------------------------------------
  60.  *
  61.  * Tcl_PipeCmd --
  62.  *     Implements the pipe TCL command:
  63.  *         pipe ?fileId_var_r fileId_var_w?
  64.  *
  65.  * Results:
  66.  *      Standard TCL result.
  67.  *
  68.  * Side effects:
  69.  *      Locates and creates entries in the file table
  70.  *
  71.  *-----------------------------------------------------------------------------
  72.  */
  73. int
  74. Tcl_PipeCmd (clientData, interp, argc, argv)
  75.     ClientData  clientData;
  76.     Tcl_Interp *interp;
  77.     int         argc;
  78.     char      **argv;
  79. {
  80. #ifdef macintosh
  81.     Tcl_AppendResult (interp, "\"", argv[0],
  82.                         "\" is not supported for Macintosh.",
  83.                         (char*) NULL);
  84.     return TCL_ERROR;
  85. #else
  86.     Interp    *iPtr = (Interp *) interp;
  87.     int        fileNums [2];
  88.     char       fileIds [12];
  89.  
  90.     if (!((argc == 1) || (argc == 3))) {
  91.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0], 
  92.                           " ?fileId_var_r fileId_var_w?", (char*) NULL);
  93.         return TCL_ERROR;
  94.     }
  95.  
  96.     if (pipe (fileNums) < 0) {
  97.         interp->result = Tcl_PosixError (interp);
  98.         return TCL_ERROR;
  99.     }
  100.  
  101.     if (Tcl_SetupFileEntry (interp, fileNums [0], TCL_FILE_READABLE) == NULL)
  102.         goto errorExit;
  103.     if (Tcl_SetupFileEntry (interp, fileNums [1], TCL_FILE_WRITABLE) == NULL)
  104.         goto errorExit;
  105.  
  106.     if (argc == 1)      
  107.         sprintf (interp->result, "file%d file%d", fileNums [0], fileNums [1]);
  108.     else {
  109.         sprintf (fileIds, "file%d", fileNums [0]);
  110.         if (Tcl_SetVar (interp, argv[1], fileIds, TCL_LEAVE_ERR_MSG) == NULL)
  111.             goto errorExit;
  112.  
  113.         sprintf (fileIds, "file%d", fileNums [1]);
  114.         if (Tcl_SetVar (interp, argv[2], fileIds, TCL_LEAVE_ERR_MSG) == NULL)
  115.             goto errorExit;
  116.     }
  117.         
  118.     return TCL_OK;
  119.  
  120.   errorExit:
  121.     Tcl_CloseForError (interp, fileNums [0]);
  122.     Tcl_CloseForError (interp, fileNums [1]);
  123.     return TCL_ERROR;
  124. #endif
  125. }
  126.  
  127. /*
  128.  *-----------------------------------------------------------------------------
  129.  *
  130.  * Tcl_CopyfileCmd --
  131.  *     Implements the copyfile TCL command:
  132.  *         copyfile ?-bytes num|-maxbytes num? fromFileId toFileId
  133.  *
  134.  * Results:
  135.  *      The number of bytes transfered or an error.
  136.  *
  137.  *-----------------------------------------------------------------------------
  138.  */
  139. int
  140. Tcl_CopyfileCmd (clientData, interp, argc, argv)
  141.     ClientData  clientData;
  142.     Tcl_Interp *interp;
  143.     int         argc;
  144.     char      **argv;
  145. {
  146. #define TCL_COPY_ALL        0
  147. #define TCL_COPY_BYTES      1
  148. #define TCL_COPY_MAX_BYTES  2
  149.  
  150.     FILE  *fromFilePtr, *toFilePtr;
  151.     char   buffer [2048];
  152.     long   bytesToRead, bytesRead, totalBytesToRead, totalBytesRead, bytesLeft;
  153.     int    copyMode;
  154.  
  155.     if (!(argc == 3 || argc == 5))
  156.         goto wrongArgs;
  157.  
  158.     if (argc == 5) {
  159.         if (STREQU (argv [1], "-bytes")) 
  160.             copyMode = TCL_COPY_BYTES;
  161.         else if (STREQU (argv [1], "-maxbytes"))
  162.             copyMode = TCL_COPY_MAX_BYTES;
  163.         else
  164.             goto invalidOption;
  165.  
  166.         if (Tcl_GetLong (interp, argv [2], &totalBytesToRead) != TCL_OK)
  167.             return TCL_ERROR;
  168.         bytesLeft = totalBytesToRead;
  169.     } else {
  170.         copyMode = TCL_COPY_ALL;
  171.         bytesLeft = MAXLONG;
  172.     }
  173.     totalBytesRead = 0;
  174.  
  175.     if (Tcl_GetOpenFile (interp, argv [argc - 2],
  176.                          FALSE,  /* Read access  */
  177.                          TRUE,   /* Check access */  
  178.                          &fromFilePtr) != TCL_OK)
  179.         return TCL_ERROR;
  180.  
  181.     if (Tcl_GetOpenFile (interp, argv [argc - 1],
  182.                          TRUE,   /* Write access */
  183.                          TRUE,   /* Check access */
  184.                          &toFilePtr) != TCL_OK)
  185.         return TCL_ERROR;
  186.  
  187.     while (bytesLeft > 0) {
  188.         bytesToRead = sizeof (buffer);
  189.         if (bytesToRead > bytesLeft)
  190.             bytesToRead = bytesLeft;
  191.  
  192.         bytesRead = fread (buffer, sizeof (char), bytesToRead, fromFilePtr);
  193.         if (bytesRead <= 0) {
  194.             if (feof (fromFilePtr))
  195.                 break;
  196.             else
  197.                 goto unixError;
  198.         }
  199.         if (fwrite (buffer, sizeof (char), bytesRead, toFilePtr) != bytesRead)
  200.             goto unixError;
  201.  
  202.         bytesLeft -= bytesRead;
  203.         totalBytesRead += bytesRead;
  204.     }
  205.     
  206.     /*
  207.      * Return an error if -bytes were specified and not that many were
  208.      * available.
  209.      */
  210.     if ((copyMode == TCL_COPY_BYTES) &&
  211.         (totalBytesToRead > 0) && (totalBytesRead != totalBytesToRead)) {
  212.  
  213.         sprintf (interp->result,
  214.                  "premature EOF, %d bytes expected, %d bytes actually read",
  215.                  totalBytesToRead, totalBytesRead);
  216.         return TCL_ERROR;
  217.     }
  218.  
  219.     sprintf (interp->result, "%d", totalBytesRead);
  220.     return TCL_OK;
  221.  
  222.   unixError:
  223.     interp->result = Tcl_PosixError (interp);
  224.     return TCL_ERROR;
  225.  
  226.   wrongArgs:
  227.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  228.                       " ?-bytes num|-maxbytes num? fromFileId toFileId",
  229.                       (char *) NULL);
  230.     return TCL_ERROR;
  231.  
  232.   invalidOption:
  233.     Tcl_AppendResult (interp, "expect \"-bytes\" or \"-maxbytes\", got \"",
  234.                       argv [1], "\"", (char *) NULL);
  235.     return TCL_ERROR;
  236.  
  237. }
  238.  
  239. /*
  240.  *-----------------------------------------------------------------------------
  241.  *
  242.  * GetsListElement --
  243.  *
  244.  *   Parse through a line read from a file for a list element.  If the end of
  245.  * the string is reached while still in the list element, read another line.
  246.  *
  247.  * Paramaters:
  248.  *   o interp (I) - Errors are returned in result.
  249.  *   o filePtr (I) - The file to read from.
  250.  *   o bufferPtr (I) - Buffer that file is read into.  The first line of the
  251.  *     list should already have been read in.
  252.  *   o idxPtr (I/O) - Pointer to the index of the next element in the buffer.
  253.  *     initialize to zero before the first call.
  254.  * Returns:
  255.  *   o TCL_OK if an element was validated but there are more in the buffer.
  256.  *   o TCL_BREAK if the end of the list was reached.
  257.  *   o TCL_ERROR if an error occured.
  258.  *-----------------------------------------------------------------------------
  259.  */
  260. static int
  261. GetsListElement (interp, filePtr, bufferPtr, idxPtr)
  262.     Tcl_Interp    *interp;
  263.     FILE          *filePtr;
  264.     Tcl_DString   *bufferPtr;
  265.     int           *idxPtr;
  266. {
  267.     register char *p;
  268.     int openBraces = 0;
  269.     int inQuotes = 0;
  270.  
  271.     p = bufferPtr->string + *idxPtr;
  272.  
  273.     /*
  274.      * Skim off leading white space and check for an opening brace or
  275.      * quote.
  276.      */
  277.     
  278.     while (ISSPACE(*p)) {
  279.         p++;
  280.     }
  281.     if (*p == '{') {
  282.         openBraces = 1;
  283.         p++;
  284.     } else if (*p == '"') {
  285.         inQuotes = 1;
  286.         p++;
  287.     }
  288.  
  289.     /*
  290.      * Find the end of the element (either a space or a close brace or
  291.      * the end of the string).
  292.      */
  293.  
  294.     while (1) {
  295.         switch (*p) {
  296.  
  297.             /*
  298.              * Open brace: don't treat specially unless the element is
  299.              * in braces.  In this case, keep a nesting count.
  300.              */
  301.  
  302.             case '{':
  303.                 if (openBraces != 0) {
  304.                     openBraces++;
  305.                 }
  306.                 break;
  307.  
  308.             /*
  309.              * Close brace: if element is in braces, keep nesting
  310.              * count and quit when the last close brace is seen.
  311.              */
  312.  
  313.             case '}':
  314.                 if (openBraces == 1) {
  315.                     char *p2;
  316.  
  317.                     p++;
  318.                     if (ISSPACE(*p) || (*p == 0)) {
  319.                         goto done;
  320.                     }
  321.                     for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
  322.                             p2++) {
  323.                         /* null body */
  324.                     }
  325.                     Tcl_ResetResult(interp);
  326.                     sprintf(interp->result,
  327.                             "list element in braces followed by \"%.*s\" instead of space in list read from file",
  328.                             p2-p, p);
  329.                     return TCL_ERROR;
  330.                 } else if (openBraces != 0) {
  331.                     openBraces--;
  332.                 }
  333.                 break;
  334.  
  335.             /*
  336.              * Backslash:  skip over everything up to the end of the
  337.              * backslash sequence.
  338.              */
  339.  
  340.             case '\\': {
  341.                 int size;
  342.  
  343.                 (void) Tcl_Backslash(p, &size);
  344.                 p += size - 1;
  345.                 break;
  346.             }
  347.  
  348.             /*
  349.              * Space: ignore if element is in braces or quotes;  otherwise
  350.              * terminate element.
  351.              */
  352.  
  353.             case ' ':
  354.             case '\f':
  355.             case '\n':
  356.             case '\r':
  357.             case '\t':
  358.             case '\v':
  359.                 if ((openBraces == 0) && !inQuotes) {
  360.                     goto done;
  361.                 }
  362.                 break;
  363.  
  364.             /*
  365.              * Double-quote:  if element is in quotes then terminate it.
  366.              */
  367.  
  368.             case '"':
  369.                 if (inQuotes) {
  370.                     char *p2;
  371.  
  372.                     p++;
  373.                     if (ISSPACE(*p) || (*p == 0)) {
  374.                         goto done;
  375.                     }
  376.                     for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
  377.                             p2++) {
  378.                         /* null body */
  379.                     }
  380.                     Tcl_ResetResult(interp);
  381.                     sprintf(interp->result,
  382.                             "list element in quotes followed by \"%.*s\" %s",
  383.                             p2-p, p, "instead of space in list read from file");
  384.                     return TCL_ERROR;
  385.                 }
  386.                 break;
  387.  
  388.             /*
  389.              * End of line, read and append another line if in braces or
  390.              * quotes. Replace the '\0' with the newline that was in the sting.
  391.              * Reset scan pointer (p) in case of buffer realloc.
  392.              */
  393.  
  394.             case 0: {
  395.                 char *oldString;
  396.                 int   stat;
  397.                 
  398.                 if ((openBraces == 0) && (inQuotes == 0))
  399.                     goto done;
  400.  
  401.                 oldString = bufferPtr->string;
  402.                 Tcl_DStringAppend (bufferPtr, "\n", -1);
  403.  
  404.                 stat = Tcl_DStringGets (filePtr, bufferPtr); 
  405.                 if (stat == TCL_ERROR)
  406.                     goto fileError;
  407.                 
  408.                 p = bufferPtr->string + (p - oldString);
  409.                 if (stat == TCL_OK)
  410.                     break;  /* Got some data */
  411.                 /*
  412.                  * EOF in list error.
  413.                  */
  414.                 if (openBraces != 0) {
  415.                     Tcl_SetResult(interp,
  416.                             "unmatched open brace in list read from file (at EOF)",
  417.                             TCL_STATIC);
  418.                     return TCL_ERROR;
  419.                 } else {
  420.                     Tcl_SetResult(interp,
  421.                             "unmatched open quote in list read from file (at EOF)",
  422.                             TCL_STATIC);
  423.                     return TCL_ERROR;
  424.                 }
  425.             }
  426.         }
  427.         p++;
  428.     }
  429.  
  430.     done:
  431.     while (ISSPACE(*p)) {
  432.         p++;
  433.     }
  434.     *idxPtr = p - bufferPtr->string;
  435.     return (*p == '\0') ? TCL_BREAK : TCL_OK;
  436.  
  437.     fileError:
  438.     Tcl_AppendResult (interp, "error reading list from file: ",
  439.                       Tcl_PosixError (interp), (char *) NULL);
  440.     return TCL_ERROR;
  441. }
  442.  
  443. /*
  444.  *-----------------------------------------------------------------------------
  445.  *
  446.  * Tcl_LgetsCmd --
  447.  *
  448.  * Implements the `lgets' Tcl command:
  449.  *    lgets fileId ?varName?
  450.  *
  451.  * Results:
  452.  *      A standard Tcl result.
  453.  *
  454.  * Side effects:
  455.  *      See the user documentation.
  456.  *
  457.  *-----------------------------------------------------------------------------
  458.  */
  459. int
  460. Tcl_LgetsCmd (notUsed, interp, argc, argv)
  461.     ClientData   notUsed;
  462.     Tcl_Interp  *interp;
  463.     int          argc;
  464.     char       **argv;
  465. {
  466.     FILE        *filePtr;
  467.     Tcl_DString  buffer;
  468.     int          stat, bufIdx = 0;
  469.  
  470.     if ((argc != 2) && (argc != 3)) {
  471.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0],
  472.                           " fileId ?varName?", (char *) NULL);
  473.         return TCL_ERROR;
  474.     }
  475.     if (Tcl_GetOpenFile (interp, argv[1],
  476.                          FALSE,  /* Read access  */
  477.                          TRUE,   /* Check access */
  478.                          &filePtr) != TCL_OK) {
  479.         return TCL_ERROR;
  480.     }
  481.  
  482.     /*
  483.      * Read the list, parsing off each element until the list is read.
  484.      * More lines are read if newlines are encountered in the middle of
  485.      * a list.
  486.      */
  487.     Tcl_DStringInit (&buffer);
  488.  
  489.     stat = Tcl_DStringGets (filePtr, &buffer);
  490.     if (stat == TCL_ERROR)
  491.         goto readError;
  492.  
  493.     while (stat != TCL_BREAK) {
  494.         stat = GetsListElement (interp, filePtr, &buffer, &bufIdx);
  495.         if (stat == TCL_ERROR)
  496.             goto errorExit;
  497.     }
  498.  
  499.     /*
  500.      * Return the string as a result or in a variable.
  501.      */
  502.     if (argc == 2) {
  503.         Tcl_DStringResult (interp, &buffer);
  504.     } else {
  505.         if (Tcl_SetVar (interp, argv[2], buffer.string,
  506.                         TCL_LEAVE_ERR_MSG) == NULL)
  507.             goto errorExit;
  508.  
  509.         if (feof (filePtr) && (buffer.length == 0))
  510.             interp->result = "-1";
  511.         else
  512.             sprintf (interp->result, "%d", buffer.length);
  513.  
  514.         Tcl_DStringFree (&buffer);
  515.     }
  516.     return TCL_OK;
  517.  
  518. readError:
  519.     Tcl_AppendResult (interp, "error reading list from file: ",
  520.                       Tcl_PosixError (interp), (char *) NULL);
  521.     clearerr (filePtr);
  522.  
  523. errorExit:
  524.     Tcl_DStringFree (&buffer);
  525.     return TCL_ERROR;
  526.  
  527. }
  528.  
  529.