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