Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclUnixTest.c

/*
 * 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.
 *
 * RCS: @(#) $Id: tclUnixTest.c,v 1.26 2007/04/20 06:11:00 kennykb Exp $
 */

#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 char *gotsig = "0";

/*
 * Forward declarations of functions defined later in this file:
 */

static void       TestFileHandlerProc(ClientData clientData, int mask);
static int        TestfilehandlerCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static int        TestfilewaitCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static int        TestfindexecutableCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static int        TestgetopenfileCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static int        TestgetdefencdirCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static int        TestsetdefencdirCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
int               TclplatformtestInit(Tcl_Interp *interp);
static int        TestalarmCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static int        TestgotsigCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);
static void       AlarmHandler(int signum);
static int        TestchmodCmd(ClientData dummy,
                      Tcl_Interp *interp, int argc, CONST char **argv);

/*
 *----------------------------------------------------------------------
 *
 * 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_CreateCommand(interp, "testchmod", TestchmodCmd,
          (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testsetdefenc", TestsetdefencdirCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testalarm", TestalarmCmd,
            (ClientData) 0, NULL);
    Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
            (ClientData) 0, 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_SetResult(interp, buf, TCL_VOLATILE);
    } 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_SetResult(interp, "can't make pipes non-blocking",
                TCL_STATIC);
          return TCL_ERROR;
#endif
      }
      pipePtr->readCount = 0;
      pipePtr->writeCount = 0;

      if (strcmp(argv[3], "readable") == 0) {
          Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
                TestFileHandlerProc, (ClientData) 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, (ClientData) 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, (ClientData) 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, (ClientData) 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_SetResult(interp, buf, TCL_VOLATILE);
    } 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 = (Pipe *) 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_SetResult(interp, "couldn't get channel file", TCL_STATIC);
      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 == (ClientData) 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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 argc,                       /* Number of arguments. */
    CONST char **argv)              /* Argument strings. */
{
    int i, mode;
    char *rest;

    if (argc < 2) {
      usage:
      Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " mode file ?file ...?", NULL);
      return TCL_ERROR;
    }

    mode = (int) strtol(argv[1], &rest, 8);
    if ((rest == argv[1]) || (*rest != '\0')) {
      goto usage;
    }

    for (i = 2; i < argc; i++) {
      Tcl_DString buffer;
      CONST char *translated;

      translated = Tcl_TranslateFileName(interp, argv[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;
}

Generated by  Doxygen 1.6.0   Back to index