1/*
2 * tclXfilecmds.c
3 *
4 * Extended Tcl file-related commands.
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: tclXfilecmds.c,v 1.2 2002/09/26 00:19:18 hobbs Exp $
16 *-----------------------------------------------------------------------------
17 */
18
19#include "tclExtdInt.h"
20
21static char *FILE_ID_OPT = "-fileid";
22
23/*
24 * Prototypes of internal functions.
25 */
26static int
27TruncateByPath  _ANSI_ARGS_((Tcl_Interp  *interp,
28                             char        *filePath,
29                             off_t        newSize));
30
31static int
32ReadDirCallback _ANSI_ARGS_((Tcl_Interp  *interp,
33                             char        *path,
34                             char        *fileName,
35                             int          caseSensitive,
36                             ClientData   clientData));
37
38static int
39TclX_PipeObjCmd _ANSI_ARGS_((ClientData  clientData,
40                             Tcl_Interp *interp,
41                             int         objc,
42                             Tcl_Obj    *CONST objv[]));
43
44static int
45TclX_FtruncateObjCmd _ANSI_ARGS_((ClientData  clientData,
46                                  Tcl_Interp *interp,
47                                  int         objc,
48                                  Tcl_Obj    *CONST objv[]));
49
50static int
51TclX_ReaddirObjCmd _ANSI_ARGS_((ClientData clientData,
52                                Tcl_Interp *interp,
53                                int         objc,
54                                Tcl_Obj    *CONST objv[]));
55
56
57/*-----------------------------------------------------------------------------
58 * Tcl_PipeObjCmd --
59 *     Implements the pipe TCL command:
60 *         pipe ?fileId_var_r fileId_var_w?
61 *
62 * Results:
63 *      Standard TCL result.
64 *-----------------------------------------------------------------------------
65 */
66static int
67TclX_PipeObjCmd (clientData, interp, objc, objv)
68     ClientData  clientData;
69     Tcl_Interp *interp;
70     int         objc;
71     Tcl_Obj    *CONST objv[];
72{
73    Tcl_Channel   channels [2];
74    CONST84 char *channelNames [2];
75
76    if (!((objc == 1) || (objc == 3)))
77	return TclX_WrongArgs (interp, objv [0], "?fileId_var_r fileId_var_w?");
78
79    if (TclXOSpipe (interp, channels) != TCL_OK)
80        return TCL_ERROR;
81
82
83    channelNames [0] = Tcl_GetChannelName (channels [0]);
84    channelNames [1] = Tcl_GetChannelName (channels [1]);
85
86    if (objc == 1) {
87        TclX_AppendObjResult (interp, channelNames [0], " ",
88                              channelNames [1], (char *) NULL);
89    } else {
90        if (Tcl_ObjSetVar2(interp, objv[1], NULL, Tcl_NewStringObj(channelNames [0], -1),
91                           TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL)
92            goto errorExit;
93
94        if (Tcl_ObjSetVar2(interp, objv[2], NULL,
95                           Tcl_NewStringObj(channelNames [1], -1),
96                           TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL)
97            goto errorExit;
98    }
99
100    return TCL_OK;
101
102  errorExit:
103    Tcl_Close (NULL, channels [0]);
104    Tcl_Close (NULL, channels [1]);
105    return TCL_ERROR;
106}
107
108/*-----------------------------------------------------------------------------
109 * TruncateByPath --
110 *
111 *  Truncate a file via path, if this is available on this system.
112 *
113 * Parameters:
114 *   o interp (I) - Error messages are returned in the interpreter.
115 *   o filePath (I) - Path to file.
116 *   o newSize (I) - Size to truncate the file to.
117 * Returns:
118 *   TCL_OK or TCL_ERROR.
119 *-----------------------------------------------------------------------------
120 */
121static int
122TruncateByPath (interp, filePath, newSize)
123    Tcl_Interp  *interp;
124    char        *filePath;
125    off_t        newSize;
126{
127#ifndef NO_TRUNCATE
128    Tcl_DString  pathBuf;
129
130    Tcl_DStringInit (&pathBuf);
131
132    filePath = Tcl_TranslateFileName (interp, filePath, &pathBuf);
133    if (filePath == NULL) {
134        Tcl_DStringFree (&pathBuf);
135        return TCL_ERROR;
136    }
137    if (truncate (filePath, newSize) != 0) {
138        TclX_AppendObjResult (interp, filePath, ": ", Tcl_PosixError (interp),
139                              (char *) NULL);
140        Tcl_DStringFree (&pathBuf);
141        return TCL_ERROR;
142    }
143
144    Tcl_DStringFree (&pathBuf);
145    return TCL_OK;
146#else
147    TclX_AppendObjResult (interp, "truncating files by path is not available ",
148                          "on this system", (char *) NULL);
149    return TCL_ERROR;
150#endif
151}
152
153/*-----------------------------------------------------------------------------
154 * Tcl_FtruncateObjCmd --
155 *     Implements the Tcl ftruncate command:
156 *     ftruncate [-fileid] file newsize
157 *
158 * Results:
159 *  Standard TCL results, may return the UNIX system error message.
160 *
161 *-----------------------------------------------------------------------------
162 */
163static int
164TclX_FtruncateObjCmd (clientData, interp, objc, objv)
165    ClientData   clientData;
166    Tcl_Interp  *interp;
167    int          objc;
168    Tcl_Obj     *CONST objv[];
169{
170    int           objIdx, fileIds;
171    off_t         newSize;
172    long          convSize;
173    Tcl_Channel   channel;
174    char         *switchString;
175    char         *pathString;
176
177    fileIds = FALSE;
178    for (objIdx = 1; objIdx < objc ; objIdx++) {
179        switchString = Tcl_GetStringFromObj (objv [objIdx], NULL);
180	if (*switchString != '-')
181            break;
182        if (STREQU (switchString, FILE_ID_OPT)) {
183            fileIds = TRUE;
184        } else {
185            TclX_AppendObjResult (interp, "Invalid option \"", switchString,
186                                  "\", expected \"", FILE_ID_OPT, "\"",
187                                  (char *) NULL);
188            return TCL_ERROR;
189        }
190    }
191
192    if (objIdx != objc - 2)
193        return TclX_WrongArgs (interp, objv [0], "[-fileid] file newsize");
194
195    if (Tcl_GetLongFromObj (interp, objv [objIdx + 1], &convSize) != TCL_OK)
196        return TCL_ERROR;
197
198    newSize = convSize;
199    if (fileIds) {
200        channel = TclX_GetOpenChannelObj (interp, objv [objIdx], 0);
201        if (channel == NULL)
202            return TCL_ERROR;
203        return TclXOSftruncate (interp, channel, newSize,
204                                "-fileid option");
205    } else {
206	pathString = Tcl_GetStringFromObj (objv [objIdx], NULL);
207        return TruncateByPath (interp, pathString, newSize);
208    }
209}
210
211/*-----------------------------------------------------------------------------
212 * ReadDirCallback --
213 *
214 *   Callback procedure for walking directories.
215 * Parameters:
216 *   o interp (I) - Interp is passed though.
217 *   o path (I) - Normalized path to directory.
218 *   o fileName (I) - Tcl normalized file name in directory.
219 *   o caseSensitive (I) - Are the file names case sensitive?  Always
220 *     TRUE on Unix.
221 *   o clientData (I) - Tcl_DString to append names to.
222 * Returns:
223 *   TCL_OK.
224 *-----------------------------------------------------------------------------
225 */
226static int
227ReadDirCallback (interp, path, fileName, caseSensitive, clientData)
228    Tcl_Interp  *interp;
229    char        *path;
230    char        *fileName;
231    int          caseSensitive;
232    ClientData   clientData;
233{
234    Tcl_Obj *fileListObj = (Tcl_Obj *) clientData;
235    Tcl_Obj *fileNameObj;
236    int      result;
237
238    fileNameObj = Tcl_NewStringObj (fileName, -1);
239    result = Tcl_ListObjAppendElement (interp, fileListObj, fileNameObj);
240    return result;
241}
242
243/*-----------------------------------------------------------------------------
244 * Tcl_ReaddirObjCmd --
245 *     Implements the rename TCL command:
246 *         readdir ?-hidden? dirPath
247 *
248 * Results:
249 *      Standard TCL result.
250 *-----------------------------------------------------------------------------
251 */
252static int
253TclX_ReaddirObjCmd (clientData, interp, objc, objv)
254    ClientData  clientData;
255    Tcl_Interp *interp;
256    int         objc;
257    Tcl_Obj    *CONST objv[];
258{
259    Tcl_DString  pathBuf;
260    char        *dirPath;
261    int          hidden, status;
262    Tcl_Obj     *fileListObj;
263    char        *switchString;
264    int          dirPathLen;
265
266    if ((objc < 2) || (objc > 3))
267        return TclX_WrongArgs (interp, objv [0], "?-hidden? dirPath");
268
269    if (objc == 2) {
270        dirPath = Tcl_GetStringFromObj (objv [1], &dirPathLen);
271        hidden = FALSE;
272    } else {
273        switchString = Tcl_GetStringFromObj (objv [1], NULL);
274        if (!STREQU (switchString, "-hidden")) {
275            TclX_AppendObjResult (interp,
276                                  "expected option of \"-hidden\", got \"",
277                                  switchString, "\"", (char *) NULL);
278            return TCL_ERROR;
279        }
280        dirPath = Tcl_GetStringFromObj (objv [2], NULL);
281        hidden = TRUE;
282    }
283
284    Tcl_DStringInit (&pathBuf);
285
286    fileListObj = Tcl_NewObj ();
287
288    dirPath = Tcl_TranslateFileName (interp, dirPath, &pathBuf);
289    if (dirPath == NULL) {
290        goto errorExit;
291    }
292
293    status = TclXOSWalkDir (interp,
294                            dirPath,
295                            hidden,
296                            ReadDirCallback,
297                            (ClientData) fileListObj);
298    if (status == TCL_ERROR)
299        goto errorExit;
300
301    Tcl_DStringFree (&pathBuf);
302    Tcl_SetObjResult (interp, fileListObj);
303    return TCL_OK;
304
305  errorExit:
306    Tcl_DStringFree (&pathBuf);
307    Tcl_DecrRefCount (fileListObj);
308    return TCL_ERROR;
309}
310
311
312/*-----------------------------------------------------------------------------
313 * TclX_FilecmdsInit --
314 *     Initialize the file commands.
315 *-----------------------------------------------------------------------------
316 */
317void
318TclX_FilecmdsInit (interp)
319    Tcl_Interp *interp;
320{
321    Tcl_CreateObjCommand (interp,
322			  "pipe",
323			  TclX_PipeObjCmd,
324                          (ClientData) NULL,
325			  (Tcl_CmdDeleteProc*) NULL);
326
327    Tcl_CreateObjCommand (interp,
328			  "ftruncate",
329			  TclX_FtruncateObjCmd,
330			  (ClientData) NULL,
331			  (Tcl_CmdDeleteProc*) NULL);
332
333    Tcl_CreateObjCommand (interp,
334                          "readdir",
335			  TclX_ReaddirObjCmd,
336                          (ClientData) NULL,
337			  (Tcl_CmdDeleteProc*) NULL);
338}
339
340