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

   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 "tclxint.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 \f
  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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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