home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXfilecmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  24.7 KB  |  857 lines
  1. /*
  2.  * tclXfilecmds.c
  3.  *
  4.  * Extended Tcl pipe, copyfile and fstat commands.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  7.  *
  8.  * Permission to use, copy, modify, and distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11.  * Mark Diekhans make no representations about the suitability of this
  12.  * software for any purpose.  It is provided "as is" without express or
  13.  * implied warranty.
  14.  *-----------------------------------------------------------------------------
  15.  * $Id: tclXfilecmds.c,v 2.0 1992/10/16 04:50:41 markd Rel $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * Prototypes of internal functions.
  23.  */
  24. static char *
  25. GetFileType _ANSI_ARGS_((struct stat  *statBufPtr));
  26.  
  27. static void
  28. ReturnStatList _ANSI_ARGS_((Tcl_Interp   *interp,
  29.                             OpenFile     *filePtr,
  30.                             struct stat  *statBufPtr));
  31.  
  32. static int
  33. ReturnStatArray _ANSI_ARGS_((Tcl_Interp   *interp,
  34.                              OpenFile     *filePtr,
  35.                              struct stat  *statBufPtr,
  36.                              char         *arrayName));
  37.  
  38. static int
  39. ReturnStatItem _ANSI_ARGS_((Tcl_Interp   *interp,
  40.                             OpenFile     *filePtr,
  41.                             struct stat  *statBufPtr,
  42.                             char         *itemName));
  43.  
  44. static int
  45. ParseLockUnlockArgs _ANSI_ARGS_((Tcl_Interp    *interp,
  46.                                  int            argc,
  47.                                  char         **argv,
  48.                                  int            argIdx,
  49.                                  OpenFile     **filePtrPtr,
  50.                                  struct flock  *lockInfoPtr));
  51.  
  52.  
  53. /*
  54.  *-----------------------------------------------------------------------------
  55.  *
  56.  * Tcl_PipeCmd --
  57.  *     Implements the pipe TCL command:
  58.  *         pipe [handle_var_r handle_var_w]
  59.  *
  60.  * Results:
  61.  *      Standard TCL result.
  62.  *
  63.  * Side effects:
  64.  *      Locates and creates entries in the handles table
  65.  *
  66.  *-----------------------------------------------------------------------------
  67.  */
  68. int
  69. Tcl_PipeCmd (clientData, interp, argc, argv)
  70.     ClientData  clientData;
  71.     Tcl_Interp *interp;
  72.     int         argc;
  73.     char      **argv;
  74. {
  75.     Interp    *iPtr = (Interp *) interp;
  76.     int        fileIds [2];
  77.     char       fHandle [12];
  78.  
  79.     if (!((argc == 1) || (argc == 3))) {
  80.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0], 
  81.                           " [handle_var_r handle_var_w]", (char*) NULL);
  82.         return TCL_ERROR;
  83.     }
  84.  
  85.     if (pipe (fileIds) < 0) {
  86.         interp->result = Tcl_UnixError (interp);
  87.         return TCL_ERROR;
  88.     }
  89.  
  90.     if (Tcl_SetupFileEntry (interp, fileIds [0], TRUE,  FALSE) != TCL_OK)
  91.         goto errorExit;
  92.     if (Tcl_SetupFileEntry (interp, fileIds [1], FALSE, TRUE) != TCL_OK)
  93.         goto errorExit;
  94.  
  95.     if (argc == 1)      
  96.         sprintf (interp->result, "file%d file%d", fileIds [0], fileIds [1]);
  97.     else {
  98.         sprintf (fHandle, "file%d", fileIds [0]);
  99.         if (Tcl_SetVar (interp, argv[1], fHandle, TCL_LEAVE_ERR_MSG) == NULL)
  100.             goto errorExit;
  101.  
  102.         sprintf (fHandle, "file%d", fileIds [1]);
  103.         if (Tcl_SetVar (interp, argv[2], fHandle, TCL_LEAVE_ERR_MSG) == NULL)
  104.             goto errorExit;
  105.     }
  106.         
  107.     return TCL_OK;
  108.  
  109. errorExit:
  110.     close (fileIds [0]);
  111.     close (fileIds [1]);
  112.     return TCL_ERROR;
  113. }
  114.  
  115. /*
  116.  *-----------------------------------------------------------------------------
  117.  *
  118.  * Tcl_CopyfileCmd --
  119.  *     Implements the copyfile TCL command:
  120.  *         copyfile handle1 handle2 [lines]
  121.  *
  122.  * Results:
  123.  *      Nothing if it worked, else an error.
  124.  *
  125.  *-----------------------------------------------------------------------------
  126.  */
  127. int
  128. Tcl_CopyfileCmd (clientData, interp, argc, argv)
  129.     ClientData  clientData;
  130.     Tcl_Interp *interp;
  131.     int         argc;
  132.     char      **argv;
  133. {
  134.     OpenFile  *fromFilePtr, *toFilePtr;
  135.     char       transferBuffer [2048];
  136.     int        bytesRead;
  137.  
  138.     if (argc != 3) {
  139.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  140.                           " fromfilehandle tofilehandle", (char *) NULL);
  141.         return TCL_ERROR;
  142.     }
  143.  
  144.     if (TclGetOpenFile (interp, argv[1], &fromFilePtr) != TCL_OK)
  145.     return TCL_ERROR;
  146.     if (TclGetOpenFile (interp, argv[2], &toFilePtr) != TCL_OK)
  147.     return TCL_ERROR;
  148.  
  149.     if (!fromFilePtr->readable) {
  150.         interp->result = "Source file is not open for read access";
  151.     return TCL_ERROR;
  152.     }
  153.     if (!toFilePtr->writable) {
  154.         interp->result = "Target file is not open for write access";
  155.     return TCL_ERROR;
  156.     }
  157.  
  158.     while (TRUE) {
  159.         bytesRead = fread (transferBuffer, sizeof (char), 
  160.                            sizeof (transferBuffer), fromFilePtr->f);
  161.         if (bytesRead <= 0) {
  162.             if (feof (fromFilePtr->f))
  163.                 break;
  164.             else
  165.                 goto unixError;
  166.         }
  167.         if (fwrite (transferBuffer, sizeof (char), bytesRead, toFilePtr->f) != 
  168.                     bytesRead)
  169.             goto unixError;
  170.     }
  171.  
  172.     return TCL_OK;
  173.  
  174. unixError:
  175.     interp->result = Tcl_UnixError (interp);
  176.     return TCL_ERROR;
  177. }
  178.  
  179. /*
  180.  *-----------------------------------------------------------------------------
  181.  *
  182.  * GetFileType --
  183.  *
  184.  *   Looks at stat mode and returns a text string indicating what type of
  185.  * file it is.
  186.  *
  187.  * Parameters:
  188.  *   o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
  189.  * Returns:
  190.  *   A pointer static text string representing the type of the file.
  191.  *-----------------------------------------------------------------------------
  192.  */
  193. static char *
  194. GetFileType (statBufPtr)
  195.     struct stat  *statBufPtr;
  196. {
  197.     char *typeStr;
  198.  
  199.     /*
  200.      * Get a string representing the type of the file.
  201.      */
  202.     if (S_ISREG (statBufPtr->st_mode)) {
  203.         typeStr = "file";
  204.     } else if (S_ISDIR (statBufPtr->st_mode)) {
  205.         typeStr = "directory";
  206.     } else if (S_ISCHR (statBufPtr->st_mode)) {
  207.         typeStr = "characterSpecial";
  208.     } else if (S_ISBLK (statBufPtr->st_mode)) {
  209.         typeStr = "blockSpecial";
  210.     } else if (S_ISFIFO (statBufPtr->st_mode)) {
  211.         typeStr = "fifo";
  212.     } else if (S_ISLNK (statBufPtr->st_mode)) {
  213.         typeStr = "link";
  214.     } else if (S_ISSOCK (statBufPtr->st_mode)) {
  215.         typeStr = "socket";
  216.     } else {
  217.         typeStr = "unknown";
  218.     }
  219.  
  220.     return typeStr;
  221. }
  222.  
  223. /*
  224.  *-----------------------------------------------------------------------------
  225.  *
  226.  * ReturnStatList --
  227.  *
  228.  *   Return file stat infomation as a keyed list.
  229.  *
  230.  * Parameters:
  231.  *   o interp (I) - The list is returned in result.
  232.  *   o filePtr (I) - Pointer to the Tcl open file structure.
  233.  *   o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
  234.  *-----------------------------------------------------------------------------
  235.  */
  236. static void
  237. ReturnStatList (interp, filePtr, statBufPtr)
  238.     Tcl_Interp   *interp;
  239.     OpenFile     *filePtr;
  240.     struct stat  *statBufPtr;
  241. {
  242.     char statList [200];
  243.  
  244.     sprintf (statList, 
  245.              "{atime %d} {ctime %d} {dev %d} {gid %d} {ino %d} {mode %d} ",
  246.               statBufPtr->st_atime, statBufPtr->st_ctime, statBufPtr->st_dev,
  247.               statBufPtr->st_gid,   statBufPtr->st_ino,   statBufPtr->st_mode);
  248.     Tcl_AppendResult (interp, statList, (char *) NULL);
  249.  
  250.     sprintf (statList, 
  251.              "{mtime %d} {nlink %d} {size %d} {uid %d} {tty %d} {type %s}",
  252.              statBufPtr->st_mtime,  statBufPtr->st_nlink, statBufPtr->st_size,
  253.              statBufPtr->st_uid,    isatty (fileno (filePtr->f)),
  254.              GetFileType (statBufPtr));
  255.     Tcl_AppendResult (interp, statList, (char *) NULL);
  256.  
  257. }
  258.  
  259. /*
  260.  *-----------------------------------------------------------------------------
  261.  *
  262.  * ReturnStatArray --
  263.  *
  264.  *   Return file stat infomation in an array.
  265.  *
  266.  * Parameters:
  267.  *   o interp (I) - Current interpreter, error return in result.
  268.  *   o filePtr (I) - Pointer to the Tcl open file structure.
  269.  *   o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
  270.  *   o arrayName (I) - The name of the array to return the info in.
  271.  * Returns:
  272.  *   TCL_OK or TCL_ERROR.
  273.  *-----------------------------------------------------------------------------
  274.  */
  275. static int
  276. ReturnStatArray (interp, filePtr, statBufPtr, arrayName)
  277.     Tcl_Interp   *interp;
  278.     OpenFile     *filePtr;
  279.     struct stat  *statBufPtr;
  280.     char         *arrayName;
  281. {
  282.     char numBuf [30];
  283.  
  284.     sprintf (numBuf, "%d", statBufPtr->st_dev);
  285.     if  (Tcl_SetVar2 (interp, arrayName, "dev", numBuf, 
  286.                       TCL_LEAVE_ERR_MSG) == NULL)
  287.         return TCL_ERROR;
  288.  
  289.     sprintf (numBuf, "%d", statBufPtr->st_ino);
  290.     if  (Tcl_SetVar2 (interp, arrayName, "ino", numBuf,
  291.                          TCL_LEAVE_ERR_MSG) == NULL)
  292.         return TCL_ERROR;
  293.  
  294.     sprintf (numBuf, "%d", statBufPtr->st_mode);
  295.     if  (Tcl_SetVar2 (interp, arrayName, "mode", numBuf, 
  296.                       TCL_LEAVE_ERR_MSG) == NULL)
  297.         return TCL_ERROR;
  298.  
  299.     sprintf (numBuf, "%d", statBufPtr->st_nlink);
  300.     if  (Tcl_SetVar2 (interp, arrayName, "nlink", numBuf,
  301.                       TCL_LEAVE_ERR_MSG) == NULL)
  302.         return TCL_ERROR;
  303.  
  304.     sprintf (numBuf, "%d", statBufPtr->st_uid);
  305.     if  (Tcl_SetVar2 (interp, arrayName, "uid", numBuf,
  306.                       TCL_LEAVE_ERR_MSG) == NULL)
  307.         return TCL_ERROR;
  308.  
  309.     sprintf (numBuf, "%d", statBufPtr->st_gid);
  310.     if  (Tcl_SetVar2 (interp, arrayName, "gid", numBuf,
  311.                       TCL_LEAVE_ERR_MSG) == NULL)
  312.         return TCL_ERROR;
  313.  
  314.     sprintf (numBuf, "%d", statBufPtr->st_size);
  315.     if  (Tcl_SetVar2 (interp, arrayName, "size", numBuf,
  316.                       TCL_LEAVE_ERR_MSG) == NULL)
  317.         return TCL_ERROR;
  318.  
  319.     sprintf (numBuf, "%d", statBufPtr->st_atime);
  320.     if  (Tcl_SetVar2 (interp, arrayName, "atime", numBuf,
  321.                       TCL_LEAVE_ERR_MSG) == NULL)
  322.         return TCL_ERROR;
  323.  
  324.     sprintf (numBuf, "%d", statBufPtr->st_mtime);
  325.     if  (Tcl_SetVar2 (interp, arrayName, "mtime", numBuf,
  326.                       TCL_LEAVE_ERR_MSG) == NULL)
  327.         return TCL_ERROR;
  328.  
  329.     sprintf (numBuf, "%d", statBufPtr->st_ctime);
  330.     if  (Tcl_SetVar2 (interp, arrayName, "ctime", numBuf,
  331.                       TCL_LEAVE_ERR_MSG) == NULL)
  332.         return TCL_ERROR;
  333.  
  334.     if (Tcl_SetVar2 (interp, arrayName, "tty", 
  335.                      isatty (fileno (filePtr->f)) ? "1" : "0",
  336.                      TCL_LEAVE_ERR_MSG) == NULL)
  337.         return TCL_ERROR;
  338.  
  339.     if (Tcl_SetVar2 (interp, arrayName, "type", GetFileType (statBufPtr),
  340.                      TCL_LEAVE_ERR_MSG) == NULL)
  341.         return TCL_ERROR;
  342.  
  343.     return TCL_OK;
  344.  
  345. }
  346.  
  347. /*
  348.  *-----------------------------------------------------------------------------
  349.  *
  350.  * ReturnStatItem --
  351.  *
  352.  *   Return a single file status item.
  353.  *
  354.  * Parameters:
  355.  *   o interp (I) - Item or error returned in result.
  356.  *   o filePtr (I) - Pointer to the Tcl open file structure.
  357.  *   o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
  358.  *   o itemName (I) - The name of the desired item.
  359.  * Returns:
  360.  *   TCL_OK or TCL_ERROR.
  361.  *-----------------------------------------------------------------------------
  362.  */
  363. static int
  364. ReturnStatItem (interp, filePtr, statBufPtr, itemName)
  365.     Tcl_Interp   *interp;
  366.     OpenFile     *filePtr;
  367.     struct stat  *statBufPtr;
  368.     char         *itemName;
  369. {
  370.     if (STREQU (itemName, "dev"))
  371.         sprintf (interp->result, "%d", statBufPtr->st_dev);
  372.     else if (STREQU (itemName, "ino"))
  373.         sprintf (interp->result, "%d", statBufPtr->st_ino);
  374.     else if (STREQU (itemName, "mode"))
  375.         sprintf (interp->result, "%d", statBufPtr->st_mode);
  376.     else if (STREQU (itemName, "nlink"))
  377.         sprintf (interp->result, "%d", statBufPtr->st_nlink);
  378.     else if (STREQU (itemName, "uid"))
  379.         sprintf (interp->result, "%d", statBufPtr->st_uid);
  380.     else if (STREQU (itemName, "gid"))
  381.         sprintf (interp->result, "%d", statBufPtr->st_gid);
  382.     else if (STREQU (itemName, "size"))
  383.         sprintf (interp->result, "%d", statBufPtr->st_size);
  384.     else if (STREQU (itemName, "atime"))
  385.         sprintf (interp->result, "%d", statBufPtr->st_atime);
  386.     else if (STREQU (itemName, "mtime"))
  387.         sprintf (interp->result, "%d", statBufPtr->st_mtime);
  388.     else if (STREQU (itemName, "ctime"))
  389.         sprintf (interp->result, "%d", statBufPtr->st_ctime);
  390.     else if (STREQU (itemName, "type"))
  391.         interp->result = GetFileType (statBufPtr);
  392.     else if (STREQU (itemName, "tty"))
  393.         interp->result = isatty (fileno (filePtr->f)) ? "1" : "0";
  394.     else {
  395.         Tcl_AppendResult (interp, "Got \"", itemName, "\", expected one of ",
  396.                           "\"atime\", \"ctime\", \"dev\", \"gid\", \"ino\", ",
  397.                           "\"mode\", \"mtime\", \"nlink\", \"size\", ",
  398.                           "\"tty\", \"type\", \"uid\"", (char *) NULL);
  399.  
  400.         return TCL_ERROR;
  401.     }
  402.  
  403.     return TCL_OK;
  404.  
  405. }
  406.  
  407. /*
  408.  *-----------------------------------------------------------------------------
  409.  *
  410.  * Tcl_FstatCmd --
  411.  *     Implements the fstat TCL command:
  412.  *         fstat handle [item]|[stat arrayvar]
  413.  *
  414.  *-----------------------------------------------------------------------------
  415.  */
  416. int
  417. Tcl_FstatCmd (clientData, interp, argc, argv)
  418.     ClientData  clientData;
  419.     Tcl_Interp *interp;
  420.     int         argc;
  421.     char      **argv;
  422. {
  423.     OpenFile    *filePtr;
  424.     struct stat  statBuf;
  425.  
  426.     if ((argc < 2) || (argc > 4)) {
  427.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  428.                           " handle [item]|[stat arrayVar]", (char *) NULL);
  429.         return TCL_ERROR;
  430.     }
  431.  
  432.     if (TclGetOpenFile (interp, argv[1], &filePtr) != TCL_OK)
  433.     return TCL_ERROR;
  434.     
  435.     if (fstat (fileno (filePtr->f), &statBuf)) {
  436.         interp->result = Tcl_UnixError (interp);
  437.         return TCL_ERROR;
  438.     }
  439.  
  440.     /*
  441.      * Return data in the requested format.
  442.      */
  443.     if (argc == 4) {
  444.         if (!STREQU (argv [2], "stat")) {
  445.             Tcl_AppendResult (interp, "expected item name of \"stat\" when ",
  446.                               "using array name", (char *) NULL);
  447.             return TCL_ERROR;
  448.         }
  449.         return ReturnStatArray (interp, filePtr, &statBuf, argv [3]);
  450.     }
  451.     if (argc == 3)
  452.         return ReturnStatItem (interp, filePtr, &statBuf, argv [2]);
  453.  
  454.     ReturnStatList (interp, filePtr, &statBuf);
  455.     return TCL_OK;
  456.  
  457. }
  458.  
  459. /*
  460.  *-----------------------------------------------------------------------------
  461.  *
  462.  * Tcl_LgetsCmd --
  463.  *
  464.  * Implements the `lgets' Tcl command:
  465.  *    lgets fileId [varName]
  466.  *
  467.  * Results:
  468.  *      A standard Tcl result.
  469.  *
  470.  * Side effects:
  471.  *      See the user documentation.
  472.  *
  473.  *-----------------------------------------------------------------------------
  474.  */
  475. int
  476. Tcl_LgetsCmd (notUsed, interp, argc, argv)
  477.     ClientData   notUsed;
  478.     Tcl_Interp  *interp;
  479.     int          argc;
  480.     char       **argv;
  481. {
  482.     dynamicBuf_t  dynBuf;
  483.     char          prevChar;
  484.     int           bracesDepth, inQuotes, inChar;
  485.     OpenFile     *filePtr;
  486.  
  487.     if ((argc != 2) && (argc != 3)) {
  488.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0],
  489.                           " fileId [varName]", (char *) NULL);
  490.         return TCL_ERROR;
  491.     }
  492.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  493.         return TCL_ERROR;
  494.     }
  495.     if (!filePtr->readable) {
  496.         Tcl_AppendResult (interp, "\"", argv[1],
  497.                           "\" wasn't opened for reading", (char *) NULL);
  498.         return TCL_ERROR;
  499.     }
  500.  
  501.     Tcl_DynBufInit (&dynBuf);
  502.  
  503.     prevChar = '\0';
  504.     bracesDepth = 0;
  505.     inQuotes = FALSE;
  506.  
  507.     /*
  508.      * Read in characters, keeping trace of if we are in the middle of a {}
  509.      * or "" part of the list.
  510.      */
  511.  
  512.     while (TRUE) {
  513.         if (dynBuf.len + 1 == dynBuf.size)
  514.             Tcl_ExpandDynBuf (&dynBuf, 0);
  515.         inChar = getc (filePtr->f);
  516.         if (inChar == EOF) {
  517.             if (ferror (filePtr->f))
  518.                 goto readError;
  519.             break;
  520.         }
  521.         if (prevChar != '\\') {
  522.             switch (inChar) {
  523.                 case '{':
  524.                     bracesDepth++;
  525.                     break;
  526.                 case '}':
  527.                     if (bracesDepth == 0)
  528.                         break;
  529.                     bracesDepth--;
  530.                     break;
  531.                 case '"':
  532.                     if (bracesDepth == 0)
  533.                         inQuotes = !inQuotes;
  534.                     break;
  535.             }
  536.         }
  537.         prevChar = inChar;
  538.         if ((inChar == '\n') && (bracesDepth == 0) && !inQuotes)
  539.             break;
  540.         dynBuf.ptr [dynBuf.len++] = inChar;
  541.     }
  542.  
  543.     dynBuf.ptr [dynBuf.len] = '\0';
  544.  
  545.     if ((bracesDepth != 0) || inQuotes) {
  546.         Tcl_AppendResult (interp, "miss-matched ",
  547.                          (bracesDepth != 0) ? "braces" : "quote",
  548.                          " in inputed list: ", dynBuf.ptr, (char *) NULL);
  549.         goto errorExit;
  550.     }
  551.  
  552.     if (argc == 2) {
  553.         Tcl_DynBufReturn (interp, &dynBuf);
  554.     } else {
  555.         if (Tcl_SetVar (interp, argv[2], dynBuf.ptr, 
  556.                         TCL_LEAVE_ERR_MSG) == NULL)
  557.             goto errorExit;
  558.         if (feof (filePtr->f) && (dynBuf.len == 0))
  559.             interp->result = "-1";
  560.         else
  561.             sprintf (interp->result, "%d", dynBuf.len);
  562.         Tcl_DynBufFree (&dynBuf);
  563.     }
  564.     return TCL_OK;
  565.  
  566. readError:
  567.     Tcl_ResetResult (interp);
  568.     interp->result = Tcl_UnixError (interp);
  569.     clearerr (filePtr->f);
  570.     goto errorExit;
  571.  
  572. errorExit:
  573.     Tcl_DynBufFree (&dynBuf);
  574.     return TCL_ERROR;
  575.  
  576. }
  577.  
  578. #ifndef TCL_NO_FILE_LOCKING
  579.  
  580. /*
  581.  *-----------------------------------------------------------------------------
  582.  *
  583.  * ParseLockUnlockArgs --
  584.  *
  585.  * Parse the positional arguments common to both the flock and funlock
  586.  * commands:
  587.  *   ... handle [start] [length] [origin]
  588.  *
  589.  * Parameters:
  590.  *   o interp (I) - Pointer to the interpreter, errors returned in result.
  591.  *   o argc (I) - Count of arguments supplied to the comment.
  592.  *   o argv (I) - Commant argument vector.
  593.  *   o argIdx (I) - Index of the first common agument to parse.
  594.  *   o filePtrPtr (O) - Pointer to the open file structure returned here.
  595.  *   o lockInfoPtr (O) - Fcntl info structure, start, length and whence
  596.  *     are initialized by this routine.
  597.  * Returns:
  598.  *   TCL_OK if all is OK,  TCL_ERROR and an error message is result.
  599.  *
  600.  *-----------------------------------------------------------------------------
  601.  */
  602. static int
  603. ParseLockUnlockArgs (interp, argc, argv, argIdx, filePtrPtr, lockInfoPtr)
  604.     Tcl_Interp    *interp;
  605.     int            argc;
  606.     char         **argv;
  607.     int            argIdx;
  608.     OpenFile     **filePtrPtr;
  609.     struct flock  *lockInfoPtr;
  610. {
  611.  
  612.     lockInfoPtr->l_start  = 0;
  613.     lockInfoPtr->l_len    = 0;
  614.     lockInfoPtr->l_whence = 0;
  615.  
  616.     if (TclGetOpenFile (interp, argv [argIdx], filePtrPtr) != TCL_OK)
  617.     return TCL_ERROR;
  618.     argIdx++;
  619.  
  620.     if ((argIdx < argc) && (argv [argIdx][0] != '\0')) {
  621.         if (Tcl_GetLong (interp, argv [argIdx],
  622.                          &lockInfoPtr->l_start) != TCL_OK)
  623.             return TCL_ERROR;
  624.     }
  625.     argIdx++;
  626.  
  627.     if ((argIdx < argc) && (argv [argIdx][0] != '\0')) {
  628.         if (Tcl_GetLong (interp, argv [argIdx], &lockInfoPtr->l_len) != TCL_OK)
  629.             return TCL_ERROR;
  630.     }
  631.     argIdx++;
  632.  
  633.     if (argIdx < argc) {
  634.         if (STREQU (argv [argIdx], "start"))
  635.             lockInfoPtr->l_whence = 0;
  636.         else if (STREQU (argv [argIdx], "current"))
  637.             lockInfoPtr->l_whence = 1;
  638.         else if (STREQU (argv [argIdx], "end"))
  639.             lockInfoPtr->l_whence = 2;
  640.         else
  641.             goto badOrgin;
  642.     }
  643.  
  644.     return TCL_OK;
  645.  
  646.   badOrgin:
  647.     Tcl_AppendResult(interp, "bad origin \"", argv [argIdx],
  648.                      "\": should be \"start\", \"current\", or \"end\"",
  649.                      (char *) NULL);
  650.     return TCL_ERROR;
  651.    
  652. }
  653.  
  654. /*
  655.  *-----------------------------------------------------------------------------
  656.  *
  657.  * Tcl_FlockCmd --
  658.  *
  659.  * Implements the `flock' Tcl command:
  660.  *    flock [-read|-write] [-nowait] handle [start] [length] [origin]
  661.  *
  662.  * Results:
  663.  *      A standard Tcl result.
  664.  *
  665.  *-----------------------------------------------------------------------------
  666.  */
  667. int
  668. Tcl_FlockCmd (notUsed, interp, argc, argv)
  669.     ClientData   notUsed;
  670.     Tcl_Interp  *interp;
  671.     int          argc;
  672.     char       **argv;
  673. {
  674.     int           argIdx, stat;
  675.     int           readLock = FALSE, writeLock = FALSE, noWaitLock = FALSE;
  676.     OpenFile     *filePtr;
  677.     struct flock  lockInfo;
  678.  
  679.     if (argc < 2)
  680.         goto invalidArgs;
  681.  
  682.     /*
  683.      * Parse off the options.
  684.      */
  685.     
  686.     for (argIdx = 1; (argIdx < argc) && (argv [argIdx][0] == '-'); argIdx++) {
  687.         if (STREQU (argv [argIdx], "-read")) {
  688.             readLock = TRUE;
  689.             continue;
  690.         }
  691.         if (STREQU (argv [argIdx], "-write")) {
  692.             writeLock = TRUE;
  693.             continue;
  694.         }
  695.         if (STREQU (argv [argIdx], "-nowait")) {
  696.             noWaitLock = TRUE;
  697.             continue;
  698.         }
  699.         goto invalidOption;
  700.     }
  701.  
  702.     if (readLock && writeLock)
  703.         goto bothReadAndWrite;
  704.     if (!(readLock || writeLock))
  705.         writeLock = TRUE;
  706.  
  707.     /*
  708.      * Make sure there are enough arguments left and then parse the 
  709.      * positional ones.
  710.      */
  711.     if ((argIdx > argc - 1) || (argIdx < argc - 4))
  712.         goto invalidArgs;
  713.  
  714.     if (ParseLockUnlockArgs (interp, argc, argv, argIdx, &filePtr,
  715.                              &lockInfo) != TCL_OK)
  716.         return TCL_ERROR;
  717.  
  718.     if (readLock && !filePtr->readable)
  719.         goto notReadable;
  720.     if (writeLock && !filePtr->writable)
  721.         goto notWritable;
  722.  
  723.     lockInfo.l_type = writeLock ? F_WRLCK : F_RDLCK;
  724.     
  725.     stat = fcntl (fileno (filePtr->f), noWaitLock ? F_SETLK : F_SETLKW, 
  726.                   &lockInfo);
  727.     if ((stat < 0) && (errno != EACCES)) {
  728.         interp->result = Tcl_UnixError (interp);
  729.         return TCL_ERROR;
  730.     }
  731.     
  732.     if (noWaitLock)
  733.         interp->result = (stat < 0) ? "0" : "1";
  734.  
  735.     return TCL_OK;
  736.  
  737.     /*
  738.      * Code to return error messages.
  739.      */
  740.  
  741.   invalidArgs:
  742.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " [-read|-write] ",
  743.                       "[-nowait] handle [start] [length] [origin]",
  744.                       (char *) NULL);
  745.     return TCL_ERROR;
  746.  
  747.     /*
  748.      * Invalid option found at argv [argIdx].
  749.      */
  750.   invalidOption:
  751.     Tcl_AppendResult (interp, "invalid option \"", argv [argIdx],
  752.                       "\" expected one of \"-read\", \"-write\", or ",
  753.                       "\"-nowait\"", (char *) NULL);
  754.     return TCL_ERROR;
  755.  
  756.   bothReadAndWrite:
  757.     interp->result = "can not specify both \"-read\" and \"-write\"";
  758.     return TCL_ERROR;
  759.  
  760.   notReadable:
  761.     interp->result = "file not open for reading";
  762.     return TCL_ERROR;
  763.  
  764.   notWritable:
  765.     interp->result = "file not open for writing";
  766.     return TCL_ERROR;
  767. }
  768.  
  769. /*
  770.  *-----------------------------------------------------------------------------
  771.  *
  772.  * Tcl_FunlockCmd --
  773.  *
  774.  * Implements the `funlock' Tcl command:
  775.  *    funlock handle [start] [length] [origin]
  776.  *
  777.  * Results:
  778.  *      A standard Tcl result.
  779.  *
  780.  *-----------------------------------------------------------------------------
  781.  */
  782. int
  783. Tcl_FunlockCmd (notUsed, interp, argc, argv)
  784.     ClientData   notUsed;
  785.     Tcl_Interp  *interp;
  786.     int          argc;
  787.     char       **argv;
  788. {
  789.     OpenFile     *filePtr;
  790.     struct flock  lockInfo;
  791.  
  792.     if ((argc < 2) || (argc > 5))
  793.         goto invalidArgs;
  794.  
  795.     if (ParseLockUnlockArgs (interp, argc, argv, 1, &filePtr,
  796.                              &lockInfo) != TCL_OK)
  797.         return TCL_ERROR;
  798.  
  799.     lockInfo.l_type = F_UNLCK;
  800.     
  801.     if (fcntl (fileno(filePtr->f), F_SETLK, &lockInfo) < 0) {
  802.         interp->result = Tcl_UnixError (interp);
  803.         return TCL_ERROR;
  804.     }
  805.     
  806.     return TCL_OK;
  807.  
  808.   invalidArgs:
  809.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  810.                       " handle [start] [length] [origin]", (char *) NULL);
  811.     return TCL_ERROR;
  812.  
  813. }
  814. #else
  815.  
  816. /*
  817.  *-----------------------------------------------------------------------------
  818.  *
  819.  * Tcl_FlockCmd --
  820.  *
  821.  * Version of the command that always returns an error on systems that
  822.  * don't have file locking.
  823.  *
  824.  *-----------------------------------------------------------------------------
  825.  */
  826. int
  827. Tcl_FlockCmd (notUsed, interp, argc, argv)
  828.     ClientData   notUsed;
  829.     Tcl_Interp  *interp;
  830.     int          argc;
  831.     char       **argv;
  832. {
  833.     interp->result = "File locking is not available on this system";
  834.     return TCL_ERROR;
  835. }
  836.  
  837. /*
  838.  *-----------------------------------------------------------------------------
  839.  *
  840.  * Tcl_FunlockCmd --
  841.  *
  842.  * Version of the command that always returns an error on systems that
  843.  * don't have file locking/
  844.  *
  845.  *-----------------------------------------------------------------------------
  846.  */
  847. int
  848. Tcl_FunlockCmd (notUsed, interp, argc, argv)
  849.     ClientData   notUsed;
  850.     Tcl_Interp  *interp;
  851.     int          argc;
  852.     char       **argv;
  853. {
  854.     return Tcl_FlockCmd (notUsed, interp, argc, argv);
  855. }
  856. #endif
  857.