cvs.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxfctl.c

   1 /*
   2  * tclXfcntl.c
   3  *
   4  * Extended Tcl fcntl command.
   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: tclXfcntl.c,v 2.0 1992/10/16 04:50:38 markd Rel $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.h"
  20
  21 /*
  22  * Macro to enable line buffering mode on a file.  Macros assure that the
  23  * resulting expression returns zero if the function call does not return
  24  * a value.
  25  */
  26 #ifdef TCL_HAVE_SETLINEBUF
  27 #   define SET_LINE_BUF(fp)  (setlinebuf (fp),0)
  28 #else
  29 #   define SET_LINE_BUF(fp)  setvbuf (fp, NULL, _IOLBF, BUFSIZ)
  30 #endif
  31
  32 /*
  33  * If we don't have O_NONBLOCK, use O_NDELAY.
  34  */
  35 #ifndef O_NONBLOCK
  36 #   define O_NONBLOCK O_NDELAY
  37 #endif
  38
  39 /*
  40  * Attributes used by fcntl command and the maximum length of any attribute
  41  * name.
  42  */
  43 #define   ATTR_CLOEXEC  1
  44 #define   ATTR_NOBUF    2
  45 #define   ATTR_LINEBUF  4
  46 #define   MAX_ATTR_NAME_LEN  20
  47
  48 /*
  49  * Prototypes of internal functions.
  50  */
  51 static int
  52 XlateFcntlAttr  _ANSI_ARGS_((Tcl_Interp *interp,
  53                              char       *attrName,
  54                              int        *fcntlAttrPtr,
  55                              int        *otherAttrPtr));
  56
  57 static int
  58 GetFcntlAttr _ANSI_ARGS_((Tcl_Interp *interp,
  59                           OpenFile   *filePtr,
  60                           char       *attrName));
  61
  62 static int
  63 SetFcntlAttr _ANSI_ARGS_((Tcl_Interp *interp,
  64                           OpenFile   *filePtr,
  65                           char       *attrName,
  66                           char       *valueStr));
  67 \f
  68 /*
  69  *-----------------------------------------------------------------------------
  70  *
  71  * XlateFcntlAttr --
  72  *    Translate an fcntl attribute.
  73  *
  74  * Parameters:
  75  *   o interp (I) - Tcl interpreter.
  76  *   o attrName (I) - The attrbute name to translate, maybe upper or lower
  77  *     case.
  78  *   o fcntlAttrPtr (O) - If the attr specified is one of the standard
  79  *     fcntl attrs, it is returned here, otherwise zero is returned.
  80  *   o otherAttrPtr (O) - If the attr specified is one of the additional
  81  *     attrs supported by the Tcl command, it is returned here, otherwise
  82  *     zero is returned.
  83  * Result:
  84  *   Returns TCL_OK if all is well, TCL_ERROR if there is an error.
  85  *-----------------------------------------------------------------------------
  86  */
  87 static int
  88 XlateFcntlAttr (interp, attrName, fcntlAttrPtr, otherAttrPtr)
  89     Tcl_Interp *interp;
  90     char       *attrName;
  91     int        *fcntlAttrPtr;
  92     int        *otherAttrPtr;
  93 {
  94     char attrNameUp [MAX_ATTR_NAME_LEN];
  95
  96     *fcntlAttrPtr = 0;
  97     *otherAttrPtr = 0;
  98
  99     if (strlen (attrName) >= MAX_ATTR_NAME_LEN)
 100         goto invalidAttrName;
 101
 102     Tcl_UpShift (attrNameUp, attrName);
 103
 104     if (STREQU (attrNameUp, "RDONLY")) {
 105         *fcntlAttrPtr = O_RDONLY;
 106         return TCL_OK;
 107     }
 108     if (STREQU (attrNameUp, "WRONLY")) {
 109         *fcntlAttrPtr = O_WRONLY;
 110         return TCL_OK;
 111     }
 112     if (STREQU (attrNameUp, "RDWR")) {
 113         *fcntlAttrPtr = O_RDWR;
 114         return TCL_OK;
 115     }
 116     if (STREQU (attrNameUp, "READ")) {
 117         *fcntlAttrPtr = O_RDONLY | O_RDWR;
 118         return TCL_OK;
 119     }
 120     if (STREQU (attrNameUp, "WRITE")) {
 121         *fcntlAttrPtr = O_WRONLY | O_RDWR;
 122         return TCL_OK;
 123     }
 124     if (STREQU (attrNameUp, "NONBLOCK")) {
 125         *fcntlAttrPtr = O_NONBLOCK;
 126         return TCL_OK;
 127     }
 128     if (STREQU (attrNameUp, "APPEND")) {
 129         *fcntlAttrPtr = O_APPEND;
 130         return TCL_OK;
 131     }
 132     if (STREQU (attrNameUp, "CLOEXEC")) {
 133         *otherAttrPtr = ATTR_CLOEXEC;
 134         return TCL_OK;
 135     }
 136     if (STREQU (attrNameUp, "NOBUF")) {
 137         *otherAttrPtr = ATTR_NOBUF;
 138         return TCL_OK;
 139     }
 140     if (STREQU (attrNameUp, "LINEBUF")) {
 141         *otherAttrPtr = ATTR_LINEBUF;
 142         return TCL_OK;
 143     }
 144
 145     /*
 146      * Error return code.
 147      */
 148   invalidAttrName:
 149     Tcl_AppendResult (interp, "unknown attribute name \"", attrName,
 150                       "\", expected one of APPEND, CLOEXEC, LINEBUF, ",
 151                       "NONBLOCK, NOBUF, READ, RDONLY, RDWR, WRITE, WRONLY",
 152                       (char *) NULL);
 153     return TCL_ERROR;
 154
 155 }
 156 \f
 157 /*
 158  *-----------------------------------------------------------------------------
 159  *
 160  * GetFcntlAttr --
 161  *    Return the value of a specified fcntl attribute.
 162  *
 163  * Parameters:
 164  *   o interp (I) - Tcl interpreter, value is returned in the result
 165  *   o filePtr (I) - Pointer to the file descriptor.
 166  *   o attrName (I) - The attrbute name to translate, maybe upper or lower
 167  *     case.
 168  * Result:
 169  *   Returns TCL_OK if all is well, TCL_ERROR if fcntl returns an error.
 170  *-----------------------------------------------------------------------------
 171  */
 172 static int
 173 GetFcntlAttr (interp, filePtr, attrName)
 174     Tcl_Interp *interp;
 175     OpenFile   *filePtr;
 176     char       *attrName;
 177 {
 178     int fcntlAttr, otherAttr, current;
 179
 180     if (XlateFcntlAttr (interp, attrName, &fcntlAttr, &otherAttr) != TCL_OK)
 181         return TCL_ERROR;
 182
 183     if (fcntlAttr != 0) {
 184         current = fcntl (fileno (filePtr->f), F_GETFL, 0);
 185         if (current == -1)
 186             goto unixError;
 187         interp->result = (current & fcntlAttr) ? "1" : "0";
 188         return TCL_OK;
 189     }
 190
 191     if (otherAttr & ATTR_CLOEXEC) {
 192         current = fcntl (fileno (filePtr->f), F_GETFD, 0);
 193         if (current == -1)
 194             goto unixError;
 195         interp->result = (current & 1) ? "1" : "0";
 196         return TCL_OK;
 197     }
 198
 199     /*
 200      * Poke the stdio FILE structure to determine the buffering status.
 201      */
 202
 203 #ifndef IS_LINUX
 204
 205 #ifdef _IONBF
 206     if (otherAttr & ATTR_NOBUF) {
 207         interp->result = (filePtr->f->_flag & _IONBF) ? "1" : "0";
 208         return TCL_OK;
 209     }
 210     if (otherAttr & ATTR_LINEBUF) {
 211         interp->result = (filePtr->f->_flag & _IOLBF) ? "1" : "0";
 212         return TCL_OK;
 213     }
 214 #else
 215     if (otherAttr & ATTR_NOBUF) {
 216         interp->result = (filePtr->f->_flags & _SNBF) ? "1" : "0";
 217         return TCL_OK;
 218     }
 219     if (otherAttr & ATTR_LINEBUF) {
 220         interp->result = (filePtr->f->_flags & _SLBF) ? "1" : "0";
 221         return TCL_OK;
 222     }
 223 #endif
 224
 225 #endif
 226
 227 unixError:
 228     interp->result = Tcl_UnixError (interp);
 229     return TCL_ERROR;
 230 }
 231 \f
 232 /*
 233  *-----------------------------------------------------------------------------
 234  *
 235  * SetFcntlAttr --
 236  *    Set the specified fcntl attr to the given value.
 237  *
 238  * Parameters:
 239  *   o interp (I) - Tcl interpreter, value is returned in the result
 240  *   o filePtr (I) - Pointer to the file descriptor.
 241  *   o attrName (I) - The attrbute name to translate, maybe upper or lower
 242  *     case.
 243  *   o valueStr (I) - The string value to set the attribiute to.
 244  *
 245  * Result:
 246  *   Returns TCL_OK if all is well, TCL_ERROR if there is an error.
 247  *-----------------------------------------------------------------------------
 248  */
 249 static int
 250 SetFcntlAttr (interp, filePtr, attrName, valueStr)
 251     Tcl_Interp *interp;
 252     OpenFile   *filePtr;
 253     char       *attrName;
 254     char       *valueStr;
 255 {
 256
 257     int fcntlAttr, otherAttr, current, setValue;
 258
 259     if (Tcl_GetBoolean (interp, valueStr, &setValue) != TCL_OK)
 260         return TCL_ERROR;
 261
 262     if (XlateFcntlAttr (interp, attrName, &fcntlAttr, &otherAttr) != TCL_OK)
 263         return TCL_ERROR;
 264
 265     /*
 266      * Validate that this the attribute may be set (or cleared).
 267      */
 268
 269     if (fcntlAttr & (O_RDONLY | O_WRONLY | O_RDWR)) {
 270         Tcl_AppendResult (interp, "Attribute \"", attrName, "\" may not be ",
 271                           "altered after open", (char *) NULL);
 272         return TCL_ERROR;
 273     }
 274
 275     if ((otherAttr & (ATTR_NOBUF | ATTR_LINEBUF)) && !setValue) {
 276         Tcl_AppendResult (interp, "Attribute \"", attrName, "\" may not be ",
 277                           "cleared once set", (char *) NULL);
 278         return TCL_ERROR;
 279     }
 280
 281     if (otherAttr == ATTR_CLOEXEC) {
 282         if (fcntl (fileno (filePtr->f), F_SETFD, setValue) == -1)
 283             goto unixError;
 284         return TCL_OK;
 285     }
 286
 287     if (otherAttr == ATTR_NOBUF) {
 288         setbuf (filePtr->f, NULL);
 289         return TCL_OK;
 290     }
 291
 292     if (otherAttr == ATTR_LINEBUF) {
 293         if (SET_LINE_BUF (filePtr->f) != 0)
 294             goto unixError;
 295         return TCL_OK;
 296     }
 297
 298     /*
 299      * Handle standard fcntl attrs.
 300      */
 301
 302     current = fcntl (fileno (filePtr->f), F_GETFL, 0);
 303     if (current == -1)
 304         goto unixError;
 305     current &= ~fcntlAttr;
 306     if (setValue)
 307         current |= fcntlAttr;
 308     if (fcntl (fileno (filePtr->f), F_SETFL, current) == -1)
 309         goto unixError;
 310
 311     return TCL_OK;
 312
 313   unixError:
 314     interp->result = Tcl_UnixError (interp);
 315     return TCL_ERROR;
 316
 317 }
 318 \f
 319 /*
 320  *-----------------------------------------------------------------------------
 321  *
 322  * Tcl_FcntlCmd --
 323  *     Implements the fcntl TCL command:
 324  *         fcntl handle [attribute value]
 325  *-----------------------------------------------------------------------------
 326  */
 327 int
 328 Tcl_FcntlCmd (clientData, interp, argc, argv)
 329     ClientData  clientData;
 330     Tcl_Interp *interp;
 331     int         argc;
 332     char      **argv;
 333 {
 334     OpenFile    *filePtr;
 335
 336     if ((argc < 3) || (argc > 4)) {
 337         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
 338                           " handle attribute [value]", (char *) NULL);
 339         return TCL_ERROR;
 340     }
 341
 342     if (TclGetOpenFile (interp, argv[1], &filePtr) != TCL_OK)
 343         return TCL_ERROR;
 344     if (argc == 3) {
 345         if (GetFcntlAttr (interp, filePtr, argv [2]) != TCL_OK)
 346             return TCL_ERROR;
 347     } else {
 348         if (SetFcntlAttr (interp, filePtr, argv [2], argv [3]) != TCL_OK)
 349             return TCL_ERROR;
 350     }
 351     return TCL_OK;
 352 }