--- /dev/null
+/*
+ * 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);
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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++;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * AlarmHandler --
+ *
+ * Signal handler for the alarm command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the Tcl Async handler.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AlarmHandler(
+ int signum)
+{
+ gotsig = "1";
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
OSDN Git Service
