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