1/*
2 * tclXfcntl.c
3 *
4 * Extended Tcl fcntl command.
5 *-----------------------------------------------------------------------------
6 * Copyright 1991-1999 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 1.2 2005/01/19 03:20:47 hobbs Exp $
16 *-----------------------------------------------------------------------------
17 */
18
19#include "tclExtdInt.h"
20
21/*
22 * Attributes sets used by fcntl command.
23 */
24#define ATTR_ERROR           -1  /* Error parsing attributes.   */
25
26#define ATTR_RDONLY           1  /* Access checks desired.      */
27#define ATTR_WRONLY           2
28#define ATTR_RDWR             3
29#define ATTR_READ             4
30#define ATTR_WRITE            5
31#define ATTR_APPEND           6
32#define ATTR_CLOEXEC          7
33#define ATTR_NOBUF            8
34#define ATTR_LINEBUF          9
35#define ATTR_NONBLOCK        10
36#define ATTR_KEEPALIVE       11
37
38/*
39 * The maximum length of any attribute name.
40 */
41#define MAX_ATTR_NAME_LEN  20
42
43/*
44 * Table of attribute names and values.
45 */
46static struct {
47    char *name;
48    int   id;
49    int   modifiable;
50} TclXfcntlAttrNames [] = {
51    {"RDONLY",    ATTR_RDONLY,    FALSE},
52    {"WRONLY",    ATTR_WRONLY,    FALSE},
53    {"RDWR",      ATTR_RDWR,      FALSE},
54    {"READ",      ATTR_READ,      FALSE},
55    {"WRITE",     ATTR_WRITE,     FALSE},
56    {"APPEND",    ATTR_APPEND,    TRUE},
57    {"CLOEXEC",   ATTR_CLOEXEC,   TRUE},
58    {"NONBLOCK",  ATTR_NONBLOCK,  TRUE},
59    {"LINEBUF",   ATTR_LINEBUF,   TRUE},
60    {"NOBUF",     ATTR_NOBUF,     TRUE},
61    {"KEEPALIVE", ATTR_KEEPALIVE, TRUE},
62    {NULL,        0,              FALSE}};
63
64/*
65 * Prototypes of internal functions.
66 */
67static int
68XlateFcntlAttr  _ANSI_ARGS_((Tcl_Interp  *interp,
69                             char        *attrName,
70                             int          modify));
71
72static int
73GetFcntlAttr _ANSI_ARGS_((Tcl_Interp  *interp,
74                          Tcl_Channel  channel,
75                          int          mode,
76                          int          attrib));
77
78static int
79SetFcntlAttrObj _ANSI_ARGS_((Tcl_Interp  *interp,
80                             Tcl_Channel  channel,
81                             int          attrib,
82                             Tcl_Obj     *valueObj));
83
84static int
85TclX_FcntlObjCmd _ANSI_ARGS_((ClientData clientData,
86                              Tcl_Interp *interp,
87                              int objc,
88                              Tcl_Obj *CONST objv[]));
89
90
91/*-----------------------------------------------------------------------------
92 * XlateFcntlAttr --
93 *    Translate an fcntl attribute to an numberic id.
94 *
95 * Parameters:
96 *   o interp - Tcl interp, errors in result
97 *   o attrName - The attrbute name to translate, maybe upper or lower case.
98 *   o modify - Will the attribute be modified
99 * Result:
100 *   The number associated with the attirbute, or ATTR_ERROR is an error
101 * occures.
102 *-----------------------------------------------------------------------------
103 */
104static int
105XlateFcntlAttr (interp, attrName, modify)
106    Tcl_Interp  *interp;
107    char        *attrName;
108    int          modify;
109{
110    char attrNameUp [MAX_ATTR_NAME_LEN];
111    int idx;
112
113    if (strlen (attrName) >= MAX_ATTR_NAME_LEN)
114        goto invalidAttrName;
115
116    TclX_UpShift (attrNameUp, attrName);
117
118    for (idx = 0; TclXfcntlAttrNames [idx].name != NULL; idx++) {
119        if (STREQU (attrNameUp, TclXfcntlAttrNames [idx].name)) {
120            if (modify && !TclXfcntlAttrNames [idx].modifiable) {
121                TclX_AppendObjResult (interp, "Attribute \"", attrName,
122                                      "\" may not be altered after open",
123                                      (char *) NULL);
124                return ATTR_ERROR;
125            }
126            return TclXfcntlAttrNames [idx].id;
127        }
128    }
129
130    /*
131     * Invalid attribute.
132     */
133  invalidAttrName:
134    TclX_AppendObjResult (interp, "unknown attribute name \"", attrName,
135                          "\", expected one of ", (char *) NULL);
136
137    for (idx = 0; TclXfcntlAttrNames [idx + 1].name != NULL; idx++) {
138        TclX_AppendObjResult (interp, TclXfcntlAttrNames [idx].name, ", ",
139                              (char *) NULL);
140    }
141    TclX_AppendObjResult (interp, "or ", TclXfcntlAttrNames [idx].name, (char *) NULL);
142    return ATTR_ERROR;
143}
144
145/*-----------------------------------------------------------------------------
146 * GetFcntlAttr --
147 *    Return the value of a specified fcntl attribute.
148 *
149 * Parameters:
150 *   o interp - Tcl interpreter, value is returned in the result
151 *   o channel - The channel to check.
152 *   o mode - Channel access mode.
153 *   o attrib - Attribute to get.
154 * Result:
155 *   TCL_OK or TCL_ERROR
156 *-----------------------------------------------------------------------------
157 */
158static int
159GetFcntlAttr (interp, channel, mode, attrib)
160    Tcl_Interp  *interp;
161    Tcl_Channel  channel;
162    int          mode;
163    int          attrib;
164{
165    int value, optValue;
166
167    switch (attrib) {
168      case ATTR_RDONLY:
169        value = (mode & TCL_READABLE) && !(mode & TCL_WRITABLE);
170        break;
171      case ATTR_WRONLY:
172        value = (mode & TCL_WRITABLE) && !(mode & TCL_READABLE);
173        break;
174      case ATTR_RDWR:
175        value = (mode & TCL_READABLE) && (mode & TCL_WRITABLE);
176        break;
177      case ATTR_READ:
178        value =  (mode & TCL_READABLE);
179        break;
180      case ATTR_WRITE:
181        value = (mode & TCL_WRITABLE);
182        break;
183      case ATTR_APPEND:
184        if (TclXOSGetAppend (interp, channel, &value) != TCL_OK)
185            return TCL_ERROR;
186        break;
187      case ATTR_CLOEXEC:
188        if (TclXOSGetCloseOnExec (interp, channel, &value) != TCL_OK)
189            return TCL_ERROR;
190        break;
191      case ATTR_NONBLOCK:
192        if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BLOCKING,
193                                   &optValue) != TCL_OK)
194            return TCL_ERROR;
195        value = (optValue == TCLX_MODE_NONBLOCKING);
196        break;
197      case ATTR_NOBUF:
198        if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BUFFERING,
199                                   &optValue) != TCL_OK)
200            return TCL_ERROR;
201        value = (optValue == TCLX_BUFFERING_NONE);
202        break;
203      case ATTR_LINEBUF:
204        if (TclX_GetChannelOption (interp, channel, TCLX_COPT_BUFFERING,
205                                   &optValue) != TCL_OK)
206            return TCL_ERROR;
207        value = (optValue == TCLX_BUFFERING_LINE);
208        break;
209      case ATTR_KEEPALIVE:
210        if (TclXOSgetsockopt (interp, channel, SO_KEEPALIVE, &value) != TCL_OK)
211            return TCL_ERROR;
212        break;
213      default:
214        panic ("bug in fcntl get attrib");
215    }
216
217    Tcl_SetIntObj (Tcl_GetObjResult (interp), value != 0);
218    return TCL_OK;
219}
220
221/*-----------------------------------------------------------------------------
222 * SetFcntlAttrObj --
223 *    Set the the attributes on a channel.
224 *
225 * Parameters:
226 *   o interp - Tcl interpreter, value is returned in the result
227 *   o channel - The channel to check.
228 *   o attrib - Atrribute to set.
229 *   o valueStr - Object value (all are boolean now).
230 * Result:
231 *   TCL_OK or TCL_ERROR.
232 *-----------------------------------------------------------------------------
233 */
234static int
235SetFcntlAttrObj (interp, channel, attrib, valueObj)
236    Tcl_Interp  *interp;
237    Tcl_Channel  channel;
238    int          attrib;
239    Tcl_Obj     *valueObj;
240{
241    int value;
242
243    if (Tcl_GetBooleanFromObj (interp, valueObj, &value) != TCL_OK)
244        return TCL_ERROR;
245
246    switch (attrib) {
247      case ATTR_APPEND:
248        if (TclXOSSetAppend (interp, channel, value) != TCL_OK)
249            return TCL_ERROR;
250        return TCL_OK;
251      case ATTR_CLOEXEC:
252        if (TclXOSSetCloseOnExec (interp, channel, value) != TCL_OK)
253            return TCL_ERROR;
254        return TCL_OK;
255      case ATTR_NONBLOCK:
256        return TclX_SetChannelOption (interp, channel, TCLX_COPT_BLOCKING,
257                                      value ? TCLX_MODE_NONBLOCKING :
258                                              TCLX_MODE_BLOCKING);
259      case ATTR_NOBUF:
260        return TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING,
261                                      value ? TCLX_BUFFERING_NONE :
262                                              TCLX_BUFFERING_FULL);
263      case ATTR_LINEBUF:
264        return TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING,
265                                      value ? TCLX_BUFFERING_LINE :
266                                              TCLX_BUFFERING_FULL);
267      case ATTR_KEEPALIVE:
268        return TclXOSsetsockopt (interp, channel, SO_KEEPALIVE, value);
269      default:
270        panic ("buf in fcntl set attrib");
271    }
272    return TCL_ERROR;  /* Should never be reached */
273}
274
275/*-----------------------------------------------------------------------------
276 * TclX_FcntlObjCmd --
277 *     Implements the fcntl TCL command:
278 *         fcntl handle attribute ?value?
279 *-----------------------------------------------------------------------------
280 */
281static int
282TclX_FcntlObjCmd (clientData, interp, objc, objv)
283    ClientData  clientData;
284    Tcl_Interp *interp;
285    int         objc;
286    Tcl_Obj    *CONST objv[];
287{
288    Tcl_Channel  channel;
289    int          mode;
290    int          attrib;
291    char        *channelString;
292    char        *fcntlAttributes;
293
294    if ((objc < 3) || (objc > 4))
295	return TclX_WrongArgs (interp, objv [0],
296                               "handle attribute ?value?");
297
298    channelString = Tcl_GetStringFromObj (objv[1], NULL);
299
300    channel = Tcl_GetChannel (interp, channelString, &mode);
301    if (channel == NULL) {
302	return TCL_ERROR;
303    }
304
305    fcntlAttributes = Tcl_GetStringFromObj (objv[2], NULL);
306    attrib = XlateFcntlAttr (interp, fcntlAttributes, (objc == 4));
307    if (attrib == ATTR_ERROR)
308        return TCL_ERROR;
309
310    if (objc == 3) {
311        if (GetFcntlAttr (interp, channel, mode, attrib) != TCL_OK)
312            return TCL_ERROR;
313    } else {
314        if (SetFcntlAttrObj (interp, channel, attrib, objv[3]) != TCL_OK)
315            return TCL_ERROR;
316    }
317    return TCL_OK;
318}
319
320
321/*-----------------------------------------------------------------------------
322 * TclX_FcntlInit --
323 *     Initialize the fcntl command.
324 *-----------------------------------------------------------------------------
325 */
326void
327TclX_FcntlInit (interp)
328    Tcl_Interp *interp;
329{
330    Tcl_CreateObjCommand (interp,
331			  "fcntl",
332			  TclX_FcntlObjCmd,
333                          (ClientData) NULL,
334			  (Tcl_CmdDeleteProc*) NULL);
335}
336
337