os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIOCmd.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIOCmd.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1554 @@
1.4 +/*
1.5 + * tclIOCmd.c --
1.6 + *
1.7 + * Contains the definitions of most of the Tcl commands relating to IO.
1.8 + *
1.9 + * Copyright (c) 1995-1997 Sun Microsystems, Inc.
1.10 + *
1.11 + * See the file "license.terms" for information on usage and redistribution
1.12 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.13 + *
1.14 + * RCS: @(#) $Id: tclIOCmd.c,v 1.15.2.2 2004/07/16 22:38:37 andreas_kupries Exp $
1.15 + */
1.16 +
1.17 +#include "tclInt.h"
1.18 +#include "tclPort.h"
1.19 +
1.20 +/*
1.21 + * Callback structure for accept callback in a TCP server.
1.22 + */
1.23 +
1.24 +typedef struct AcceptCallback {
1.25 + char *script; /* Script to invoke. */
1.26 + Tcl_Interp *interp; /* Interpreter in which to run it. */
1.27 +} AcceptCallback;
1.28 +
1.29 +/*
1.30 + * Static functions for this file:
1.31 + */
1.32 +
1.33 +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
1.34 + Tcl_Channel chan, char *address, int port));
1.35 +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
1.36 + AcceptCallback *acceptCallbackPtr));
1.37 +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
1.38 + ClientData clientData, Tcl_Interp *interp));
1.39 +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
1.40 +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
1.41 + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));
1.42 +
1.43 +/*
1.44 + *----------------------------------------------------------------------
1.45 + *
1.46 + * Tcl_PutsObjCmd --
1.47 + *
1.48 + * This procedure is invoked to process the "puts" Tcl command.
1.49 + * See the user documentation for details on what it does.
1.50 + *
1.51 + * Results:
1.52 + * A standard Tcl result.
1.53 + *
1.54 + * Side effects:
1.55 + * Produces output on a channel.
1.56 + *
1.57 + *----------------------------------------------------------------------
1.58 + */
1.59 +
1.60 + /* ARGSUSED */
1.61 +int
1.62 +Tcl_PutsObjCmd(dummy, interp, objc, objv)
1.63 + ClientData dummy; /* Not used. */
1.64 + Tcl_Interp *interp; /* Current interpreter. */
1.65 + int objc; /* Number of arguments. */
1.66 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.67 +{
1.68 + Tcl_Channel chan; /* The channel to puts on. */
1.69 + Tcl_Obj *string; /* String to write. */
1.70 + int newline; /* Add a newline at end? */
1.71 + char *channelId; /* Name of channel for puts. */
1.72 + int result; /* Result of puts operation. */
1.73 + int mode; /* Mode in which channel is opened. */
1.74 +
1.75 + switch (objc) {
1.76 + case 2: /* puts $x */
1.77 + string = objv[1];
1.78 + newline = 1;
1.79 + channelId = "stdout";
1.80 + break;
1.81 +
1.82 + case 3: /* puts -nonewline $x or puts $chan $x */
1.83 + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
1.84 + newline = 0;
1.85 + channelId = "stdout";
1.86 + } else {
1.87 + newline = 1;
1.88 + channelId = Tcl_GetString(objv[1]);
1.89 + }
1.90 + string = objv[2];
1.91 + break;
1.92 +
1.93 + case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */
1.94 + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
1.95 + channelId = Tcl_GetString(objv[2]);
1.96 + string = objv[3];
1.97 + } else {
1.98 + /*
1.99 + * The code below provides backwards compatibility with an
1.100 + * old form of the command that is no longer recommended
1.101 + * or documented.
1.102 + */
1.103 +
1.104 + char *arg;
1.105 + int length;
1.106 +
1.107 + arg = Tcl_GetStringFromObj(objv[3], &length);
1.108 + if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
1.109 + Tcl_AppendResult(interp, "bad argument \"", arg,
1.110 + "\": should be \"nonewline\"",
1.111 + (char *) NULL);
1.112 + return TCL_ERROR;
1.113 + }
1.114 + channelId = Tcl_GetString(objv[1]);
1.115 + string = objv[2];
1.116 + }
1.117 + newline = 0;
1.118 + break;
1.119 +
1.120 + default: /* puts or puts some bad number of arguments... */
1.121 + Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
1.122 + return TCL_ERROR;
1.123 + }
1.124 +
1.125 + chan = Tcl_GetChannel(interp, channelId, &mode);
1.126 + if (chan == (Tcl_Channel) NULL) {
1.127 + return TCL_ERROR;
1.128 + }
1.129 + if ((mode & TCL_WRITABLE) == 0) {
1.130 + Tcl_AppendResult(interp, "channel \"", channelId,
1.131 + "\" wasn't opened for writing", (char *) NULL);
1.132 + return TCL_ERROR;
1.133 + }
1.134 +
1.135 + result = Tcl_WriteObj(chan, string);
1.136 + if (result < 0) {
1.137 + goto error;
1.138 + }
1.139 + if (newline != 0) {
1.140 + result = Tcl_WriteChars(chan, "\n", 1);
1.141 + if (result < 0) {
1.142 + goto error;
1.143 + }
1.144 + }
1.145 + return TCL_OK;
1.146 +
1.147 + error:
1.148 + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
1.149 + Tcl_PosixError(interp), (char *) NULL);
1.150 + return TCL_ERROR;
1.151 +}
1.152 +
1.153 +/*
1.154 + *----------------------------------------------------------------------
1.155 + *
1.156 + * Tcl_FlushObjCmd --
1.157 + *
1.158 + * This procedure is called to process the Tcl "flush" command.
1.159 + * See the user documentation for details on what it does.
1.160 + *
1.161 + * Results:
1.162 + * A standard Tcl result.
1.163 + *
1.164 + * Side effects:
1.165 + * May cause output to appear on the specified channel.
1.166 + *
1.167 + *----------------------------------------------------------------------
1.168 + */
1.169 +
1.170 + /* ARGSUSED */
1.171 +int
1.172 +Tcl_FlushObjCmd(dummy, interp, objc, objv)
1.173 + ClientData dummy; /* Not used. */
1.174 + Tcl_Interp *interp; /* Current interpreter. */
1.175 + int objc; /* Number of arguments. */
1.176 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.177 +{
1.178 + Tcl_Channel chan; /* The channel to flush on. */
1.179 + char *channelId;
1.180 + int mode;
1.181 +
1.182 + if (objc != 2) {
1.183 + Tcl_WrongNumArgs(interp, 1, objv, "channelId");
1.184 + return TCL_ERROR;
1.185 + }
1.186 + channelId = Tcl_GetString(objv[1]);
1.187 + chan = Tcl_GetChannel(interp, channelId, &mode);
1.188 + if (chan == (Tcl_Channel) NULL) {
1.189 + return TCL_ERROR;
1.190 + }
1.191 + if ((mode & TCL_WRITABLE) == 0) {
1.192 + Tcl_AppendResult(interp, "channel \"", channelId,
1.193 + "\" wasn't opened for writing", (char *) NULL);
1.194 + return TCL_ERROR;
1.195 + }
1.196 +
1.197 + if (Tcl_Flush(chan) != TCL_OK) {
1.198 + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
1.199 + Tcl_PosixError(interp), (char *) NULL);
1.200 + return TCL_ERROR;
1.201 + }
1.202 + return TCL_OK;
1.203 +}
1.204 +
1.205 +/*
1.206 + *----------------------------------------------------------------------
1.207 + *
1.208 + * Tcl_GetsObjCmd --
1.209 + *
1.210 + * This procedure is called to process the Tcl "gets" command.
1.211 + * See the user documentation for details on what it does.
1.212 + *
1.213 + * Results:
1.214 + * A standard Tcl result.
1.215 + *
1.216 + * Side effects:
1.217 + * May consume input from channel.
1.218 + *
1.219 + *----------------------------------------------------------------------
1.220 + */
1.221 +
1.222 + /* ARGSUSED */
1.223 +int
1.224 +Tcl_GetsObjCmd(dummy, interp, objc, objv)
1.225 + ClientData dummy; /* Not used. */
1.226 + Tcl_Interp *interp; /* Current interpreter. */
1.227 + int objc; /* Number of arguments. */
1.228 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.229 +{
1.230 + Tcl_Channel chan; /* The channel to read from. */
1.231 + int lineLen; /* Length of line just read. */
1.232 + int mode; /* Mode in which channel is opened. */
1.233 + char *name;
1.234 + Tcl_Obj *resultPtr, *linePtr;
1.235 +
1.236 + if ((objc != 2) && (objc != 3)) {
1.237 + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
1.238 + return TCL_ERROR;
1.239 + }
1.240 + name = Tcl_GetString(objv[1]);
1.241 + chan = Tcl_GetChannel(interp, name, &mode);
1.242 + if (chan == (Tcl_Channel) NULL) {
1.243 + return TCL_ERROR;
1.244 + }
1.245 + if ((mode & TCL_READABLE) == 0) {
1.246 + Tcl_AppendResult(interp, "channel \"", name,
1.247 + "\" wasn't opened for reading", (char *) NULL);
1.248 + return TCL_ERROR;
1.249 + }
1.250 +
1.251 + linePtr = Tcl_NewObj();
1.252 +
1.253 + lineLen = Tcl_GetsObj(chan, linePtr);
1.254 + if (lineLen < 0) {
1.255 + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
1.256 + Tcl_DecrRefCount(linePtr);
1.257 + Tcl_ResetResult(interp);
1.258 + Tcl_AppendResult(interp, "error reading \"", name, "\": ",
1.259 + Tcl_PosixError(interp), (char *) NULL);
1.260 + return TCL_ERROR;
1.261 + }
1.262 + lineLen = -1;
1.263 + }
1.264 + if (objc == 3) {
1.265 + if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
1.266 + TCL_LEAVE_ERR_MSG) == NULL) {
1.267 + Tcl_DecrRefCount(linePtr);
1.268 + return TCL_ERROR;
1.269 + }
1.270 + resultPtr = Tcl_GetObjResult(interp);
1.271 + Tcl_SetIntObj(resultPtr, lineLen);
1.272 + return TCL_OK;
1.273 + } else {
1.274 + Tcl_SetObjResult(interp, linePtr);
1.275 + }
1.276 + return TCL_OK;
1.277 +}
1.278 +
1.279 +/*
1.280 + *----------------------------------------------------------------------
1.281 + *
1.282 + * Tcl_ReadObjCmd --
1.283 + *
1.284 + * This procedure is invoked to process the Tcl "read" command.
1.285 + * See the user documentation for details on what it does.
1.286 + *
1.287 + * Results:
1.288 + * A standard Tcl result.
1.289 + *
1.290 + * Side effects:
1.291 + * May consume input from channel.
1.292 + *
1.293 + *----------------------------------------------------------------------
1.294 + */
1.295 +
1.296 + /* ARGSUSED */
1.297 +int
1.298 +Tcl_ReadObjCmd(dummy, interp, objc, objv)
1.299 + ClientData dummy; /* Not used. */
1.300 + Tcl_Interp *interp; /* Current interpreter. */
1.301 + int objc; /* Number of arguments. */
1.302 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.303 +{
1.304 + Tcl_Channel chan; /* The channel to read from. */
1.305 + int newline, i; /* Discard newline at end? */
1.306 + int toRead; /* How many bytes to read? */
1.307 + int charactersRead; /* How many characters were read? */
1.308 + int mode; /* Mode in which channel is opened. */
1.309 + char *name;
1.310 + Tcl_Obj *resultPtr;
1.311 +
1.312 + if ((objc != 2) && (objc != 3)) {
1.313 + argerror:
1.314 + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
1.315 + Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),
1.316 + " ?-nonewline? channelId\"", (char *) NULL);
1.317 + return TCL_ERROR;
1.318 + }
1.319 +
1.320 + i = 1;
1.321 + newline = 0;
1.322 + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
1.323 + newline = 1;
1.324 + i++;
1.325 + }
1.326 +
1.327 + if (i == objc) {
1.328 + goto argerror;
1.329 + }
1.330 +
1.331 + name = Tcl_GetString(objv[i]);
1.332 + chan = Tcl_GetChannel(interp, name, &mode);
1.333 + if (chan == (Tcl_Channel) NULL) {
1.334 + return TCL_ERROR;
1.335 + }
1.336 + if ((mode & TCL_READABLE) == 0) {
1.337 + Tcl_AppendResult(interp, "channel \"", name,
1.338 + "\" wasn't opened for reading", (char *) NULL);
1.339 + return TCL_ERROR;
1.340 + }
1.341 + i++; /* Consumed channel name. */
1.342 +
1.343 + /*
1.344 + * Compute how many bytes to read, and see whether the final
1.345 + * newline should be dropped.
1.346 + */
1.347 +
1.348 + toRead = -1;
1.349 + if (i < objc) {
1.350 + char *arg;
1.351 +
1.352 + arg = Tcl_GetString(objv[i]);
1.353 + if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
1.354 + if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
1.355 + return TCL_ERROR;
1.356 + }
1.357 + } else if (strcmp(arg, "nonewline") == 0) {
1.358 + newline = 1;
1.359 + } else {
1.360 + Tcl_AppendResult(interp, "bad argument \"", arg,
1.361 + "\": should be \"nonewline\"", (char *) NULL);
1.362 + return TCL_ERROR;
1.363 + }
1.364 + }
1.365 +
1.366 + resultPtr = Tcl_NewObj();
1.367 + Tcl_IncrRefCount(resultPtr);
1.368 + charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
1.369 + if (charactersRead < 0) {
1.370 + Tcl_ResetResult(interp);
1.371 + Tcl_AppendResult(interp, "error reading \"", name, "\": ",
1.372 + Tcl_PosixError(interp), (char *) NULL);
1.373 + Tcl_DecrRefCount(resultPtr);
1.374 + return TCL_ERROR;
1.375 + }
1.376 +
1.377 + /*
1.378 + * If requested, remove the last newline in the channel if at EOF.
1.379 + */
1.380 +
1.381 + if ((charactersRead > 0) && (newline != 0)) {
1.382 + char *result;
1.383 + int length;
1.384 +
1.385 + result = Tcl_GetStringFromObj(resultPtr, &length);
1.386 + if (result[length - 1] == '\n') {
1.387 + Tcl_SetObjLength(resultPtr, length - 1);
1.388 + }
1.389 + }
1.390 + Tcl_SetObjResult(interp, resultPtr);
1.391 + Tcl_DecrRefCount(resultPtr);
1.392 + return TCL_OK;
1.393 +}
1.394 +
1.395 +/*
1.396 + *----------------------------------------------------------------------
1.397 + *
1.398 + * Tcl_SeekObjCmd --
1.399 + *
1.400 + * This procedure is invoked to process the Tcl "seek" command. See
1.401 + * the user documentation for details on what it does.
1.402 + *
1.403 + * Results:
1.404 + * A standard Tcl result.
1.405 + *
1.406 + * Side effects:
1.407 + * Moves the position of the access point on the specified channel.
1.408 + * May flush queued output.
1.409 + *
1.410 + *----------------------------------------------------------------------
1.411 + */
1.412 +
1.413 + /* ARGSUSED */
1.414 +int
1.415 +Tcl_SeekObjCmd(clientData, interp, objc, objv)
1.416 + ClientData clientData; /* Not used. */
1.417 + Tcl_Interp *interp; /* Current interpreter. */
1.418 + int objc; /* Number of arguments. */
1.419 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.420 +{
1.421 + Tcl_Channel chan; /* The channel to tell on. */
1.422 + Tcl_WideInt offset; /* Where to seek? */
1.423 + int mode; /* How to seek? */
1.424 + Tcl_WideInt result; /* Of calling Tcl_Seek. */
1.425 + char *chanName;
1.426 + int optionIndex;
1.427 + static CONST char *originOptions[] = {
1.428 + "start", "current", "end", (char *) NULL
1.429 + };
1.430 + static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
1.431 +
1.432 + if ((objc != 3) && (objc != 4)) {
1.433 + Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
1.434 + return TCL_ERROR;
1.435 + }
1.436 + chanName = Tcl_GetString(objv[1]);
1.437 + chan = Tcl_GetChannel(interp, chanName, NULL);
1.438 + if (chan == (Tcl_Channel) NULL) {
1.439 + return TCL_ERROR;
1.440 + }
1.441 + if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
1.442 + return TCL_ERROR;
1.443 + }
1.444 + mode = SEEK_SET;
1.445 + if (objc == 4) {
1.446 + if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
1.447 + &optionIndex) != TCL_OK) {
1.448 + return TCL_ERROR;
1.449 + }
1.450 + mode = modeArray[optionIndex];
1.451 + }
1.452 +
1.453 + result = Tcl_Seek(chan, offset, mode);
1.454 + if (result == Tcl_LongAsWide(-1)) {
1.455 + Tcl_AppendResult(interp, "error during seek on \"",
1.456 + chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
1.457 + return TCL_ERROR;
1.458 + }
1.459 + return TCL_OK;
1.460 +}
1.461 +
1.462 +/*
1.463 + *----------------------------------------------------------------------
1.464 + *
1.465 + * Tcl_TellObjCmd --
1.466 + *
1.467 + * This procedure is invoked to process the Tcl "tell" command.
1.468 + * See the user documentation for details on what it does.
1.469 + *
1.470 + * Results:
1.471 + * A standard Tcl result.
1.472 + *
1.473 + * Side effects:
1.474 + * None.
1.475 + *
1.476 + *----------------------------------------------------------------------
1.477 + */
1.478 +
1.479 + /* ARGSUSED */
1.480 +int
1.481 +Tcl_TellObjCmd(clientData, interp, objc, objv)
1.482 + ClientData clientData; /* Not used. */
1.483 + Tcl_Interp *interp; /* Current interpreter. */
1.484 + int objc; /* Number of arguments. */
1.485 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.486 +{
1.487 + Tcl_Channel chan; /* The channel to tell on. */
1.488 + char *chanName;
1.489 +
1.490 + if (objc != 2) {
1.491 + Tcl_WrongNumArgs(interp, 1, objv, "channelId");
1.492 + return TCL_ERROR;
1.493 + }
1.494 + /*
1.495 + * Try to find a channel with the right name and permissions in
1.496 + * the IO channel table of this interpreter.
1.497 + */
1.498 +
1.499 + chanName = Tcl_GetString(objv[1]);
1.500 + chan = Tcl_GetChannel(interp, chanName, NULL);
1.501 + if (chan == (Tcl_Channel) NULL) {
1.502 + return TCL_ERROR;
1.503 + }
1.504 + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
1.505 + return TCL_OK;
1.506 +}
1.507 +
1.508 +/*
1.509 + *----------------------------------------------------------------------
1.510 + *
1.511 + * Tcl_CloseObjCmd --
1.512 + *
1.513 + * This procedure is invoked to process the Tcl "close" command.
1.514 + * See the user documentation for details on what it does.
1.515 + *
1.516 + * Results:
1.517 + * A standard Tcl result.
1.518 + *
1.519 + * Side effects:
1.520 + * May discard queued input; may flush queued output.
1.521 + *
1.522 + *----------------------------------------------------------------------
1.523 + */
1.524 +
1.525 + /* ARGSUSED */
1.526 +int
1.527 +Tcl_CloseObjCmd(clientData, interp, objc, objv)
1.528 + ClientData clientData; /* Not used. */
1.529 + Tcl_Interp *interp; /* Current interpreter. */
1.530 + int objc; /* Number of arguments. */
1.531 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.532 +{
1.533 + Tcl_Channel chan; /* The channel to close. */
1.534 + char *arg;
1.535 +
1.536 + if (objc != 2) {
1.537 + Tcl_WrongNumArgs(interp, 1, objv, "channelId");
1.538 + return TCL_ERROR;
1.539 + }
1.540 +
1.541 + arg = Tcl_GetString(objv[1]);
1.542 + chan = Tcl_GetChannel(interp, arg, NULL);
1.543 + if (chan == (Tcl_Channel) NULL) {
1.544 + return TCL_ERROR;
1.545 + }
1.546 +
1.547 + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
1.548 + /*
1.549 + * If there is an error message and it ends with a newline, remove
1.550 + * the newline. This is done for command pipeline channels where the
1.551 + * error output from the subprocesses is stored in interp's result.
1.552 + *
1.553 + * NOTE: This is likely to not have any effect on regular error
1.554 + * messages produced by drivers during the closing of a channel,
1.555 + * because the Tcl convention is that such error messages do not
1.556 + * have a terminating newline.
1.557 + */
1.558 +
1.559 + Tcl_Obj *resultPtr;
1.560 + char *string;
1.561 + int len;
1.562 +
1.563 + resultPtr = Tcl_GetObjResult(interp);
1.564 + string = Tcl_GetStringFromObj(resultPtr, &len);
1.565 + if ((len > 0) && (string[len - 1] == '\n')) {
1.566 + Tcl_SetObjLength(resultPtr, len - 1);
1.567 + }
1.568 + return TCL_ERROR;
1.569 + }
1.570 +
1.571 + return TCL_OK;
1.572 +}
1.573 +
1.574 +/*
1.575 + *----------------------------------------------------------------------
1.576 + *
1.577 + * Tcl_FconfigureObjCmd --
1.578 + *
1.579 + * This procedure is invoked to process the Tcl "fconfigure" command.
1.580 + * See the user documentation for details on what it does.
1.581 + *
1.582 + * Results:
1.583 + * A standard Tcl result.
1.584 + *
1.585 + * Side effects:
1.586 + * May modify the behavior of an IO channel.
1.587 + *
1.588 + *----------------------------------------------------------------------
1.589 + */
1.590 +
1.591 + /* ARGSUSED */
1.592 +int
1.593 +Tcl_FconfigureObjCmd(clientData, interp, objc, objv)
1.594 + ClientData clientData; /* Not used. */
1.595 + Tcl_Interp *interp; /* Current interpreter. */
1.596 + int objc; /* Number of arguments. */
1.597 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.598 +{
1.599 + char *chanName, *optionName, *valueName;
1.600 + Tcl_Channel chan; /* The channel to set a mode on. */
1.601 + int i; /* Iterate over arg-value pairs. */
1.602 + Tcl_DString ds; /* DString to hold result of
1.603 + * calling Tcl_GetChannelOption. */
1.604 +
1.605 + if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
1.606 + Tcl_WrongNumArgs(interp, 1, objv,
1.607 + "channelId ?optionName? ?value? ?optionName value?...");
1.608 + return TCL_ERROR;
1.609 + }
1.610 + chanName = Tcl_GetString(objv[1]);
1.611 + chan = Tcl_GetChannel(interp, chanName, NULL);
1.612 + if (chan == (Tcl_Channel) NULL) {
1.613 + return TCL_ERROR;
1.614 + }
1.615 + if (objc == 2) {
1.616 + Tcl_DStringInit(&ds);
1.617 + if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
1.618 + Tcl_DStringFree(&ds);
1.619 + return TCL_ERROR;
1.620 + }
1.621 + Tcl_DStringResult(interp, &ds);
1.622 + return TCL_OK;
1.623 + }
1.624 + if (objc == 3) {
1.625 + Tcl_DStringInit(&ds);
1.626 + optionName = Tcl_GetString(objv[2]);
1.627 + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
1.628 + Tcl_DStringFree(&ds);
1.629 + return TCL_ERROR;
1.630 + }
1.631 + Tcl_DStringResult(interp, &ds);
1.632 + return TCL_OK;
1.633 + }
1.634 + for (i = 3; i < objc; i += 2) {
1.635 + optionName = Tcl_GetString(objv[i-1]);
1.636 + valueName = Tcl_GetString(objv[i]);
1.637 + if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
1.638 + != TCL_OK) {
1.639 + return TCL_ERROR;
1.640 + }
1.641 + }
1.642 + return TCL_OK;
1.643 +}
1.644 +
1.645 +/*
1.646 + *---------------------------------------------------------------------------
1.647 + *
1.648 + * Tcl_EofObjCmd --
1.649 + *
1.650 + * This procedure is invoked to process the Tcl "eof" command.
1.651 + * See the user documentation for details on what it does.
1.652 + *
1.653 + * Results:
1.654 + * A standard Tcl result.
1.655 + *
1.656 + * Side effects:
1.657 + * Sets interp's result to boolean true or false depending on whether
1.658 + * the specified channel has an EOF condition.
1.659 + *
1.660 + *---------------------------------------------------------------------------
1.661 + */
1.662 +
1.663 + /* ARGSUSED */
1.664 +int
1.665 +Tcl_EofObjCmd(unused, interp, objc, objv)
1.666 + ClientData unused; /* Not used. */
1.667 + Tcl_Interp *interp; /* Current interpreter. */
1.668 + int objc; /* Number of arguments. */
1.669 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.670 +{
1.671 + Tcl_Channel chan;
1.672 + int dummy;
1.673 + char *arg;
1.674 +
1.675 + if (objc != 2) {
1.676 + Tcl_WrongNumArgs(interp, 1, objv, "channelId");
1.677 + return TCL_ERROR;
1.678 + }
1.679 +
1.680 + arg = Tcl_GetString(objv[1]);
1.681 + chan = Tcl_GetChannel(interp, arg, &dummy);
1.682 + if (chan == NULL) {
1.683 + return TCL_ERROR;
1.684 + }
1.685 +
1.686 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan));
1.687 + return TCL_OK;
1.688 +}
1.689 +
1.690 +/*
1.691 + *----------------------------------------------------------------------
1.692 + *
1.693 + * Tcl_ExecObjCmd --
1.694 + *
1.695 + * This procedure is invoked to process the "exec" Tcl command.
1.696 + * See the user documentation for details on what it does.
1.697 + *
1.698 + * Results:
1.699 + * A standard Tcl result.
1.700 + *
1.701 + * Side effects:
1.702 + * See the user documentation.
1.703 + *
1.704 + *----------------------------------------------------------------------
1.705 + */
1.706 +
1.707 + /* ARGSUSED */
1.708 +int
1.709 +Tcl_ExecObjCmd(dummy, interp, objc, objv)
1.710 + ClientData dummy; /* Not used. */
1.711 + Tcl_Interp *interp; /* Current interpreter. */
1.712 + int objc; /* Number of arguments. */
1.713 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.714 +{
1.715 +#ifdef MAC_TCL
1.716 +
1.717 + Tcl_AppendResult(interp, "exec not implemented under Mac OS",
1.718 + (char *)NULL);
1.719 + return TCL_ERROR;
1.720 +
1.721 +#else /* !MAC_TCL */
1.722 +
1.723 + /*
1.724 + * This procedure generates an argv array for the string arguments. It
1.725 + * starts out with stack-allocated space but uses dynamically-allocated
1.726 + * storage if needed.
1.727 + */
1.728 +
1.729 +#define NUM_ARGS 20
1.730 + Tcl_Obj *resultPtr;
1.731 + CONST char **argv;
1.732 + char *string;
1.733 + Tcl_Channel chan;
1.734 + CONST char *argStorage[NUM_ARGS];
1.735 + int argc, background, i, index, keepNewline, result, skip, length;
1.736 + static CONST char *options[] = {
1.737 + "-keepnewline", "--", NULL
1.738 + };
1.739 + enum options {
1.740 + EXEC_KEEPNEWLINE, EXEC_LAST
1.741 + };
1.742 +
1.743 + /*
1.744 + * Check for a leading "-keepnewline" argument.
1.745 + */
1.746 +
1.747 + keepNewline = 0;
1.748 + for (skip = 1; skip < objc; skip++) {
1.749 + string = Tcl_GetString(objv[skip]);
1.750 + if (string[0] != '-') {
1.751 + break;
1.752 + }
1.753 + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
1.754 + TCL_EXACT, &index) != TCL_OK) {
1.755 + return TCL_ERROR;
1.756 + }
1.757 + if (index == EXEC_KEEPNEWLINE) {
1.758 + keepNewline = 1;
1.759 + } else {
1.760 + skip++;
1.761 + break;
1.762 + }
1.763 + }
1.764 + if (objc <= skip) {
1.765 + Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
1.766 + return TCL_ERROR;
1.767 + }
1.768 +
1.769 + /*
1.770 + * See if the command is to be run in background.
1.771 + */
1.772 +
1.773 + background = 0;
1.774 + string = Tcl_GetString(objv[objc - 1]);
1.775 + if ((string[0] == '&') && (string[1] == '\0')) {
1.776 + objc--;
1.777 + background = 1;
1.778 + }
1.779 +
1.780 + /*
1.781 + * Create the string argument array "argv". Make sure argv is large
1.782 + * enough to hold the argc arguments plus 1 extra for the zero
1.783 + * end-of-argv word.
1.784 + */
1.785 +
1.786 + argv = argStorage;
1.787 + argc = objc - skip;
1.788 + if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
1.789 + argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
1.790 + }
1.791 +
1.792 + /*
1.793 + * Copy the string conversions of each (post option) object into the
1.794 + * argument vector.
1.795 + */
1.796 +
1.797 + for (i = 0; i < argc; i++) {
1.798 + argv[i] = Tcl_GetString(objv[i + skip]);
1.799 + }
1.800 + argv[argc] = NULL;
1.801 + chan = Tcl_OpenCommandChannel(interp, argc, argv,
1.802 + (background ? 0 : TCL_STDOUT | TCL_STDERR));
1.803 +
1.804 + /*
1.805 + * Free the argv array if malloc'ed storage was used.
1.806 + */
1.807 +
1.808 + if (argv != argStorage) {
1.809 + ckfree((char *)argv);
1.810 + }
1.811 +
1.812 + if (chan == (Tcl_Channel) NULL) {
1.813 + return TCL_ERROR;
1.814 + }
1.815 +
1.816 + if (background) {
1.817 + /*
1.818 + * Store the list of PIDs from the pipeline in interp's result and
1.819 + * detach the PIDs (instead of waiting for them).
1.820 + */
1.821 +
1.822 + TclGetAndDetachPids(interp, chan);
1.823 + if (Tcl_Close(interp, chan) != TCL_OK) {
1.824 + return TCL_ERROR;
1.825 + }
1.826 + return TCL_OK;
1.827 + }
1.828 +
1.829 + resultPtr = Tcl_NewObj();
1.830 + if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
1.831 + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
1.832 + Tcl_ResetResult(interp);
1.833 + Tcl_AppendResult(interp, "error reading output from command: ",
1.834 + Tcl_PosixError(interp), (char *) NULL);
1.835 + Tcl_DecrRefCount(resultPtr);
1.836 + return TCL_ERROR;
1.837 + }
1.838 + }
1.839 + /*
1.840 + * If the process produced anything on stderr, it will have been
1.841 + * returned in the interpreter result. It needs to be appended to
1.842 + * the result string.
1.843 + */
1.844 +
1.845 + result = Tcl_Close(interp, chan);
1.846 + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
1.847 + Tcl_AppendToObj(resultPtr, string, length);
1.848 +
1.849 + /*
1.850 + * If the last character of the result is a newline, then remove
1.851 + * the newline character.
1.852 + */
1.853 +
1.854 + if (keepNewline == 0) {
1.855 + string = Tcl_GetStringFromObj(resultPtr, &length);
1.856 + if ((length > 0) && (string[length - 1] == '\n')) {
1.857 + Tcl_SetObjLength(resultPtr, length - 1);
1.858 + }
1.859 + }
1.860 + Tcl_SetObjResult(interp, resultPtr);
1.861 +
1.862 + return result;
1.863 +#endif /* !MAC_TCL */
1.864 +}
1.865 +
1.866 +/*
1.867 + *---------------------------------------------------------------------------
1.868 + *
1.869 + * Tcl_FblockedObjCmd --
1.870 + *
1.871 + * This procedure is invoked to process the Tcl "fblocked" command.
1.872 + * See the user documentation for details on what it does.
1.873 + *
1.874 + * Results:
1.875 + * A standard Tcl result.
1.876 + *
1.877 + * Side effects:
1.878 + * Sets interp's result to boolean true or false depending on whether
1.879 + * the preceeding input operation on the channel would have blocked.
1.880 + *
1.881 + *---------------------------------------------------------------------------
1.882 + */
1.883 +
1.884 + /* ARGSUSED */
1.885 +int
1.886 +Tcl_FblockedObjCmd(unused, interp, objc, objv)
1.887 + ClientData unused; /* Not used. */
1.888 + Tcl_Interp *interp; /* Current interpreter. */
1.889 + int objc; /* Number of arguments. */
1.890 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.891 +{
1.892 + Tcl_Channel chan;
1.893 + int mode;
1.894 + char *arg;
1.895 +
1.896 + if (objc != 2) {
1.897 + Tcl_WrongNumArgs(interp, 1, objv, "channelId");
1.898 + return TCL_ERROR;
1.899 + }
1.900 +
1.901 + arg = Tcl_GetString(objv[1]);
1.902 + chan = Tcl_GetChannel(interp, arg, &mode);
1.903 + if (chan == NULL) {
1.904 + return TCL_ERROR;
1.905 + }
1.906 + if ((mode & TCL_READABLE) == 0) {
1.907 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
1.908 + arg, "\" wasn't opened for reading", (char *) NULL);
1.909 + return TCL_ERROR;
1.910 + }
1.911 +
1.912 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan));
1.913 + return TCL_OK;
1.914 +}
1.915 +
1.916 +/*
1.917 + *----------------------------------------------------------------------
1.918 + *
1.919 + * Tcl_OpenObjCmd --
1.920 + *
1.921 + * This procedure is invoked to process the "open" Tcl command.
1.922 + * See the user documentation for details on what it does.
1.923 + *
1.924 + * Results:
1.925 + * A standard Tcl result.
1.926 + *
1.927 + * Side effects:
1.928 + * See the user documentation.
1.929 + *
1.930 + *----------------------------------------------------------------------
1.931 + */
1.932 +
1.933 + /* ARGSUSED */
1.934 +int
1.935 +Tcl_OpenObjCmd(notUsed, interp, objc, objv)
1.936 + ClientData notUsed; /* Not used. */
1.937 + Tcl_Interp *interp; /* Current interpreter. */
1.938 + int objc; /* Number of arguments. */
1.939 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.940 +{
1.941 + int pipeline, prot;
1.942 + char *modeString, *what;
1.943 + Tcl_Channel chan;
1.944 +
1.945 + if ((objc < 2) || (objc > 4)) {
1.946 + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
1.947 + return TCL_ERROR;
1.948 + }
1.949 + prot = 0666;
1.950 + if (objc == 2) {
1.951 + modeString = "r";
1.952 + } else {
1.953 + modeString = Tcl_GetString(objv[2]);
1.954 + if (objc == 4) {
1.955 + if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
1.956 + return TCL_ERROR;
1.957 + }
1.958 + }
1.959 + }
1.960 +
1.961 + pipeline = 0;
1.962 + what = Tcl_GetString(objv[1]);
1.963 + if (what[0] == '|') {
1.964 + pipeline = 1;
1.965 + }
1.966 +
1.967 + /*
1.968 + * Open the file or create a process pipeline.
1.969 + */
1.970 +
1.971 + if (!pipeline) {
1.972 + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
1.973 + } else {
1.974 +#ifdef MAC_TCL
1.975 + Tcl_AppendResult(interp,
1.976 + "command pipelines not supported on Macintosh OS",
1.977 + (char *)NULL);
1.978 + return TCL_ERROR;
1.979 +#else
1.980 + int mode, seekFlag, cmdObjc;
1.981 + CONST char **cmdArgv;
1.982 +
1.983 + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
1.984 + return TCL_ERROR;
1.985 + }
1.986 +
1.987 + mode = TclGetOpenMode(interp, modeString, &seekFlag);
1.988 + if (mode == -1) {
1.989 + chan = NULL;
1.990 + } else {
1.991 + int flags = TCL_STDERR | TCL_ENFORCE_MODE;
1.992 + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
1.993 + case O_RDONLY:
1.994 + flags |= TCL_STDOUT;
1.995 + break;
1.996 + case O_WRONLY:
1.997 + flags |= TCL_STDIN;
1.998 + break;
1.999 + case O_RDWR:
1.1000 + flags |= (TCL_STDIN | TCL_STDOUT);
1.1001 + break;
1.1002 + default:
1.1003 + panic("Tcl_OpenCmd: invalid mode value");
1.1004 + break;
1.1005 + }
1.1006 + chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
1.1007 + }
1.1008 + ckfree((char *) cmdArgv);
1.1009 +#endif
1.1010 + }
1.1011 + if (chan == (Tcl_Channel) NULL) {
1.1012 + return TCL_ERROR;
1.1013 + }
1.1014 + Tcl_RegisterChannel(interp, chan);
1.1015 + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
1.1016 + return TCL_OK;
1.1017 +}
1.1018 +
1.1019 +/*
1.1020 + *----------------------------------------------------------------------
1.1021 + *
1.1022 + * TcpAcceptCallbacksDeleteProc --
1.1023 + *
1.1024 + * Assocdata cleanup routine called when an interpreter is being
1.1025 + * deleted to set the interp field of all the accept callback records
1.1026 + * registered with the interpreter to NULL. This will prevent the
1.1027 + * interpreter from being used in the future to eval accept scripts.
1.1028 + *
1.1029 + * Results:
1.1030 + * None.
1.1031 + *
1.1032 + * Side effects:
1.1033 + * Deallocates memory and sets the interp field of all the accept
1.1034 + * callback records to NULL to prevent this interpreter from being
1.1035 + * used subsequently to eval accept scripts.
1.1036 + *
1.1037 + *----------------------------------------------------------------------
1.1038 + */
1.1039 +
1.1040 + /* ARGSUSED */
1.1041 +static void
1.1042 +TcpAcceptCallbacksDeleteProc(clientData, interp)
1.1043 + ClientData clientData; /* Data which was passed when the assocdata
1.1044 + * was registered. */
1.1045 + Tcl_Interp *interp; /* Interpreter being deleted - not used. */
1.1046 +{
1.1047 + Tcl_HashTable *hTblPtr;
1.1048 + Tcl_HashEntry *hPtr;
1.1049 + Tcl_HashSearch hSearch;
1.1050 + AcceptCallback *acceptCallbackPtr;
1.1051 +
1.1052 + hTblPtr = (Tcl_HashTable *) clientData;
1.1053 + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
1.1054 + hPtr != (Tcl_HashEntry *) NULL;
1.1055 + hPtr = Tcl_NextHashEntry(&hSearch)) {
1.1056 + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
1.1057 + acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
1.1058 + }
1.1059 + Tcl_DeleteHashTable(hTblPtr);
1.1060 + ckfree((char *) hTblPtr);
1.1061 +}
1.1062 +
1.1063 +/*
1.1064 + *----------------------------------------------------------------------
1.1065 + *
1.1066 + * RegisterTcpServerInterpCleanup --
1.1067 + *
1.1068 + * Registers an accept callback record to have its interp
1.1069 + * field set to NULL when the interpreter is deleted.
1.1070 + *
1.1071 + * Results:
1.1072 + * None.
1.1073 + *
1.1074 + * Side effects:
1.1075 + * When, in the future, the interpreter is deleted, the interp
1.1076 + * field of the accept callback data structure will be set to
1.1077 + * NULL. This will prevent attempts to eval the accept script
1.1078 + * in a deleted interpreter.
1.1079 + *
1.1080 + *----------------------------------------------------------------------
1.1081 + */
1.1082 +
1.1083 +static void
1.1084 +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
1.1085 + Tcl_Interp *interp; /* Interpreter for which we want to be
1.1086 + * informed of deletion. */
1.1087 + AcceptCallback *acceptCallbackPtr;
1.1088 + /* The accept callback record whose
1.1089 + * interp field we want set to NULL when
1.1090 + * the interpreter is deleted. */
1.1091 +{
1.1092 + Tcl_HashTable *hTblPtr; /* Hash table for accept callback
1.1093 + * records to smash when the interpreter
1.1094 + * will be deleted. */
1.1095 + Tcl_HashEntry *hPtr; /* Entry for this record. */
1.1096 + int new; /* Is the entry new? */
1.1097 +
1.1098 + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
1.1099 + "tclTCPAcceptCallbacks",
1.1100 + NULL);
1.1101 + if (hTblPtr == (Tcl_HashTable *) NULL) {
1.1102 + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
1.1103 + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
1.1104 + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
1.1105 + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
1.1106 + }
1.1107 + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
1.1108 + if (!new) {
1.1109 + panic("RegisterTcpServerCleanup: damaged accept record table");
1.1110 + }
1.1111 + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
1.1112 +}
1.1113 +
1.1114 +/*
1.1115 + *----------------------------------------------------------------------
1.1116 + *
1.1117 + * UnregisterTcpServerInterpCleanupProc --
1.1118 + *
1.1119 + * Unregister a previously registered accept callback record. The
1.1120 + * interp field of this record will no longer be set to NULL in
1.1121 + * the future when the interpreter is deleted.
1.1122 + *
1.1123 + * Results:
1.1124 + * None.
1.1125 + *
1.1126 + * Side effects:
1.1127 + * Prevents the interp field of the accept callback record from
1.1128 + * being set to NULL in the future when the interpreter is deleted.
1.1129 + *
1.1130 + *----------------------------------------------------------------------
1.1131 + */
1.1132 +
1.1133 +static void
1.1134 +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
1.1135 + Tcl_Interp *interp; /* Interpreter in which the accept callback
1.1136 + * record was registered. */
1.1137 + AcceptCallback *acceptCallbackPtr;
1.1138 + /* The record for which to delete the
1.1139 + * registration. */
1.1140 +{
1.1141 + Tcl_HashTable *hTblPtr;
1.1142 + Tcl_HashEntry *hPtr;
1.1143 +
1.1144 + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
1.1145 + "tclTCPAcceptCallbacks", NULL);
1.1146 + if (hTblPtr == (Tcl_HashTable *) NULL) {
1.1147 + return;
1.1148 + }
1.1149 + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
1.1150 + if (hPtr == (Tcl_HashEntry *) NULL) {
1.1151 + return;
1.1152 + }
1.1153 + Tcl_DeleteHashEntry(hPtr);
1.1154 +}
1.1155 +
1.1156 +/*
1.1157 + *----------------------------------------------------------------------
1.1158 + *
1.1159 + * AcceptCallbackProc --
1.1160 + *
1.1161 + * This callback is invoked by the TCP channel driver when it
1.1162 + * accepts a new connection from a client on a server socket.
1.1163 + *
1.1164 + * Results:
1.1165 + * None.
1.1166 + *
1.1167 + * Side effects:
1.1168 + * Whatever the script does.
1.1169 + *
1.1170 + *----------------------------------------------------------------------
1.1171 + */
1.1172 +
1.1173 +static void
1.1174 +AcceptCallbackProc(callbackData, chan, address, port)
1.1175 + ClientData callbackData; /* The data stored when the callback
1.1176 + * was created in the call to
1.1177 + * Tcl_OpenTcpServer. */
1.1178 + Tcl_Channel chan; /* Channel for the newly accepted
1.1179 + * connection. */
1.1180 + char *address; /* Address of client that was
1.1181 + * accepted. */
1.1182 + int port; /* Port of client that was accepted. */
1.1183 +{
1.1184 + AcceptCallback *acceptCallbackPtr;
1.1185 + Tcl_Interp *interp;
1.1186 + char *script;
1.1187 + char portBuf[TCL_INTEGER_SPACE];
1.1188 + int result;
1.1189 +
1.1190 + acceptCallbackPtr = (AcceptCallback *) callbackData;
1.1191 +
1.1192 + /*
1.1193 + * Check if the callback is still valid; the interpreter may have gone
1.1194 + * away, this is signalled by setting the interp field of the callback
1.1195 + * data to NULL.
1.1196 + */
1.1197 +
1.1198 + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
1.1199 +
1.1200 + script = acceptCallbackPtr->script;
1.1201 + interp = acceptCallbackPtr->interp;
1.1202 +
1.1203 + Tcl_Preserve((ClientData) script);
1.1204 + Tcl_Preserve((ClientData) interp);
1.1205 +
1.1206 + TclFormatInt(portBuf, port);
1.1207 + Tcl_RegisterChannel(interp, chan);
1.1208 +
1.1209 + /*
1.1210 + * Artificially bump the refcount to protect the channel from
1.1211 + * being deleted while the script is being evaluated.
1.1212 + */
1.1213 +
1.1214 + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
1.1215 +
1.1216 + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
1.1217 + " ", address, " ", portBuf, (char *) NULL);
1.1218 + if (result != TCL_OK) {
1.1219 + Tcl_BackgroundError(interp);
1.1220 + Tcl_UnregisterChannel(interp, chan);
1.1221 + }
1.1222 +
1.1223 + /*
1.1224 + * Decrement the artificially bumped refcount. After this it is
1.1225 + * not safe anymore to use "chan", because it may now be deleted.
1.1226 + */
1.1227 +
1.1228 + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
1.1229 +
1.1230 + Tcl_Release((ClientData) interp);
1.1231 + Tcl_Release((ClientData) script);
1.1232 + } else {
1.1233 +
1.1234 + /*
1.1235 + * The interpreter has been deleted, so there is no useful
1.1236 + * way to utilize the client socket - just close it.
1.1237 + */
1.1238 +
1.1239 + Tcl_Close((Tcl_Interp *) NULL, chan);
1.1240 + }
1.1241 +}
1.1242 +
1.1243 +/*
1.1244 + *----------------------------------------------------------------------
1.1245 + *
1.1246 + * TcpServerCloseProc --
1.1247 + *
1.1248 + * This callback is called when the TCP server channel for which it
1.1249 + * was registered is being closed. It informs the interpreter in
1.1250 + * which the accept script is evaluated (if that interpreter still
1.1251 + * exists) that this channel no longer needs to be informed if the
1.1252 + * interpreter is deleted.
1.1253 + *
1.1254 + * Results:
1.1255 + * None.
1.1256 + *
1.1257 + * Side effects:
1.1258 + * In the future, if the interpreter is deleted this channel will
1.1259 + * no longer be informed.
1.1260 + *
1.1261 + *----------------------------------------------------------------------
1.1262 + */
1.1263 +
1.1264 +static void
1.1265 +TcpServerCloseProc(callbackData)
1.1266 + ClientData callbackData; /* The data passed in the call to
1.1267 + * Tcl_CreateCloseHandler. */
1.1268 +{
1.1269 + AcceptCallback *acceptCallbackPtr;
1.1270 + /* The actual data. */
1.1271 +
1.1272 + acceptCallbackPtr = (AcceptCallback *) callbackData;
1.1273 + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
1.1274 + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
1.1275 + acceptCallbackPtr);
1.1276 + }
1.1277 + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
1.1278 + ckfree((char *) acceptCallbackPtr);
1.1279 +}
1.1280 +
1.1281 +/*
1.1282 + *----------------------------------------------------------------------
1.1283 + *
1.1284 + * Tcl_SocketObjCmd --
1.1285 + *
1.1286 + * This procedure is invoked to process the "socket" Tcl command.
1.1287 + * See the user documentation for details on what it does.
1.1288 + *
1.1289 + * Results:
1.1290 + * A standard Tcl result.
1.1291 + *
1.1292 + * Side effects:
1.1293 + * Creates a socket based channel.
1.1294 + *
1.1295 + *----------------------------------------------------------------------
1.1296 + */
1.1297 +
1.1298 +int
1.1299 +Tcl_SocketObjCmd(notUsed, interp, objc, objv)
1.1300 + ClientData notUsed; /* Not used. */
1.1301 + Tcl_Interp *interp; /* Current interpreter. */
1.1302 + int objc; /* Number of arguments. */
1.1303 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1304 +{
1.1305 + static CONST char *socketOptions[] = {
1.1306 + "-async", "-myaddr", "-myport","-server", (char *) NULL
1.1307 + };
1.1308 + enum socketOptions {
1.1309 + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
1.1310 + };
1.1311 + int optionIndex, a, server, port;
1.1312 + char *arg, *copyScript, *host, *script;
1.1313 + char *myaddr = NULL;
1.1314 + int myport = 0;
1.1315 + int async = 0;
1.1316 + Tcl_Channel chan;
1.1317 + AcceptCallback *acceptCallbackPtr;
1.1318 +
1.1319 + server = 0;
1.1320 + script = NULL;
1.1321 +
1.1322 + if (TclpHasSockets(interp) != TCL_OK) {
1.1323 + return TCL_ERROR;
1.1324 + }
1.1325 +
1.1326 + for (a = 1; a < objc; a++) {
1.1327 + arg = Tcl_GetString(objv[a]);
1.1328 + if (arg[0] != '-') {
1.1329 + break;
1.1330 + }
1.1331 + if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions,
1.1332 + "option", TCL_EXACT, &optionIndex) != TCL_OK) {
1.1333 + return TCL_ERROR;
1.1334 + }
1.1335 + switch ((enum socketOptions) optionIndex) {
1.1336 + case SKT_ASYNC: {
1.1337 + if (server == 1) {
1.1338 + Tcl_AppendResult(interp,
1.1339 + "cannot set -async option for server sockets",
1.1340 + (char *) NULL);
1.1341 + return TCL_ERROR;
1.1342 + }
1.1343 + async = 1;
1.1344 + break;
1.1345 + }
1.1346 + case SKT_MYADDR: {
1.1347 + a++;
1.1348 + if (a >= objc) {
1.1349 + Tcl_AppendResult(interp,
1.1350 + "no argument given for -myaddr option",
1.1351 + (char *) NULL);
1.1352 + return TCL_ERROR;
1.1353 + }
1.1354 + myaddr = Tcl_GetString(objv[a]);
1.1355 + break;
1.1356 + }
1.1357 + case SKT_MYPORT: {
1.1358 + char *myPortName;
1.1359 + a++;
1.1360 + if (a >= objc) {
1.1361 + Tcl_AppendResult(interp,
1.1362 + "no argument given for -myport option",
1.1363 + (char *) NULL);
1.1364 + return TCL_ERROR;
1.1365 + }
1.1366 + myPortName = Tcl_GetString(objv[a]);
1.1367 + if (TclSockGetPort(interp, myPortName, "tcp", &myport)
1.1368 + != TCL_OK) {
1.1369 + return TCL_ERROR;
1.1370 + }
1.1371 + break;
1.1372 + }
1.1373 + case SKT_SERVER: {
1.1374 + if (async == 1) {
1.1375 + Tcl_AppendResult(interp,
1.1376 + "cannot set -async option for server sockets",
1.1377 + (char *) NULL);
1.1378 + return TCL_ERROR;
1.1379 + }
1.1380 + server = 1;
1.1381 + a++;
1.1382 + if (a >= objc) {
1.1383 + Tcl_AppendResult(interp,
1.1384 + "no argument given for -server option",
1.1385 + (char *) NULL);
1.1386 + return TCL_ERROR;
1.1387 + }
1.1388 + script = Tcl_GetString(objv[a]);
1.1389 + break;
1.1390 + }
1.1391 + default: {
1.1392 + panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
1.1393 + }
1.1394 + }
1.1395 + }
1.1396 + if (server) {
1.1397 + host = myaddr; /* NULL implies INADDR_ANY */
1.1398 + if (myport != 0) {
1.1399 + Tcl_AppendResult(interp, "Option -myport is not valid for servers",
1.1400 + NULL);
1.1401 + return TCL_ERROR;
1.1402 + }
1.1403 + } else if (a < objc) {
1.1404 + host = Tcl_GetString(objv[a]);
1.1405 + a++;
1.1406 + } else {
1.1407 +wrongNumArgs:
1.1408 + Tcl_AppendResult(interp, "wrong # args: should be either:\n",
1.1409 + Tcl_GetString(objv[0]),
1.1410 + " ?-myaddr addr? ?-myport myport? ?-async? host port\n",
1.1411 + Tcl_GetString(objv[0]),
1.1412 + " -server command ?-myaddr addr? port",
1.1413 + (char *) NULL);
1.1414 + return TCL_ERROR;
1.1415 + }
1.1416 +
1.1417 + if (a == objc-1) {
1.1418 + if (TclSockGetPort(interp, Tcl_GetString(objv[a]),
1.1419 + "tcp", &port) != TCL_OK) {
1.1420 + return TCL_ERROR;
1.1421 + }
1.1422 + } else {
1.1423 + goto wrongNumArgs;
1.1424 + }
1.1425 +
1.1426 + if (server) {
1.1427 + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
1.1428 + sizeof(AcceptCallback));
1.1429 + copyScript = ckalloc((unsigned) strlen(script) + 1);
1.1430 + strcpy(copyScript, script);
1.1431 + acceptCallbackPtr->script = copyScript;
1.1432 + acceptCallbackPtr->interp = interp;
1.1433 + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
1.1434 + (ClientData) acceptCallbackPtr);
1.1435 + if (chan == (Tcl_Channel) NULL) {
1.1436 + ckfree(copyScript);
1.1437 + ckfree((char *) acceptCallbackPtr);
1.1438 + return TCL_ERROR;
1.1439 + }
1.1440 +
1.1441 + /*
1.1442 + * Register with the interpreter to let us know when the
1.1443 + * interpreter is deleted (by having the callback set the
1.1444 + * acceptCallbackPtr->interp field to NULL). This is to
1.1445 + * avoid trying to eval the script in a deleted interpreter.
1.1446 + */
1.1447 +
1.1448 + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
1.1449 +
1.1450 + /*
1.1451 + * Register a close callback. This callback will inform the
1.1452 + * interpreter (if it still exists) that this channel does not
1.1453 + * need to be informed when the interpreter is deleted.
1.1454 + */
1.1455 +
1.1456 + Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
1.1457 + (ClientData) acceptCallbackPtr);
1.1458 + } else {
1.1459 + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
1.1460 + if (chan == (Tcl_Channel) NULL) {
1.1461 + return TCL_ERROR;
1.1462 + }
1.1463 + }
1.1464 + Tcl_RegisterChannel(interp, chan);
1.1465 + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
1.1466 +
1.1467 + return TCL_OK;
1.1468 +}
1.1469 +
1.1470 +/*
1.1471 + *----------------------------------------------------------------------
1.1472 + *
1.1473 + * Tcl_FcopyObjCmd --
1.1474 + *
1.1475 + * This procedure is invoked to process the "fcopy" Tcl command.
1.1476 + * See the user documentation for details on what it does.
1.1477 + *
1.1478 + * Results:
1.1479 + * A standard Tcl result.
1.1480 + *
1.1481 + * Side effects:
1.1482 + * Moves data between two channels and possibly sets up a
1.1483 + * background copy handler.
1.1484 + *
1.1485 + *----------------------------------------------------------------------
1.1486 + */
1.1487 +
1.1488 +int
1.1489 +Tcl_FcopyObjCmd(dummy, interp, objc, objv)
1.1490 + ClientData dummy; /* Not used. */
1.1491 + Tcl_Interp *interp; /* Current interpreter. */
1.1492 + int objc; /* Number of arguments. */
1.1493 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1494 +{
1.1495 + Tcl_Channel inChan, outChan;
1.1496 + char *arg;
1.1497 + int mode, i;
1.1498 + int toRead, index;
1.1499 + Tcl_Obj *cmdPtr;
1.1500 + static CONST char* switches[] = { "-size", "-command", NULL };
1.1501 + enum { FcopySize, FcopyCommand };
1.1502 +
1.1503 + if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
1.1504 + Tcl_WrongNumArgs(interp, 1, objv,
1.1505 + "input output ?-size size? ?-command callback?");
1.1506 + return TCL_ERROR;
1.1507 + }
1.1508 +
1.1509 + /*
1.1510 + * Parse the channel arguments and verify that they are readable
1.1511 + * or writable, as appropriate.
1.1512 + */
1.1513 +
1.1514 + arg = Tcl_GetString(objv[1]);
1.1515 + inChan = Tcl_GetChannel(interp, arg, &mode);
1.1516 + if (inChan == (Tcl_Channel) NULL) {
1.1517 + return TCL_ERROR;
1.1518 + }
1.1519 + if ((mode & TCL_READABLE) == 0) {
1.1520 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
1.1521 + arg,
1.1522 + "\" wasn't opened for reading", (char *) NULL);
1.1523 + return TCL_ERROR;
1.1524 + }
1.1525 + arg = Tcl_GetString(objv[2]);
1.1526 + outChan = Tcl_GetChannel(interp, arg, &mode);
1.1527 + if (outChan == (Tcl_Channel) NULL) {
1.1528 + return TCL_ERROR;
1.1529 + }
1.1530 + if ((mode & TCL_WRITABLE) == 0) {
1.1531 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
1.1532 + arg,
1.1533 + "\" wasn't opened for writing", (char *) NULL);
1.1534 + return TCL_ERROR;
1.1535 + }
1.1536 +
1.1537 + toRead = -1;
1.1538 + cmdPtr = NULL;
1.1539 + for (i = 3; i < objc; i += 2) {
1.1540 + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
1.1541 + (int *) &index) != TCL_OK) {
1.1542 + return TCL_ERROR;
1.1543 + }
1.1544 + switch (index) {
1.1545 + case FcopySize:
1.1546 + if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
1.1547 + return TCL_ERROR;
1.1548 + }
1.1549 + break;
1.1550 + case FcopyCommand:
1.1551 + cmdPtr = objv[i+1];
1.1552 + break;
1.1553 + }
1.1554 + }
1.1555 +
1.1556 + return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
1.1557 +}