diff options
Diffstat (limited to 'tcl8.6/unix/tclUnixTest.c')
| -rw-r--r-- | tcl8.6/unix/tclUnixTest.c | 782 |
1 files changed, 0 insertions, 782 deletions
diff --git a/tcl8.6/unix/tclUnixTest.c b/tcl8.6/unix/tclUnixTest.c deleted file mode 100644 index c5ac52a..0000000 --- a/tcl8.6/unix/tclUnixTest.c +++ /dev/null @@ -1,782 +0,0 @@ -/* - * tclUnixTest.c -- - * - * Contains platform specific test commands for the Unix platform. - * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif -#include "tclInt.h" - -/* - * The headers are needed for the testalarm command that verifies the use of - * SA_RESTART in signal handlers. - */ - -#include <signal.h> -#include <sys/resource.h> - -/* - * The following macros convert between TclFile's and fd's. The conversion - * simple involves shifting fd's up by one to ensure that no valid fd is ever - * the same as NULL. Note that this code is duplicated from tclUnixPipe.c - */ - -#define MakeFile(fd) ((TclFile)INT2PTR(((int)(fd))+1)) -#define GetFd(file) (PTR2INT(file)-1) - -/* - * The stuff below is used to keep track of file handlers created and - * exercised by the "testfilehandler" command. - */ - -typedef struct Pipe { - TclFile readFile; /* File handle for reading from the pipe. NULL - * means pipe doesn't exist yet. */ - TclFile writeFile; /* File handle for writing from the pipe. */ - int readCount; /* Number of times the file handler for this - * file has triggered and the file was - * readable. */ - int writeCount; /* Number of times the file handler for this - * file has triggered and the file was - * writable. */ -} Pipe; - -#define MAX_PIPES 10 -static Pipe testPipes[MAX_PIPES]; - -/* - * The stuff below is used by the testalarm and testgotsig ommands. - */ - -static const char *gotsig = "0"; - -/* - * Forward declarations of functions defined later in this file: - */ - -static Tcl_CmdProc TestalarmCmd; -static Tcl_ObjCmdProc TestchmodCmd; -static Tcl_CmdProc TestfilehandlerCmd; -static Tcl_CmdProc TestfilewaitCmd; -static Tcl_CmdProc TestfindexecutableCmd; -static Tcl_ObjCmdProc TestforkObjCmd; -static Tcl_CmdProc TestgetdefencdirCmd; -static Tcl_CmdProc TestgetopenfileCmd; -static Tcl_CmdProc TestgotsigCmd; -static Tcl_CmdProc TestsetdefencdirCmd; -static Tcl_FileProc TestFileHandlerProc; -static void AlarmHandler(int signum); - -/* - *---------------------------------------------------------------------- - * - * TclplatformtestInit -- - * - * Defines commands that test platform specific functionality for Unix - * platforms. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Defines new commands. - * - *---------------------------------------------------------------------- - */ - -int -TclplatformtestInit( - Tcl_Interp *interp) /* Interpreter to add commands to. */ -{ - Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, - NULL, NULL); - Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testalarm", TestalarmCmd, - NULL, NULL); - Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd, - NULL, NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestfilehandlerCmd -- - * - * This function implements the "testfilehandler" command. It is used to - * test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and TclWaitForFile. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestfilehandlerCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - Pipe *pipePtr; - int i, mask, timeout; - static int initialized = 0; - char buffer[4000]; - TclFile file; - - /* - * NOTE: When we make this code work on Windows also, the following - * variable needs to be made Unix-only. - */ - - if (!initialized) { - for (i = 0; i < MAX_PIPES; i++) { - testPipes[i].readFile = NULL; - } - initialized = 1; - } - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", NULL); - return TCL_ERROR; - } - pipePtr = NULL; - if (argc >= 3) { - if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) { - return TCL_ERROR; - } - if (i >= MAX_PIPES) { - Tcl_AppendResult(interp, "bad index ", argv[2], NULL); - return TCL_ERROR; - } - pipePtr = &testPipes[i]; - } - - if (strcmp(argv[1], "close") == 0) { - for (i = 0; i < MAX_PIPES; i++) { - if (testPipes[i].readFile != NULL) { - TclpCloseFile(testPipes[i].readFile); - testPipes[i].readFile = NULL; - TclpCloseFile(testPipes[i].writeFile); - testPipes[i].writeFile = NULL; - } - } - } else if (strcmp(argv[1], "clear") == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " clear index\"", NULL); - return TCL_ERROR; - } - pipePtr->readCount = pipePtr->writeCount = 0; - } else if (strcmp(argv[1], "counts") == 0) { - char buf[TCL_INTEGER_SPACE * 2]; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " counts index\"", NULL); - return TCL_ERROR; - } - sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount); - Tcl_AppendResult(interp, buf, NULL); - } else if (strcmp(argv[1], "create") == 0) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " create index readMode writeMode\"", NULL); - return TCL_ERROR; - } - if (pipePtr->readFile == NULL) { - if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { - Tcl_AppendResult(interp, "couldn't open pipe: ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } -#ifdef O_NONBLOCK - fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK); - fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK); -#else - Tcl_AppendResult(interp, "can't make pipes non-blocking", - NULL); - return TCL_ERROR; -#endif - } - pipePtr->readCount = 0; - pipePtr->writeCount = 0; - - if (strcmp(argv[3], "readable") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE, - TestFileHandlerProc, pipePtr); - } else if (strcmp(argv[3], "off") == 0) { - Tcl_DeleteFileHandler(GetFd(pipePtr->readFile)); - } else if (strcmp(argv[3], "disabled") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0, - TestFileHandlerProc, pipePtr); - } else { - Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", NULL); - return TCL_ERROR; - } - if (strcmp(argv[4], "writable") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE, - TestFileHandlerProc, pipePtr); - } else if (strcmp(argv[4], "off") == 0) { - Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile)); - } else if (strcmp(argv[4], "disabled") == 0) { - Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0, - TestFileHandlerProc, pipePtr); - } else { - Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", NULL); - return TCL_ERROR; - } - } else if (strcmp(argv[1], "empty") == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " empty index\"", NULL); - return TCL_ERROR; - } - - while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { - /* Empty loop body. */ - } - } else if (strcmp(argv[1], "fill") == 0) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " fill index\"", NULL); - return TCL_ERROR; - } - - memset(buffer, 'a', 4000); - while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) { - /* Empty loop body. */ - } - } else if (strcmp(argv[1], "fillpartial") == 0) { - char buf[TCL_INTEGER_SPACE]; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " fillpartial index\"", NULL); - return TCL_ERROR; - } - - memset(buffer, 'b', 10); - TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10)); - Tcl_AppendResult(interp, buf, NULL); - } else if (strcmp(argv[1], "oneevent") == 0) { - Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); - } else if (strcmp(argv[1], "wait") == 0) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", - argv[0], " wait index readable|writable timeout\"", NULL); - return TCL_ERROR; - } - if (pipePtr->readFile == NULL) { - Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist", NULL); - return TCL_ERROR; - } - if (strcmp(argv[3], "readable") == 0) { - mask = TCL_READABLE; - file = pipePtr->readFile; - } else { - mask = TCL_WRITABLE; - file = pipePtr->writeFile; - } - if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) { - return TCL_ERROR; - } - i = TclUnixWaitForFile(GetFd(file), mask, timeout); - if (i & TCL_READABLE) { - Tcl_AppendElement(interp, "readable"); - } - if (i & TCL_WRITABLE) { - Tcl_AppendElement(interp, "writable"); - } - } else if (strcmp(argv[1], "windowevent") == 0) { - Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be close, clear, counts, create, empty, fill, " - "fillpartial, oneevent, wait, or windowevent", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -static void -TestFileHandlerProc( - ClientData clientData, /* Points to a Pipe structure. */ - int mask) /* Indicates which events happened: - * TCL_READABLE or TCL_WRITABLE. */ -{ - Pipe *pipePtr = clientData; - - if (mask & TCL_READABLE) { - pipePtr->readCount++; - } - if (mask & TCL_WRITABLE) { - pipePtr->writeCount++; - } -} - -/* - *---------------------------------------------------------------------- - * - * TestfilewaitCmd -- - * - * This function implements the "testfilewait" command. It is used to - * test TclUnixWaitForFile. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestfilewaitCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - int mask, result, timeout; - Tcl_Channel channel; - int fd; - ClientData data; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " file readable|writable|both timeout\"", NULL); - return TCL_ERROR; - } - channel = Tcl_GetChannel(interp, argv[1], NULL); - if (channel == NULL) { - return TCL_ERROR; - } - if (strcmp(argv[2], "readable") == 0) { - mask = TCL_READABLE; - } else if (strcmp(argv[2], "writable") == 0){ - mask = TCL_WRITABLE; - } else if (strcmp(argv[2], "both") == 0){ - mask = TCL_WRITABLE|TCL_READABLE; - } else { - Tcl_AppendResult(interp, "bad argument \"", argv[2], - "\": must be readable, writable, or both", NULL); - return TCL_ERROR; - } - if (Tcl_GetChannelHandle(channel, - (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, - (ClientData*) &data) != TCL_OK) { - Tcl_AppendResult(interp, "couldn't get channel file", NULL); - return TCL_ERROR; - } - fd = PTR2INT(data); - if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) { - return TCL_ERROR; - } - result = TclUnixWaitForFile(fd, mask, timeout); - if (result & TCL_READABLE) { - Tcl_AppendElement(interp, "readable"); - } - if (result & TCL_WRITABLE) { - Tcl_AppendElement(interp, "writable"); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestfindexecutableCmd -- - * - * This function implements the "testfindexecutable" command. It is used - * to test TclpFindExecutable. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestfindexecutableCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - Tcl_Obj *saveName; - - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " argv0\"", NULL); - return TCL_ERROR; - } - - saveName = TclGetObjNameOfExecutable(); - Tcl_IncrRefCount(saveName); - - TclpFindExecutable(argv[1]); - Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); - - TclSetObjNameOfExecutable(saveName, NULL); - Tcl_DecrRefCount(saveName); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestgetopenfileCmd -- - * - * This function implements the "testgetopenfile" command. It is used to - * get a FILE * value from a registered channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestgetopenfileCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - ClientData filePtr; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName forWriting\"", NULL); - return TCL_ERROR; - } - if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) - == TCL_ERROR) { - return TCL_ERROR; - } - if (filePtr == NULL) { - Tcl_AppendResult(interp, - "Tcl_GetOpenFile succeeded but FILE * NULL!", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetdefencdirCmd -- - * - * This function implements the "testsetdefenc" command. It is used to - * test Tcl_SetDefaultEncodingDir(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestsetdefencdirCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " defaultDir\"", NULL); - return TCL_ERROR; - } - - Tcl_SetDefaultEncodingDir(argv[1]); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestforkObjCmd -- - * - * This function implements the "testfork" command. It is used to - * fork the Tcl process for specific test cases. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestforkObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ -{ - pid_t pid; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - pid = fork(); - if (pid == -1) { - Tcl_AppendResult(interp, - "Cannot fork", NULL); - return TCL_ERROR; - } - /* Only needed when pthread_atfork is not present, - * should not hurt otherwise. */ - if (pid==0) { - Tcl_InitNotifier(); - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestgetdefencdirCmd -- - * - * This function implements the "testgetdefenc" command. It is used to - * test Tcl_GetDefaultEncodingDir(). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestgetdefencdirCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], NULL); - return TCL_ERROR; - } - - Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestalarmCmd -- - * - * Test that EINTR is handled correctly by generating and handling a - * signal. This requires using the SA_RESTART flag when registering the - * signal handler. - * - * Results: - * None. - * - * Side Effects: - * Sets up an signal and async handlers. - * - *---------------------------------------------------------------------- - */ - -static int -TestalarmCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ -#ifdef SA_RESTART - unsigned int sec; - struct sigaction action; - - if (argc > 1) { - Tcl_GetInt(interp, argv[1], (int *)&sec); - } else { - sec = 1; - } - - /* - * Setup the signal handling that automatically retries any interrupted - * I/O system calls. - */ - - action.sa_handler = AlarmHandler; - memset((void *) &action.sa_mask, 0, sizeof(sigset_t)); - action.sa_flags = SA_RESTART; - - if (sigaction(SIGALRM, &action, NULL) < 0) { - Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - (void) alarm(sec); - return TCL_OK; -#else - Tcl_AppendResult(interp, - "warning: sigaction SA_RESTART not support on this platform", - NULL); - return TCL_ERROR; -#endif -} - -/* - *---------------------------------------------------------------------- - * - * AlarmHandler -- - * - * Signal handler for the alarm command. - * - * Results: - * None. - * - * Side effects: - * Calls the Tcl Async handler. - * - *---------------------------------------------------------------------- - */ - -static void -AlarmHandler( - int signum) -{ - gotsig = "1"; -} - -/* - *---------------------------------------------------------------------- - * - * TestgotsigCmd -- - * - * Verify the signal was handled after the testalarm command. - * - * Results: - * None. - * - * Side Effects: - * Resets the value of gotsig back to '0'. - * - *---------------------------------------------------------------------- - */ - -static int -TestgotsigCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - Tcl_AppendResult(interp, gotsig, NULL); - gotsig = "0"; - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TestchmodCmd -- - * - * Implements the "testchmod" cmd. Used when testing "file" command. - * The only attribute used by the Windows platform is the user write - * flag; if this is not set, the file is made read-only. Otehrwise, the - * file is made read-write. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Changes permissions of specified files. - * - *--------------------------------------------------------------------------- - */ - -static int -TestchmodCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ -{ - int i, mode; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); - return TCL_ERROR; - } - - if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { - return TCL_ERROR; - } - - for (i = 2; i < objc; i++) { - Tcl_DString buffer; - const char *translated; - - translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); - if (translated == NULL) { - return TCL_ERROR; - } - if (chmod(translated, (unsigned) mode) != 0) { - Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), - NULL); - return TCL_ERROR; - } - Tcl_DStringFree(&buffer); - } - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * tab-width: 8 - * End: - */ |