1/*
2 * tclXdup.c
3 *
4 * Extended Tcl dup 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: tclXdup.c,v 1.3 2005/04/26 20:01:33 hobbs Exp $
16 *-----------------------------------------------------------------------------
17 */
18#include "tclExtdInt.h"
19
20/*
21 * Prototypes of internal functions.
22 */
23static int
24DupChannelOptions _ANSI_ARGS_((Tcl_Interp  *interp,
25                               Tcl_Channel  srcChannel,
26                               Tcl_Channel  targetChannel));
27
28static Tcl_Channel
29DupFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
30                            char       *srcFileId,
31                            char       *targetFileId));
32
33static int
34TclX_DupObjCmd _ANSI_ARGS_((ClientData   clientData,
35                            Tcl_Interp  *interp,
36                            int          objc,
37                            Tcl_Obj     *CONST objv[]));
38
39
40/*-----------------------------------------------------------------------------
41 * DupChannelOptions --
42 *
43 *   Set the channel options of one channel to those of another.
44 *
45 * Parameters:
46 *   o interp (I) - Errors returned in result.
47 *   o srcChannel (I) - Channel to get the options.
48 *   o targetChannel (I) - Channel to set the options on.
49 * Result:
50 *   TCL_OK or TCL_ERROR;
51 *-----------------------------------------------------------------------------
52 */
53static int
54DupChannelOptions (interp, srcChannel, targetChannel)
55    Tcl_Interp  *interp;
56    Tcl_Channel  srcChannel;
57    Tcl_Channel  targetChannel;
58{
59    Tcl_DString strValues;
60    CONST84 char *option, *value, **optArgv = NULL;
61    int optArgc, idx;
62
63    Tcl_DStringInit (&strValues);
64
65    if (Tcl_GetChannelOption (interp, srcChannel, NULL, &strValues) != TCL_OK) {
66        goto errorExit;
67    }
68
69    /*
70     * Split the list for each name/value pair and set the new channel.
71     * Only modify blocking if its not the default, as setting blocking on
72     * standard files generates an error on some systems.  Skip options
73     * that can't be set.
74     */
75    if (Tcl_SplitList(interp, strValues.string, &optArgc, &optArgv) != TCL_OK) {
76        goto errorExit;
77    }
78    if ((optArgc % 2) != 0) {
79        panic("channel didn't return keyword/value pairs");
80    }
81
82    for (idx = 0; idx < optArgc; idx += 2) {
83        option = optArgv[idx];
84        value = optArgv[idx+1];
85        if (STREQU (option, "-blocking") && (value [0] != '0')) {
86            continue;
87        }
88        if (STREQU (option, "-peername") || STREQU (option, "-sockname")) {
89            continue;
90        }
91        if (Tcl_SetChannelOption (interp, targetChannel, option,
92                                  value) != TCL_OK) {
93            goto errorExit;
94        }
95    }
96
97    Tcl_DStringFree (&strValues);
98    if (optArgv != NULL) {
99        ckfree((char *)optArgv);
100    }
101    return TCL_OK;
102
103  errorExit:
104    Tcl_DStringFree (&strValues);
105    if (optArgv != NULL) {
106        ckfree((char *)optArgv);
107    }
108    return TCL_ERROR;
109}
110
111/*-----------------------------------------------------------------------------
112 * DupFileChannel --
113 *   Do common work for all platforms for duplicate a channel
114 *
115 * Parameters:
116 *   o interp (I) - If an error occures, the error message is in result.
117 *   o srcChannelId (I) - The id of the channel to dup.
118 *   o targetChannelId (I) - The id for the new file.  NULL if any id maybe
119 *     used.
120 * Returns:
121 *   The unregistered channel, or NULL if an error occurs.
122 *-----------------------------------------------------------------------------
123 */
124static Tcl_Channel
125DupFileChannel (interp, srcChannelId, targetChannelId)
126    Tcl_Interp *interp;
127    char       *srcChannelId;
128    char       *targetChannelId;
129{
130    Tcl_Channel srcChannel, newChannel = NULL;
131    Tcl_ChannelType *channelType;
132    int mode;
133
134    srcChannel = Tcl_GetChannel (interp, srcChannelId, &mode);
135    if (srcChannel == NULL) {
136        return NULL;
137    }
138    channelType = Tcl_GetChannelType (srcChannel);
139    if (STREQU (channelType->typeName, "pipe")) {
140        TclX_AppendObjResult (interp, "can not \"dup\" a Tcl command ",
141                              "pipeline created with the \"open\" command",
142                              (char *) NULL);
143        return NULL;
144    }
145
146    /*
147     * If writable, flush out the buffer.
148     */
149    if (mode & TCL_WRITABLE) {
150        if (Tcl_Flush (srcChannel) == TCL_ERROR)
151            goto posixError;
152    }
153
154    /*
155     * Use OS dependent function to actually dup the channel.
156     */
157    newChannel = TclXOSDupChannel (interp, srcChannel, mode, targetChannelId);
158    if (newChannel == NULL)
159        return NULL;
160
161    /*
162     * If the channel is open for reading and seekable, seek the new channel
163     * to the same position. Tcl_Tell returns -1 if seek is not supported.
164     */
165    if (mode & TCL_READABLE) {
166	int seekOffset = (int) Tcl_Tell (srcChannel);
167	if (seekOffset >= 0) {
168            if (Tcl_Seek (newChannel, seekOffset, SEEK_SET) < 0)
169                goto posixError;
170        }
171    }
172
173    if (DupChannelOptions (interp, srcChannel, newChannel) != TCL_OK)
174        goto errorExit;
175
176    return newChannel;
177
178  posixError:
179    Tcl_ResetResult (interp);
180    TclX_AppendObjResult (interp, "dup of \"", srcChannelId, "\" failed: ",
181                          Tcl_PosixError (interp), (char *) NULL);
182
183  errorExit:
184    if (newChannel != NULL) {
185        Tcl_Close (NULL, newChannel);
186    }
187    return NULL;
188}
189
190/*-----------------------------------------------------------------------------
191 * TclX_DupObjCmd --
192 *    Implements the dup TCL command:
193 *        dup channelId ?targetChannelId?
194 *-----------------------------------------------------------------------------
195 */
196static int
197TclX_DupObjCmd (clientData, interp, objc, objv)
198    ClientData   clientData;
199    Tcl_Interp  *interp;
200    int          objc;
201    Tcl_Obj     *CONST objv[];
202{
203    Tcl_Channel newChannel;
204    int bindFnum, fnum;
205    char *srcChannelId, *targetChannelId;
206
207    if ((objc < 2) || (objc > 3)) {
208        return TclX_WrongArgs (interp, objv [0],
209                               "channelId ?targetChannelId?");
210    }
211
212    /*
213     * If a number is supplied, bind it to a file handle rather than doing
214     * a dup.
215     */
216    if (objv [1]->typePtr == Tcl_GetObjType ("int")) {
217        bindFnum = TRUE;
218    } else {
219        srcChannelId = Tcl_GetStringFromObj (objv [1], NULL);
220        if (ISDIGIT (srcChannelId [0])) {
221            if (Tcl_ConvertToType (interp, objv [1],
222                                   Tcl_GetObjType ("int")) != TCL_OK)
223                goto badFnum;
224            bindFnum = TRUE;
225        } else {
226            bindFnum = FALSE;
227        }
228    }
229    if (bindFnum) {
230        if (objc != 2)
231            goto bind2ndArg;
232        if (Tcl_GetIntFromObj (interp, objv [1], &fnum) != TCL_OK)
233            return TCL_ERROR;
234        newChannel = TclXOSBindOpenFile (interp,  fnum);
235    } else {
236        if (objc > 2) {
237            targetChannelId = Tcl_GetStringFromObj (objv [2], NULL);
238        } else {
239            targetChannelId = NULL;
240        }
241        newChannel = DupFileChannel (interp,
242                                     srcChannelId,
243                                     targetChannelId);
244    }
245    if (newChannel == NULL)
246        return TCL_ERROR;
247
248    Tcl_RegisterChannel (interp, newChannel);
249    Tcl_SetStringObj (Tcl_GetObjResult (interp),
250                      Tcl_GetChannelName (newChannel), -1);
251    return TCL_OK;
252
253  badFnum:
254    Tcl_ResetResult (interp);
255    TclX_AppendObjResult (interp, "invalid integer file number \"",
256                          Tcl_GetStringFromObj (objv [1], NULL),
257                          "\", expected unsigned integer or Tcl file id",
258                          (char *) NULL);
259    return TCL_ERROR;
260
261  bind2ndArg:
262    TclX_AppendObjResult (interp, "the second argument, targetChannelId, ",
263                          "is not allow when binding a file number to ",
264                          "a Tcl channel", (char *) NULL);
265    return TCL_ERROR;
266}
267
268/*-----------------------------------------------------------------------------
269 * TclX_DupInit --
270 *   Initialize the dip command in an interpreter.
271 *
272 * Parameters:
273 *   o interp - Interpreter to add commandsto.
274 *-----------------------------------------------------------------------------
275 */
276void
277TclX_DupInit (interp)
278    Tcl_Interp *interp;
279{
280    Tcl_CreateObjCommand (interp,
281			  "dup",
282			  TclX_DupObjCmd,
283                          (ClientData) NULL,
284			  (Tcl_CmdDeleteProc*) NULL);
285}
286
287
288