os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclUnixTest.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclUnixTest.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,777 @@
1.4 +/*
1.5 + * tclUnixTest.c --
1.6 + *
1.7 + * Contains platform specific test commands for the Unix platform.
1.8 + *
1.9 + * Copyright (c) 1996-1997 Sun Microsystems, Inc.
1.10 + * Copyright (c) 1998 by Scriptics Corporation.
1.11 + * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.12 + *
1.13 + * See the file "license.terms" for information on usage and redistribution
1.14 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 + *
1.16 + * RCS: @(#) $Id: tclUnixTest.c,v 1.14.2.2 2006/03/19 22:47:30 vincentdarley Exp $
1.17 + */
1.18 +
1.19 +#include "tclInt.h"
1.20 +#include "tclPort.h"
1.21 +#if defined(__SYMBIAN32__)
1.22 +#include "tclSymbianGlobals.h"
1.23 +#endif
1.24 +
1.25 +/*
1.26 + * The headers are needed for the testalarm command that verifies the
1.27 + * use of SA_RESTART in signal handlers.
1.28 + */
1.29 +
1.30 +#ifndef __SYMBIAN32__
1.31 +#include <signal.h>
1.32 +#endif
1.33 +#include <sys/resource.h>
1.34 +
1.35 +/*
1.36 + * The following macros convert between TclFile's and fd's. The conversion
1.37 + * simple involves shifting fd's up by one to ensure that no valid fd is ever
1.38 + * the same as NULL. Note that this code is duplicated from tclUnixPipe.c
1.39 + */
1.40 +
1.41 +#define MakeFile(fd) ((TclFile)((fd)+1))
1.42 +#define GetFd(file) (((int)file)-1)
1.43 +
1.44 +/*
1.45 + * The stuff below is used to keep track of file handlers created and
1.46 + * exercised by the "testfilehandler" command.
1.47 + */
1.48 +
1.49 +typedef struct Pipe {
1.50 + TclFile readFile; /* File handle for reading from the
1.51 + * pipe. NULL means pipe doesn't exist yet. */
1.52 + TclFile writeFile; /* File handle for writing from the
1.53 + * pipe. */
1.54 + int readCount; /* Number of times the file handler for
1.55 + * this file has triggered and the file
1.56 + * was readable. */
1.57 + int writeCount; /* Number of times the file handler for
1.58 + * this file has triggered and the file
1.59 + * was writable. */
1.60 +} Pipe;
1.61 +
1.62 +#define MAX_PIPES 10
1.63 +static Pipe testPipes[MAX_PIPES];
1.64 +
1.65 +/*
1.66 + * The stuff below is used by the testalarm and testgotsig ommands.
1.67 + */
1.68 +
1.69 +static char *gotsig = "0";
1.70 +
1.71 +/*
1.72 + * Forward declarations of procedures defined later in this file:
1.73 + */
1.74 +
1.75 +static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
1.76 + int mask));
1.77 +static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
1.78 + Tcl_Interp *interp, int argc, CONST char **argv));
1.79 +static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
1.80 + Tcl_Interp *interp, int argc, CONST char **argv));
1.81 +static int TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
1.82 + Tcl_Interp *interp, int argc, CONST char **argv));
1.83 +static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
1.84 + Tcl_Interp *interp, int argc, CONST char **argv));
1.85 +static int TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
1.86 + Tcl_Interp *interp, int argc, CONST char **argv));
1.87 +static int TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
1.88 + Tcl_Interp *interp, int argc, CONST char **argv));
1.89 +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
1.90 +static int TestalarmCmd _ANSI_ARGS_((ClientData dummy,
1.91 + Tcl_Interp *interp, int argc, CONST char **argv));
1.92 +static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
1.93 + Tcl_Interp *interp, int argc, CONST char **argv));
1.94 +static void AlarmHandler _ANSI_ARGS_(());
1.95 +static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
1.96 + Tcl_Interp *interp, int argc, CONST char **argv));
1.97 +
1.98 +/*
1.99 + *----------------------------------------------------------------------
1.100 + *
1.101 + * TclplatformtestInit --
1.102 + *
1.103 + * Defines commands that test platform specific functionality for
1.104 + * Unix platforms.
1.105 + *
1.106 + * Results:
1.107 + * A standard Tcl result.
1.108 + *
1.109 + * Side effects:
1.110 + * Defines new commands.
1.111 + *
1.112 + *----------------------------------------------------------------------
1.113 + */
1.114 +
1.115 +int
1.116 +TclplatformtestInit(interp)
1.117 + Tcl_Interp *interp; /* Interpreter to add commands to. */
1.118 +{
1.119 + Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
1.120 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.121 + Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
1.122 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.123 + Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
1.124 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.125 + Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
1.126 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.127 + Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
1.128 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.129 + Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
1.130 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.131 + Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd,
1.132 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.133 +#ifndef __SYMBIAN32__
1.134 + // Symbian and PIPS don't support signals.
1.135 + Tcl_CreateCommand(interp, "testalarm", TestalarmCmd,
1.136 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.137 +#endif
1.138 + Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
1.139 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.140 + return TCL_OK;
1.141 +}
1.142 +
1.143 +/*
1.144 + *----------------------------------------------------------------------
1.145 + *
1.146 + * TestfilehandlerCmd --
1.147 + *
1.148 + * This procedure implements the "testfilehandler" command. It is
1.149 + * used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and
1.150 + * TclWaitForFile.
1.151 + *
1.152 + * Results:
1.153 + * A standard Tcl result.
1.154 + *
1.155 + * Side effects:
1.156 + * None.
1.157 + *
1.158 + *----------------------------------------------------------------------
1.159 + */
1.160 +
1.161 +static int
1.162 +TestfilehandlerCmd(clientData, interp, argc, argv)
1.163 + ClientData clientData; /* Not used. */
1.164 + Tcl_Interp *interp; /* Current interpreter. */
1.165 + int argc; /* Number of arguments. */
1.166 + CONST char **argv; /* Argument strings. */
1.167 +{
1.168 + Pipe *pipePtr;
1.169 + int i, mask, timeout;
1.170 + static int initialized = 0;
1.171 + char buffer[4000];
1.172 + TclFile file;
1.173 +
1.174 + /*
1.175 + * NOTE: When we make this code work on Windows also, the following
1.176 + * variable needs to be made Unix-only.
1.177 + */
1.178 +
1.179 + if (!initialized) {
1.180 + for (i = 0; i < MAX_PIPES; i++) {
1.181 + testPipes[i].readFile = NULL;
1.182 + }
1.183 + initialized = 1;
1.184 + }
1.185 +
1.186 + if (argc < 2) {
1.187 + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
1.188 + " option ... \"", (char *) NULL);
1.189 + return TCL_ERROR;
1.190 + }
1.191 + pipePtr = NULL;
1.192 + if (argc >= 3) {
1.193 + if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) {
1.194 + return TCL_ERROR;
1.195 + }
1.196 + if (i >= MAX_PIPES) {
1.197 + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL);
1.198 + return TCL_ERROR;
1.199 + }
1.200 + pipePtr = &testPipes[i];
1.201 + }
1.202 +
1.203 + if (strcmp(argv[1], "close") == 0) {
1.204 + for (i = 0; i < MAX_PIPES; i++) {
1.205 + if (testPipes[i].readFile != NULL) {
1.206 + TclpCloseFile(testPipes[i].readFile);
1.207 + testPipes[i].readFile = NULL;
1.208 + TclpCloseFile(testPipes[i].writeFile);
1.209 + testPipes[i].writeFile = NULL;
1.210 + }
1.211 + }
1.212 + } else if (strcmp(argv[1], "clear") == 0) {
1.213 + if (argc != 3) {
1.214 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.215 + argv[0], " clear index\"", (char *) NULL);
1.216 + return TCL_ERROR;
1.217 + }
1.218 + pipePtr->readCount = pipePtr->writeCount = 0;
1.219 + } else if (strcmp(argv[1], "counts") == 0) {
1.220 + char buf[TCL_INTEGER_SPACE * 2];
1.221 +
1.222 + if (argc != 3) {
1.223 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.224 + argv[0], " counts index\"", (char *) NULL);
1.225 + return TCL_ERROR;
1.226 + }
1.227 + sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
1.228 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.229 + } else if (strcmp(argv[1], "create") == 0) {
1.230 + if (argc != 5) {
1.231 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.232 + argv[0], " create index readMode writeMode\"",
1.233 + (char *) NULL);
1.234 + return TCL_ERROR;
1.235 + }
1.236 + if (pipePtr->readFile == NULL) {
1.237 + if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
1.238 + Tcl_AppendResult(interp, "couldn't open pipe: ",
1.239 + Tcl_PosixError(interp), (char *) NULL);
1.240 + return TCL_ERROR;
1.241 + }
1.242 +#ifdef O_NONBLOCK
1.243 + fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
1.244 + fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
1.245 +#else
1.246 + Tcl_SetResult(interp, "can't make pipes non-blocking",
1.247 + TCL_STATIC);
1.248 + return TCL_ERROR;
1.249 +#endif
1.250 + }
1.251 + pipePtr->readCount = 0;
1.252 + pipePtr->writeCount = 0;
1.253 +
1.254 + if (strcmp(argv[3], "readable") == 0) {
1.255 + Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
1.256 + TestFileHandlerProc, (ClientData) pipePtr);
1.257 + } else if (strcmp(argv[3], "off") == 0) {
1.258 + Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
1.259 + } else if (strcmp(argv[3], "disabled") == 0) {
1.260 + Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
1.261 + TestFileHandlerProc, (ClientData) pipePtr);
1.262 + } else {
1.263 + Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"",
1.264 + (char *) NULL);
1.265 + return TCL_ERROR;
1.266 + }
1.267 + if (strcmp(argv[4], "writable") == 0) {
1.268 + Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
1.269 + TestFileHandlerProc, (ClientData) pipePtr);
1.270 + } else if (strcmp(argv[4], "off") == 0) {
1.271 + Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
1.272 + } else if (strcmp(argv[4], "disabled") == 0) {
1.273 + Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
1.274 + TestFileHandlerProc, (ClientData) pipePtr);
1.275 + } else {
1.276 + Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"",
1.277 + (char *) NULL);
1.278 + return TCL_ERROR;
1.279 + }
1.280 + } else if (strcmp(argv[1], "empty") == 0) {
1.281 + if (argc != 3) {
1.282 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.283 + argv[0], " empty index\"", (char *) NULL);
1.284 + return TCL_ERROR;
1.285 + }
1.286 +
1.287 + while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
1.288 + /* Empty loop body. */
1.289 + }
1.290 + } else if (strcmp(argv[1], "fill") == 0) {
1.291 + if (argc != 3) {
1.292 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.293 + argv[0], " fill index\"", (char *) NULL);
1.294 + return TCL_ERROR;
1.295 + }
1.296 +
1.297 + memset((VOID *) buffer, 'a', 4000);
1.298 + while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
1.299 + /* Empty loop body. */
1.300 + }
1.301 + } else if (strcmp(argv[1], "fillpartial") == 0) {
1.302 + char buf[TCL_INTEGER_SPACE];
1.303 +
1.304 + if (argc != 3) {
1.305 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.306 + argv[0], " fillpartial index\"", (char *) NULL);
1.307 + return TCL_ERROR;
1.308 + }
1.309 +
1.310 + memset((VOID *) buffer, 'b', 10);
1.311 + TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
1.312 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.313 + } else if (strcmp(argv[1], "oneevent") == 0) {
1.314 + Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
1.315 + } else if (strcmp(argv[1], "wait") == 0) {
1.316 + if (argc != 5) {
1.317 + Tcl_AppendResult(interp, "wrong # arguments: should be \"",
1.318 + argv[0], " wait index readable|writable timeout\"",
1.319 + (char *) NULL);
1.320 + return TCL_ERROR;
1.321 + }
1.322 + if (pipePtr->readFile == NULL) {
1.323 + Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
1.324 + (char *) NULL);
1.325 + return TCL_ERROR;
1.326 + }
1.327 + if (strcmp(argv[3], "readable") == 0) {
1.328 + mask = TCL_READABLE;
1.329 + file = pipePtr->readFile;
1.330 + } else {
1.331 + mask = TCL_WRITABLE;
1.332 + file = pipePtr->writeFile;
1.333 + }
1.334 + if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) {
1.335 + return TCL_ERROR;
1.336 + }
1.337 + i = TclUnixWaitForFile(GetFd(file), mask, timeout);
1.338 + if (i & TCL_READABLE) {
1.339 + Tcl_AppendElement(interp, "readable");
1.340 + }
1.341 + if (i & TCL_WRITABLE) {
1.342 + Tcl_AppendElement(interp, "writable");
1.343 + }
1.344 + } else if (strcmp(argv[1], "windowevent") == 0) {
1.345 + Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
1.346 + } else {
1.347 + Tcl_AppendResult(interp, "bad option \"", argv[1],
1.348 + "\": must be close, clear, counts, create, empty, fill, ",
1.349 + "fillpartial, oneevent, wait, or windowevent",
1.350 + (char *) NULL);
1.351 + return TCL_ERROR;
1.352 + }
1.353 + return TCL_OK;
1.354 +}
1.355 +
1.356 +static void TestFileHandlerProc(clientData, mask)
1.357 + ClientData clientData; /* Points to a Pipe structure. */
1.358 + int mask; /* Indicates which events happened:
1.359 + * TCL_READABLE or TCL_WRITABLE. */
1.360 +{
1.361 + Pipe *pipePtr = (Pipe *) clientData;
1.362 +
1.363 + if (mask & TCL_READABLE) {
1.364 + pipePtr->readCount++;
1.365 + }
1.366 + if (mask & TCL_WRITABLE) {
1.367 + pipePtr->writeCount++;
1.368 + }
1.369 +}
1.370 +
1.371 +/*
1.372 + *----------------------------------------------------------------------
1.373 + *
1.374 + * TestfilewaitCmd --
1.375 + *
1.376 + * This procedure implements the "testfilewait" command. It is
1.377 + * used to test TclUnixWaitForFile.
1.378 + *
1.379 + * Results:
1.380 + * A standard Tcl result.
1.381 + *
1.382 + * Side effects:
1.383 + * None.
1.384 + *
1.385 + *----------------------------------------------------------------------
1.386 + */
1.387 +
1.388 +static int
1.389 +TestfilewaitCmd(clientData, interp, argc, argv)
1.390 + ClientData clientData; /* Not used. */
1.391 + Tcl_Interp *interp; /* Current interpreter. */
1.392 + int argc; /* Number of arguments. */
1.393 + CONST char **argv; /* Argument strings. */
1.394 +{
1.395 + int mask, result, timeout;
1.396 + Tcl_Channel channel;
1.397 + int fd;
1.398 + ClientData data;
1.399 +
1.400 + if (argc != 4) {
1.401 + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
1.402 + " file readable|writable|both timeout\"", (char *) NULL);
1.403 + return TCL_ERROR;
1.404 + }
1.405 + channel = Tcl_GetChannel(interp, argv[1], NULL);
1.406 + if (channel == NULL) {
1.407 + return TCL_ERROR;
1.408 + }
1.409 + if (strcmp(argv[2], "readable") == 0) {
1.410 + mask = TCL_READABLE;
1.411 + } else if (strcmp(argv[2], "writable") == 0){
1.412 + mask = TCL_WRITABLE;
1.413 + } else if (strcmp(argv[2], "both") == 0){
1.414 + mask = TCL_WRITABLE|TCL_READABLE;
1.415 + } else {
1.416 + Tcl_AppendResult(interp, "bad argument \"", argv[2],
1.417 + "\": must be readable, writable, or both", (char *) NULL);
1.418 + return TCL_ERROR;
1.419 + }
1.420 + if (Tcl_GetChannelHandle(channel,
1.421 + (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
1.422 + (ClientData*) &data) != TCL_OK) {
1.423 + Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
1.424 + return TCL_ERROR;
1.425 + }
1.426 + fd = (int) data;
1.427 + if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
1.428 + return TCL_ERROR;
1.429 + }
1.430 + result = TclUnixWaitForFile(fd, mask, timeout);
1.431 + if (result & TCL_READABLE) {
1.432 + Tcl_AppendElement(interp, "readable");
1.433 + }
1.434 + if (result & TCL_WRITABLE) {
1.435 + Tcl_AppendElement(interp, "writable");
1.436 + }
1.437 + return TCL_OK;
1.438 +}
1.439 +
1.440 +/*
1.441 + *----------------------------------------------------------------------
1.442 + *
1.443 + * TestfindexecutableCmd --
1.444 + *
1.445 + * This procedure implements the "testfindexecutable" command. It is
1.446 + * used to test Tcl_FindExecutable.
1.447 + *
1.448 + * Results:
1.449 + * A standard Tcl result.
1.450 + *
1.451 + * Side effects:
1.452 + * None.
1.453 + *
1.454 + *----------------------------------------------------------------------
1.455 + */
1.456 +
1.457 +static int
1.458 +TestfindexecutableCmd(clientData, interp, argc, argv)
1.459 + ClientData clientData; /* Not used. */
1.460 + Tcl_Interp *interp; /* Current interpreter. */
1.461 + int argc; /* Number of arguments. */
1.462 + CONST char **argv; /* Argument strings. */
1.463 +{
1.464 + char *oldName;
1.465 + char *oldNativeName;
1.466 +
1.467 + if (argc != 2) {
1.468 + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
1.469 + " argv0\"", (char *) NULL);
1.470 + return TCL_ERROR;
1.471 + }
1.472 +
1.473 + oldName = tclExecutableName;
1.474 + oldNativeName = tclNativeExecutableName;
1.475 +
1.476 + tclExecutableName = NULL;
1.477 + tclNativeExecutableName = NULL;
1.478 +
1.479 + Tcl_FindExecutable(argv[1]);
1.480 + if (tclExecutableName != NULL) {
1.481 + Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
1.482 + ckfree(tclExecutableName);
1.483 + }
1.484 + if (tclNativeExecutableName != NULL) {
1.485 + ckfree(tclNativeExecutableName);
1.486 + }
1.487 +
1.488 + tclExecutableName = oldName;
1.489 + tclNativeExecutableName = oldNativeName;
1.490 +
1.491 + return TCL_OK;
1.492 +}
1.493 +
1.494 +/*
1.495 + *----------------------------------------------------------------------
1.496 + *
1.497 + * TestgetopenfileCmd --
1.498 + *
1.499 + * This procedure implements the "testgetopenfile" command. It is
1.500 + * used to get a FILE * value from a registered channel.
1.501 + *
1.502 + * Results:
1.503 + * A standard Tcl result.
1.504 + *
1.505 + * Side effects:
1.506 + * None.
1.507 + *
1.508 + *----------------------------------------------------------------------
1.509 + */
1.510 +
1.511 +static int
1.512 +TestgetopenfileCmd(clientData, interp, argc, argv)
1.513 + ClientData clientData; /* Not used. */
1.514 + Tcl_Interp *interp; /* Current interpreter. */
1.515 + int argc; /* Number of arguments. */
1.516 + CONST char **argv; /* Argument strings. */
1.517 +{
1.518 + ClientData filePtr;
1.519 +
1.520 + if (argc != 3) {
1.521 + Tcl_AppendResult(interp,
1.522 + "wrong # args: should be \"", argv[0],
1.523 + " channelName forWriting\"",
1.524 + (char *) NULL);
1.525 + return TCL_ERROR;
1.526 + }
1.527 + if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
1.528 + == TCL_ERROR) {
1.529 + return TCL_ERROR;
1.530 + }
1.531 + if (filePtr == (ClientData) NULL) {
1.532 + Tcl_AppendResult(interp,
1.533 + "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL);
1.534 + return TCL_ERROR;
1.535 + }
1.536 + return TCL_OK;
1.537 +}
1.538 +
1.539 +/*
1.540 + *----------------------------------------------------------------------
1.541 + *
1.542 + * TestsetdefencdirCmd --
1.543 + *
1.544 + * This procedure implements the "testsetdefenc" command. It is
1.545 + * used to set the value of tclDefaultEncodingDir.
1.546 + *
1.547 + * Results:
1.548 + * A standard Tcl result.
1.549 + *
1.550 + * Side effects:
1.551 + * None.
1.552 + *
1.553 + *----------------------------------------------------------------------
1.554 + */
1.555 +
1.556 +static int
1.557 +TestsetdefencdirCmd(clientData, interp, argc, argv)
1.558 + ClientData clientData; /* Not used. */
1.559 + Tcl_Interp *interp; /* Current interpreter. */
1.560 + int argc; /* Number of arguments. */
1.561 + CONST char **argv; /* Argument strings. */
1.562 +{
1.563 + if (argc != 2) {
1.564 + Tcl_AppendResult(interp,
1.565 + "wrong # args: should be \"", argv[0],
1.566 + " defaultDir\"",
1.567 + (char *) NULL);
1.568 + return TCL_ERROR;
1.569 + }
1.570 +
1.571 + if (tclDefaultEncodingDir != NULL) {
1.572 + ckfree(tclDefaultEncodingDir);
1.573 + tclDefaultEncodingDir = NULL;
1.574 + }
1.575 + if (*argv[1] != '\0') {
1.576 + tclDefaultEncodingDir = (char *)
1.577 + ckalloc((unsigned) strlen(argv[1]) + 1);
1.578 + strcpy(tclDefaultEncodingDir, argv[1]);
1.579 + }
1.580 + return TCL_OK;
1.581 +}
1.582 +
1.583 +/*
1.584 + *----------------------------------------------------------------------
1.585 + *
1.586 + * TestgetdefencdirCmd --
1.587 + *
1.588 + * This procedure implements the "testgetdefenc" command. It is
1.589 + * used to get the value of tclDefaultEncodingDir.
1.590 + *
1.591 + * Results:
1.592 + * A standard Tcl result.
1.593 + *
1.594 + * Side effects:
1.595 + * None.
1.596 + *
1.597 + *----------------------------------------------------------------------
1.598 + */
1.599 +
1.600 +static int
1.601 +TestgetdefencdirCmd(clientData, interp, argc, argv)
1.602 + ClientData clientData; /* Not used. */
1.603 + Tcl_Interp *interp; /* Current interpreter. */
1.604 + int argc; /* Number of arguments. */
1.605 + CONST char **argv; /* Argument strings. */
1.606 +{
1.607 + if (argc != 1) {
1.608 + Tcl_AppendResult(interp,
1.609 + "wrong # args: should be \"", argv[0],
1.610 + (char *) NULL);
1.611 + return TCL_ERROR;
1.612 + }
1.613 +
1.614 + if (tclDefaultEncodingDir != NULL) {
1.615 + Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL);
1.616 + }
1.617 + return TCL_OK;
1.618 +}
1.619 +
1.620 +/*
1.621 + *----------------------------------------------------------------------
1.622 + * TestalarmCmd --
1.623 + *
1.624 + * Test that EINTR is handled correctly by generating and
1.625 + * handling a signal. This requires using the SA_RESTART
1.626 + * flag when registering the signal handler.
1.627 + *
1.628 + * Results:
1.629 + * None.
1.630 + *
1.631 + * Side Effects:
1.632 + * Sets up an signal and async handlers.
1.633 + *
1.634 + *----------------------------------------------------------------------
1.635 + */
1.636 +
1.637 +static int
1.638 +TestalarmCmd(clientData, interp, argc, argv)
1.639 + ClientData clientData; /* Not used. */
1.640 + Tcl_Interp *interp; /* Current interpreter. */
1.641 + int argc; /* Number of arguments. */
1.642 + CONST char **argv; /* Argument strings. */
1.643 +{
1.644 +#ifdef SA_RESTART
1.645 + unsigned int sec;
1.646 + struct sigaction action;
1.647 +
1.648 + if (argc > 1) {
1.649 + Tcl_GetInt(interp, argv[1], (int *)&sec);
1.650 + } else {
1.651 + sec = 1;
1.652 + }
1.653 +
1.654 + /*
1.655 + * Setup the signal handling that automatically retries
1.656 + * any interupted I/O system calls.
1.657 + */
1.658 + action.sa_handler = AlarmHandler;
1.659 + memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
1.660 + action.sa_flags = SA_RESTART;
1.661 +
1.662 + if (sigaction(SIGALRM, &action, NULL) < 0) {
1.663 + Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
1.664 + return TCL_ERROR;
1.665 + }
1.666 + (void)alarm(sec);
1.667 + return TCL_OK;
1.668 +#else
1.669 + Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
1.670 + return TCL_ERROR;
1.671 +#endif
1.672 +}
1.673 +
1.674 +/*
1.675 + *----------------------------------------------------------------------
1.676 + *
1.677 + * AlarmHandler --
1.678 + *
1.679 + * Signal handler for the alarm command.
1.680 + *
1.681 + * Results:
1.682 + * None.
1.683 + *
1.684 + * Side effects:
1.685 + * Calls the Tcl Async handler.
1.686 + *
1.687 + *----------------------------------------------------------------------
1.688 + */
1.689 +
1.690 +static void
1.691 +AlarmHandler()
1.692 +{
1.693 + gotsig = "1";
1.694 +}
1.695 +
1.696 +/*
1.697 + *----------------------------------------------------------------------
1.698 + * TestgotsigCmd --
1.699 + *
1.700 + * Verify the signal was handled after the testalarm command.
1.701 + *
1.702 + * Results:
1.703 + * None.
1.704 + *
1.705 + * Side Effects:
1.706 + * Resets the value of gotsig back to '0'.
1.707 + *
1.708 + *----------------------------------------------------------------------
1.709 + */
1.710 +
1.711 +static int
1.712 +TestgotsigCmd(clientData, interp, argc, argv)
1.713 + ClientData clientData; /* Not used. */
1.714 + Tcl_Interp *interp; /* Current interpreter. */
1.715 + int argc; /* Number of arguments. */
1.716 + CONST char **argv; /* Argument strings. */
1.717 +{
1.718 + Tcl_AppendResult(interp, gotsig, (char *) NULL);
1.719 + gotsig = "0";
1.720 + return TCL_OK;
1.721 +}
1.722 +
1.723 +/*
1.724 + *---------------------------------------------------------------------------
1.725 + *
1.726 + * TestchmodCmd --
1.727 + *
1.728 + * Implements the "testchmod" cmd. Used when testing "file" command.
1.729 + * The only attribute used by the Windows platform is the user write
1.730 + * flag; if this is not set, the file is made read-only. Otehrwise, the
1.731 + * file is made read-write.
1.732 + *
1.733 + * Results:
1.734 + * A standard Tcl result.
1.735 + *
1.736 + * Side effects:
1.737 + * Changes permissions of specified files.
1.738 + *
1.739 + *---------------------------------------------------------------------------
1.740 + */
1.741 +
1.742 +static int
1.743 +TestchmodCmd(dummy, interp, argc, argv)
1.744 + ClientData dummy; /* Not used. */
1.745 + Tcl_Interp *interp; /* Current interpreter. */
1.746 + int argc; /* Number of arguments. */
1.747 + CONST char **argv; /* Argument strings. */
1.748 +{
1.749 + int i, mode;
1.750 + char *rest;
1.751 +
1.752 + if (argc < 2) {
1.753 + usage:
1.754 + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1.755 + " mode file ?file ...?", NULL);
1.756 + return TCL_ERROR;
1.757 + }
1.758 +
1.759 + mode = (int) strtol(argv[1], &rest, 8);
1.760 + if ((rest == argv[1]) || (*rest != '\0')) {
1.761 + goto usage;
1.762 + }
1.763 +
1.764 + for (i = 2; i < argc; i++) {
1.765 + Tcl_DString buffer;
1.766 + CONST char *translated;
1.767 +
1.768 + translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
1.769 + if (translated == NULL) {
1.770 + return TCL_ERROR;
1.771 + }
1.772 + if (chmod(translated, (unsigned) mode) != 0) {
1.773 + Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
1.774 + NULL);
1.775 + return TCL_ERROR;
1.776 + }
1.777 + Tcl_DStringFree(&buffer);
1.778 + }
1.779 + return TCL_OK;
1.780 +}