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