diff options
| -rw-r--r-- | unix/tclAppInit.c | 72 | ||||
| -rw-r--r-- | unix/tclUnixChan.c | 793 | ||||
| -rw-r--r-- | unix/tclUnixEvent.c | 29 | ||||
| -rw-r--r-- | unix/tclUnixFCmd.c | 1187 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 498 | ||||
| -rw-r--r-- | unix/tclUnixInit.c | 458 | ||||
| -rw-r--r-- | unix/tclUnixThrd.c | 261 | ||||
| -rw-r--r-- | unix/tclUnixTime.c | 370 |
8 files changed, 1933 insertions, 1735 deletions
diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 9f2ab39..8875b92 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -1,17 +1,17 @@ -/* +/* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * procedure for Tcl applications (without Tk). + * function for Tcl applications (without Tk). * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.15 2004/11/12 22:52:30 dgp Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.16 2005/07/20 23:16:00 dkf Exp $ */ #include "tcl.h" @@ -40,8 +40,8 @@ extern int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp)); * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this procedure never - * returns either. + * None: Tcl_Main never returns here, so this function never returns + * either. * * Side effects: * Whatever the application does. @@ -55,14 +55,14 @@ main(argc, argv) char **argv; /* Values of command-line arguments. */ { /* - * The following #if block allows you to change the AppInit - * function by using a #define of TCL_LOCAL_APPINIT instead - * of rewriting this entire file. The #if checks for that - * #define and uses Tcl_AppInit if it doesn't exist. + * The following #if block allows you to change the AppInit function by + * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire + * file. The #if checks for that #define and uses Tcl_AppInit if it does + * not exist. */ #ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit +#define TCL_LOCAL_APPINIT Tcl_AppInit #endif extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); @@ -94,13 +94,13 @@ main(argc, argv) * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. + * This function performs application-specific initialization. Most + * applications, especially those that incorporate additional packages, + * will have their own version of this function. * * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in the interp's result if an error occurs. + * Returns a standard Tcl completion code, and leaves an error message in + * the interp's result if an error occurs. * * Side effects: * Depends on the startup script. @@ -118,15 +118,15 @@ Tcl_AppInit(interp) #ifdef TCL_TEST #ifdef TCL_XT_TEST - if (Tclxttest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } + if (Tclxttest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } #endif if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, - (Tcl_PackageInitProc *) NULL); + (Tcl_PackageInitProc *) NULL); if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -134,30 +134,31 @@ Tcl_AppInit(interp) return TCL_ERROR; } Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, - Procbodytest_SafeInit); + Procbodytest_SafeInit); #endif /* TCL_TEST */ /* - * Call the init procedures for included packages. Each call should - * look like this: + * Call the init functions for included packages. Each call should look + * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * - * where "Mod" is the name of the module. + * where "Mod" is the name of the module. (Dynamically-loadable packages + * should have the same entry-point name.) */ /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. + * Call Tcl_CreateCommand for application-specific commands, if they + * weren't already created by the init functions called above. */ /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. + * Specify a user-specific startup file to invoke if the application is + * run interactively. Typically the startup file is "~/.apprc" where "app" + * is the name of the application. If this line is deleted then no user- + * specific startup file will be run under any conditions. */ #ifdef DJGPP @@ -165,5 +166,14 @@ Tcl_AppInit(interp) #else Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); #endif + return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index c055f83..390b914 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1,26 +1,27 @@ -/* +/* * tclUnixChan.c * - * Common channel driver for Unix channels based on files, command - * pipes and TCP sockets. + * Common channel driver for Unix channels based on files, command pipes + * and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.58 2005/06/06 23:45:46 dkf Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.59 2005/07/20 23:16:00 dkf Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ /* - * sys/ioctl.h has already been included by tclPort.h. Including termios.h - * or termio.h causes a bunch of warning messages because some duplicate - * (but not contradictory) #defines exist in termios.h and/or termio.h + * sys/ioctl.h has already been included by tclPort.h. Including termios.h or + * termio.h causes a bunch of warning messages because some duplicate (but not + * contradictory) #defines exist in termios.h and/or termio.h */ + #undef NL0 #undef NL1 #undef CR0 @@ -63,16 +64,17 @@ # define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) # define GETCONTROL(fd, intPtr) ioctl((fd), TIOCMGET, (intPtr)) # define SETCONTROL(fd, intPtr) ioctl((fd), TIOCMSET, (intPtr)) + /* * TIP #35 introduced a different on exit flush/close behavior that - * doesn't work correctly with standard channels on all systems. - * The problem is tcflush throws away waiting channel data. This may - * be necessary for true serial channels that may block, but isn't - * correct in the standard case. This might be replaced with tcdrain - * instead, but that can block. For now, we revert to making this do - * nothing, and TtyOutputProc being the same old FileOutputProc. - * -- hobbs [Bug #525783] + * doesn't work correctly with standard channels on all systems. The + * problem is tcflush throws away waiting channel data. This may be + * necessary for true serial channels that may block, but isn't correct in + * the standard case. This might be replaced with tcdrain instead, but + * that can block. For now, we revert to making this do nothing, and + * TtyOutputProc being the same old FileOutputProc. - hobbs [Bug #525783] */ + # define BAD_TIP35_FLUSH 0 # if BAD_TIP35_FLUSH # define TTYFLUSH(fd) tcflush((fd), TCIOFLUSH); @@ -88,10 +90,12 @@ # define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int)) # endif /* TIOCOUTQ */ # if defined(TIOCSBRK) && defined(TIOCCBRK) + /* - * Can't use ?: operator below because that messes up types on either - * Linux or Solaris (the two are mutually exclusive!) + * Can't use ?: operator below because that messes up types on either Linux or + * Solaris (the two are mutually exclusive!) */ + # define SETBREAK(fd, flag) \ if (flag) { \ ioctl((fd), TIOCSBRK, NULL); \ @@ -143,17 +147,17 @@ typedef struct FileState { */ typedef struct TtyState { - FileState fs; /* Per-instance state of the file - * descriptor. Must be the first field. */ - int stateUpdated; /* Flag to say if the state has been - * modified and needs resetting. */ - IOSTATE savedState; /* Initial state of device. Used to reset + FileState fs; /* Per-instance state of the file descriptor. + * Must be the first field. */ + int stateUpdated; /* Flag to say if the state has been modified + * and needs resetting. */ + IOSTATE savedState; /* Initial state of device. Used to reset * state when device closed. */ } TtyState; /* - * The following structure is used to set or get the serial port - * attributes in a platform-independant manner. + * The following structure is used to set or get the serial port attributes in + * a platform-independant manner. */ typedef struct TtyAttrs { @@ -166,10 +170,10 @@ typedef struct TtyAttrs { #endif /* !SUPPORTS_TTY */ #define UNSUPPORTED_OPTION(detail) \ - if (interp) { \ - Tcl_AppendResult(interp, (detail), \ - " not supported for this platform", (char *) NULL); \ - } + if (interp) { \ + Tcl_AppendResult(interp, (detail), \ + " not supported for this platform", (char *) NULL); \ + } /* * This structure describes per-instance state of a tcp based channel. @@ -178,8 +182,8 @@ typedef struct TtyAttrs { typedef struct TcpState { Tcl_Channel channel; /* Channel associated with this file. */ int fd; /* The socket itself. */ - int flags; /* ORed combination of the bitfields - * defined below. */ + int flags; /* ORed combination of the bitfields defined + * below. */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ @@ -194,10 +198,10 @@ typedef struct TcpState { #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ /* - * The following defines the maximum length of the listen queue. This is - * the number of outstanding yet-to-be-serviced requests for a connection - * on a server socket, more than this number of outstanding requests and - * the connection request will fail. + * The following defines the maximum length of the listen queue. This is the + * number of outstanding yet-to-be-serviced requests for a connection on a + * server socket, more than this number of outstanding requests and the + * connection request will fail. */ #ifndef SOMAXCONN @@ -210,8 +214,8 @@ typedef struct TcpState { #endif /* SOMAXCONN < 100 */ /* - * The following defines how much buffer space the kernel should maintain - * for a socket. + * The following defines how much buffer space the kernel should maintain for + * a socket. */ #define SOCKET_BUFSIZE 4096 @@ -240,7 +244,7 @@ static int FileOutputProc _ANSI_ARGS_(( static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); #ifdef DEPRECATED -static void FileThreadActionProc _ANSI_ARGS_ (( +static void FileThreadActionProc _ANSI_ARGS_ (( ClientData instanceData, int action)); #endif static int FileTruncateProc _ANSI_ARGS_ ((ClientData instanceData, @@ -292,7 +296,7 @@ static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp, static void TtySetAttributes _ANSI_ARGS_((int fd, TtyAttrs *ttyPtr)); static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp, CONST char *optionName, + Tcl_Interp *interp, CONST char *optionName, CONST char *value)); #endif /* SUPPORTS_TTY */ static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, @@ -323,7 +327,7 @@ static Tcl_ChannelType fileChannelType = { NULL, /* handler proc. */ FileWideSeekProc, /* wide seek proc. */ #ifdef DEPRECATED - FileThreadActionProc, /* thread actions */ + FileThreadActionProc, /* thread actions */ #else NULL, #endif @@ -385,15 +389,14 @@ static Tcl_ChannelType tcpChannelType = { NULL, /* thread action proc. */ NULL, /* truncate proc. */ }; - /* *---------------------------------------------------------------------- * * FileBlockModeProc -- * - * Helper procedure to set blocking and nonblocking modes on a - * file based channel. Invoked by generic IO level code. + * Helper function to set blocking and nonblocking modes on a file based + * channel. Invoked by generic IO level code. * * Results: * 0 if successful, errno when failed. @@ -407,10 +410,10 @@ static Tcl_ChannelType tcpChannelType = { /* ARGSUSED */ static int FileBlockModeProc(instanceData, mode) - ClientData instanceData; /* File state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + ClientData instanceData; /* File state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { FileState *fsPtr = (FileState *) instanceData; int curStatus; @@ -444,8 +447,8 @@ FileBlockModeProc(instanceData, mode) * * FileInputProc -- * - * This procedure is invoked from the generic IO level to read - * input from a file based channel. + * This function is invoked from the generic IO level to read input from + * a file based channel. * * Results: * The number of bytes read is returned or -1 on error. An output @@ -459,15 +462,15 @@ FileBlockModeProc(instanceData, mode) static int FileInputProc(instanceData, buf, toRead, errorCodePtr) - ClientData instanceData; /* File state. */ - char *buf; /* Where to store data read. */ - int toRead; /* How much space is available - * in the buffer? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available in the + * buffer? */ + int *errorCodePtr; /* Where to store error code. */ { FileState *fsPtr = (FileState *) instanceData; - int bytesRead; /* How many bytes were actually - * read from the input device? */ + int bytesRead; /* How many bytes were actually read from the + * input device? */ *errorCodePtr = 0; @@ -491,13 +494,12 @@ FileInputProc(instanceData, buf, toRead, errorCodePtr) * * FileOutputProc-- * - * This procedure is invoked from the generic IO level to write - * output to a file channel. + * This function is invoked from the generic IO level to write output to + * a file channel. * * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. + * The number of bytes written is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. @@ -507,10 +509,10 @@ FileInputProc(instanceData, buf, toRead, errorCodePtr) static int FileOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* File state. */ - CONST char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + CONST char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ { FileState *fsPtr = (FileState *) instanceData; int written; @@ -519,9 +521,8 @@ FileOutputProc(instanceData, buf, toWrite, errorCodePtr) if (toWrite == 0) { /* - * SF Tcl Bug 465765. - * Do not try to write nothing into a file. STREAM based - * implementations will considers this as EOF (if there is a + * SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM + * based implementations will considers this as EOF (if there is a * pipe behind the file). */ @@ -540,7 +541,7 @@ FileOutputProc(instanceData, buf, toWrite, errorCodePtr) * * FileCloseProc -- * - * This procedure is called from the generic IO level to perform + * This function is called from the generic IO level to perform * channel-type-specific cleanup when a file based channel is closed. * * Results: @@ -581,8 +582,8 @@ FileCloseProc(instanceData, interp) * * FileSeekProc -- * - * This procedure is called by the generic IO level to move the - * access point in a file based channel. + * This function is called by the generic IO level to move the access + * point in a file based channel. * * Results: * -1 if failed, the new position if successful. An output @@ -610,20 +611,23 @@ FileSeekProc(instanceData, offset, mode, errorCodePtr) /* * Save our current place in case we need to roll-back the seek. */ + oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR); if (oldLoc == Tcl_LongAsWide(-1)) { /* * Bad things are happening. Error out... */ + *errorCodePtr = errno; return -1; } - + newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode); - + /* * Check for expressability in our return type, and roll-back otherwise. */ + if (newLoc > Tcl_LongAsWide(INT_MAX)) { *errorCodePtr = EOVERFLOW; TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET); @@ -639,9 +643,9 @@ FileSeekProc(instanceData, offset, mode, errorCodePtr) * * FileWideSeekProc -- * - * This procedure is called by the generic IO level to move the - * access point in a file based channel, with offsets expressed - * as wide integers. + * This function is called by the generic IO level to move the access + * point in a file based channel, with offsets expressed as wide + * integers. * * Results: * -1 if failed, the new position if successful. An output @@ -719,12 +723,12 @@ FileWatchProc(instanceData, mask) * * FileGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from - * a file based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from a file + * based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. @@ -748,14 +752,14 @@ FileGetHandleProc(instanceData, direction, handlePtr) } } -#ifdef SUPPORTS_TTY +#ifdef SUPPORTS_TTY /* *---------------------------------------------------------------------- * * TtyCloseProc -- * - * This procedure is called from the generic IO level to perform + * This function is called from the generic IO level to perform * channel-type-specific cleanup when a tty based channel is closed. * * Results: @@ -774,24 +778,26 @@ TtyCloseProc(instanceData, interp) #if BAD_TIP35_FLUSH TtyState *ttyPtr = (TtyState *) instanceData; #endif /* BAD_TIP35_FLUSH */ + #ifdef TTYFLUSH TTYFLUSH(ttyPtr->fs.fd); #endif /* TTYFLUSH */ + #if 0 /* - * TIP#35 agreed to remove the unsave so that TCL could be used as a - * simple stty. - * It would be cleaner to remove all the stuff related to + * TIP#35 agreed to remove the unsave so that TCL could be used as a + * simple stty. It would be cleaner to remove all the stuff related to * TtyState.stateUpdated * TtyState.savedState - * Then the structure TtyState would be the same as FileState. - * IMO this cleanup could better be done for the final 8.4 release - * after nobody complained about the missing unsave. -- schroedter + * Then the structure TtyState would be the same as FileState. IMO this + * cleanup could better be done for the final 8.4 release after nobody + * complained about the missing unsave. - schroedter */ if (ttyPtr->stateUpdated) { SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState); } #endif + return FileCloseProc(instanceData, interp); } @@ -800,17 +806,16 @@ TtyCloseProc(instanceData, interp) * * TtyOutputProc-- * - * This procedure is invoked from the generic IO level to write - * output to a TTY channel. + * This function is invoked from the generic IO level to write output to + * a TTY channel. * * Results: - * The number of bytes written is returned or -1 on error. An - * output argument contains a POSIX error code if an error occurred, - * or zero. + * The number of bytes written is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurred, or zero. * * Side effects: - * Writes output on the output device of the channel - * if the channel is not designated to be closed. + * Writes output on the output device of the channel if the channel is + * not designated to be closed. * *---------------------------------------------------------------------- */ @@ -818,16 +823,17 @@ TtyCloseProc(instanceData, interp) #if BAD_TIP35_FLUSH static int TtyOutputProc(instanceData, buf, toWrite, errorCodePtr) - ClientData instanceData; /* File state. */ - CONST char *buf; /* The data buffer. */ - int toWrite; /* How many bytes to write? */ - int *errorCodePtr; /* Where to store error code. */ + ClientData instanceData; /* File state. */ + CONST char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ { if (TclInExit()) { /* - * Do not write data during Tcl exit. - * Serial port may block preventing Tcl from exit. + * Do not write data during Tcl exit. Serial port may block + * preventing Tcl from exit. */ + return toWrite; } else { return FileOutputProc(instanceData, buf, toWrite, errorCodePtr); @@ -841,10 +847,11 @@ TtyOutputProc(instanceData, buf, toWrite, errorCodePtr) * * TtyModemStatusStr -- * - * Converts a RS232 modem status list of readable flags + * Converts a RS232 modem status list of readable flags * *---------------------------------------------------------------------- */ + static void TtyModemStatusStr(status, dsPtr) int status; /* RS232 modem status */ @@ -881,13 +888,13 @@ TtyModemStatusStr(status, dsPtr) * interp is not NULL. * * Side effects: - * May modify an option on a device. - * Sets Error message if needed (by calling Tcl_BadChannelOption). + * May modify an option on a device. Sets Error message if needed (by + * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ -static int +static int TtySetOptionProc(instanceData, interp, optionName, value) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ @@ -914,8 +921,9 @@ TtySetOptionProc(instanceData, interp, optionName, value) &tty.stop) != TCL_OK) { return TCL_ERROR; } + /* - * system calls results should be checked there. -- dl + * system calls results should be checked there. - dl */ TtySetAttributes(fsPtr->fd, &tty); @@ -928,11 +936,12 @@ TtySetOptionProc(instanceData, interp, optionName, value) /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ + if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { /* - * Reset all handshake options - * DTR and RTS are ON by default + * Reset all handshake options. DTR and RTS are ON by default. */ + GETIOSTATE(fsPtr->fd, &iostate); iostate.c_iflag &= ~(IXON | IXOFF | IXANY); #ifdef CRTSCTS @@ -967,6 +976,7 @@ TtySetOptionProc(instanceData, interp, optionName, value) /* * Option -xchar {\x11 \x13} */ + if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { GETIOSTATE(fsPtr->fd, &iostate); if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -992,6 +1002,7 @@ TtySetOptionProc(instanceData, interp, optionName, value) /* * Option -timeout msec */ + if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; @@ -1008,6 +1019,7 @@ TtySetOptionProc(instanceData, interp, optionName, value) /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ + if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { int i; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -1090,24 +1102,24 @@ TtySetOptionProc(instanceData, interp, optionName, value) * * TtyGetOptionProc -- * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. + * Gets a mode associated with an IO channel. If the optionName arg is + * non NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. * * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. * * Side effects: - * The string returned by this function is in static storage and - * may be reused at any time subsequent to the call. - * Sets Error message if needed (by calling Tcl_BadChannelOption). + * The string returned by this function is in static storage and may be + * reused at any time subsequent to the call. Sets Error message if + * needed (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ -static int +static int TtyGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* File state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ @@ -1139,6 +1151,7 @@ TtyGetOptionProc(instanceData, interp, optionName, dsPtr) /* * get option -xchar */ + if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-xchar"); Tcl_DStringStartSublist(dsPtr); @@ -1159,9 +1172,10 @@ TtyGetOptionProc(instanceData, interp, optionName, dsPtr) /* * get option -queue - * option is readonly and returned by [fconfigure chan -queue] - * but not returned by unnamed [fconfigure chan] + * option is readonly and returned by [fconfigure chan -queue] but not + * returned by unnamed [fconfigure chan] */ + if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) { int inQueue=0, outQueue=0; int inBuffered, outBuffered; @@ -1183,8 +1197,8 @@ TtyGetOptionProc(instanceData, interp, optionName, dsPtr) /* * get option -ttystatus - * option is readonly and returned by [fconfigure chan -ttystatus] - * but not returned by unnamed [fconfigure chan] + * option is readonly and returned by [fconfigure chan -ttystatus] but not + * returned by unnamed [fconfigure chan] */ if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) { int status; @@ -1307,9 +1321,9 @@ static struct {int baud; unsigned long speed;} speeds[] = { * * TtyGetSpeed -- * - * Given a baud rate, get the mask value that should be stored in - * the termios, termio, or sgttyb structure in order to select that - * baud rate. + * Given a baud rate, get the mask value that should be stored in the + * termios, termio, or sgttyb structure in order to select that baud + * rate. * * Results: * As above. @@ -1331,8 +1345,8 @@ TtyGetSpeed(baud) /* * If the baud rate does not correspond to one of the known mask values, - * choose the mask value whose baud rate is closest to the specified - * baud rate. + * choose the mask value whose baud rate is closest to the specified baud + * rate. */ for (i = 0; speeds[i].baud >= 0; i++) { @@ -1353,8 +1367,8 @@ TtyGetSpeed(baud) * * TtyGetBaud -- * - * Given a speed mask value from a termios, termio, or sgttyb - * structure, get the baus rate that corresponds to that mask value. + * Given a speed mask value from a termios, termio, or sgttyb structure, + * get the baus rate that corresponds to that mask value. * * Results: * As above. If the mask value was not recognized, 0 is returned. @@ -1400,8 +1414,8 @@ TtyGetBaud(speed) static void TtyGetAttributes(fd, ttyPtr) - int fd; /* Open file descriptor for serial port to - * be queried. */ + int fd; /* Open file descriptor for serial port to be + * queried. */ TtyAttrs *ttyPtr; /* Buffer filled with serial port * attributes. */ { @@ -1416,15 +1430,15 @@ TtyGetAttributes(fd, ttyPtr) parity = 'n'; #ifdef PAREXT switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; } #else /* !PAREXT */ switch ((int) (iostate.c_cflag & (PARENB | PARODD))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; } #endif /* !PAREXT */ @@ -1439,10 +1453,10 @@ TtyGetAttributes(fd, ttyPtr) parity = 'n'; switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; } data = iostate.c_cflag & CSIZE; @@ -1477,7 +1491,7 @@ TtyGetAttributes(fd, ttyPtr) * * TtySetAttributes -- * - * Set the current attributes of the specified serial device. + * Set the current attributes of the specified serial device. * * Results: * None. @@ -1490,10 +1504,10 @@ TtyGetAttributes(fd, ttyPtr) static void TtySetAttributes(fd, ttyPtr) - int fd; /* Open file descriptor for serial port to - * be modified. */ - TtyAttrs *ttyPtr; /* Buffer containing new attributes for - * serial port. */ + int fd; /* Open file descriptor for serial port to be + * modified. */ + TtyAttrs *ttyPtr; /* Buffer containing new attributes for serial + * port. */ { IOSTATE iostate; @@ -1583,13 +1597,13 @@ TtySetAttributes(fd, ttyPtr) * * TtyParseMode -- * - * Parse the "-mode" argument to the fconfigure command. The argument - * is of the form baud,parity,data,stop. + * Parse the "-mode" argument to the fconfigure command. The argument is + * of the form baud,parity,data,stop. * * Results: - * The return value is TCL_OK if the argument was successfully - * parsed, TCL_ERROR otherwise. If TCL_ERROR is returned, an - * error message is left in the interp's result (if interp is non-NULL). + * The return value is TCL_OK if the argument was successfully parsed, + * TCL_ERROR otherwise. If TCL_ERROR is returned, an error message is + * left in the interp's result (if interp is non-NULL). * * Side effects: * None. @@ -1619,11 +1633,12 @@ TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr) } return TCL_ERROR; } + /* - * Only allow setting mark/space parity on platforms that support it - * Make sure to allow for the case where strchr is a macro. - * [Bug: 5089] + * Only allow setting mark/space parity on platforms that support it Make + * sure to allow for the case where strchr is a macro. [Bug: 5089] */ + if ( #if defined(PAREXT) || defined(USE_TERMIO) strchr("noems", parity) == NULL @@ -1664,29 +1679,28 @@ TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr) * * TtyInit -- * - * Given file descriptor that refers to a serial port, - * initialize the serial port to a set of sane values so that - * Tcl can talk to a device located on the serial port. - * Note that no initialization happens if the initialize flag - * is not set; this is necessary for the correct handling of - * UNIX console TTYs at startup. + * Given file descriptor that refers to a serial port, initialize the + * serial port to a set of sane values so that Tcl can talk to a device + * located on the serial port. Note that no initialization happens if + * the initialize flag is not set; this is necessary for the correct + * handling of UNIX console TTYs at startup. * * Results: - * A pointer to a FileState suitable for use with Tcl_CreateChannel - * and the ttyChannelType structure. + * A pointer to a FileState suitable for use with Tcl_CreateChannel and + * the ttyChannelType structure. * * Side effects: - * Serial device initialized to non-blocking raw mode, similar to - * sockets (if initialize flag is non-zero.) All other modes can - * be simulated on top of this in Tcl. + * Serial device initialized to non-blocking raw mode, similar to sockets + * (if initialize flag is non-zero.) All other modes can be simulated on + * top of this in Tcl. * *--------------------------------------------------------------------------- */ static FileState * TtyInit(fd, initialize) - int fd; /* Open file descriptor for serial port to - * be initialized. */ + int fd; /* Open file descriptor for serial port to be + * initialized. */ int initialize; { TtyState *ttyPtr; @@ -1724,9 +1738,9 @@ TtyInit(fd, initialize) #endif /* USE_SGTTY */ /* - * Only update if we're changing anything to avoid possible - * blocking. + * Only update if we're changing anything to avoid possible blocking. */ + if (ttyPtr->stateUpdated) { SETIOSTATE(fd, &iostate); } @@ -1744,13 +1758,13 @@ TtyInit(fd, initialize) * Open an file based channel on Unix systems. * * Results: - * The new channel or NULL. If NULL, the output argument - * errorCodePtr is set to a POSIX error and an error message is - * left in the interp's result if interp is not NULL. + * The new channel or NULL. If NULL, the output argument errorCodePtr is + * set to a POSIX error and an error message is left in the interp's + * result if interp is not NULL. * * Side effects: - * May open the channel and may cause creation of a file on the - * file system. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ @@ -1775,38 +1789,42 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions) #endif /* SUPPORTS_TTY */ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - channelPermissions = TCL_READABLE; - break; - case O_WRONLY: - channelPermissions = TCL_WRITABLE; - break; - case O_RDWR: - channelPermissions = (TCL_READABLE | TCL_WRITABLE); - break; - default: - /* - * This may occurr if modeString was "", for example. - */ - Tcl_Panic("TclpOpenFileChannel: invalid mode value"); - return NULL; + case O_RDONLY: + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + /* + * This may occurr if modeString was "", for example. + */ + + Tcl_Panic("TclpOpenFileChannel: invalid mode value"); + return NULL; } native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { return NULL; } + #ifdef DJGPP - mode |= O_BINARY; -#endif + mode |= O_BINARY; +#endif + fd = TclOSopen(native, mode, permissions); + #ifdef SUPPORTS_TTY ctl_tty = (strcmp (native, "/dev/tty") == 0); #endif /* SUPPORTS_TTY */ if (fd < 0) { if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", + Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1825,17 +1843,17 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions) #ifdef SUPPORTS_TTY if (!ctl_tty && isatty(fd)) { /* - * Initialize the serial port to a set of sane parameters. - * Especially important if the remote device is set to echo and - * the serial port driver was also set to echo -- as soon as a char - * were sent to the serial port, the remote device would echo it, - * then the serial driver would echo it back to the device, etc. + * Initialize the serial port to a set of sane parameters. Especially + * important if the remote device is set to echo and the serial port + * driver was also set to echo -- as soon as a char were sent to the + * serial port, the remote device would echo it, then the serial + * driver would echo it back to the device, etc. */ translation = "auto crlf"; channelTypePtr = &ttyChannelType; fsPtr = TtyInit(fd, 1); - } else + } else #endif /* SUPPORTS_TTY */ { translation = NULL; @@ -1845,13 +1863,16 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions) #ifdef DEPRECATED if (channelTypePtr == &fileChannelType) { - /* TIP #218. Removed the code inserting the new structure - * into the global list. This is now handled in the thread - * action callbacks, and only there. + /* + * TIP #218. Removed the code inserting the new structure into the + * global list. This is now handled in the thread action callbacks, + * and only there. */ - fsPtr->nextPtr = NULL; + + fsPtr->nextPtr = NULL; } #endif /* DEPRECATED */ + fsPtr->validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fd = fd; @@ -1860,11 +1881,11 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions) if (translation != NULL) { /* - * Gotcha. Most modems need a "\r" at the end of the command - * sequence. If you just send "at\n", the modem will not respond - * with "OK" because it never got a "\r" to actually invoke the - * command. So, by default, newlines are translated to "\r\n" on - * output to avoid "bug" reports that the serial port isn't working. + * Gotcha. Most modems need a "\r" at the end of the command sequence. + * If you just send "at\n", the modem will not respond with "OK" + * because it never got a "\r" to actually invoke the command. So, by + * default, newlines are translated to "\r\n" on output to avoid "bug" + * reports that the serial port isn't working. */ if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", @@ -1920,8 +1941,8 @@ Tcl_MakeFileChannel(handle, mode) } else #endif /* SUPPORTS_TTY */ if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0 - && sockaddrLen > 0 - && sockaddr.sa_family == AF_INET) { + && sockaddrLen > 0 + && sockaddr.sa_family == AF_INET) { return MakeTcpClientChannelMode((ClientData) fd, mode); } else { channelTypePtr = &fileChannelType; @@ -1942,8 +1963,8 @@ Tcl_MakeFileChannel(handle, mode) * * TcpBlockModeProc -- * - * This procedure is invoked by the generic IO level to set blocking - * and nonblocking mode on a TCP socket based channel. + * This function is invoked by the generic IO level to set blocking and + * nonblocking mode on a TCP socket based channel. * * Results: * 0 if successful, errno when failed. @@ -1957,10 +1978,10 @@ Tcl_MakeFileChannel(handle, mode) /* ARGSUSED */ static int TcpBlockModeProc(instanceData, mode) - ClientData instanceData; /* Socket state. */ - int mode; /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ + ClientData instanceData; /* Socket state. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { TcpState *statePtr = (TcpState *) instanceData; int setting; @@ -2001,8 +2022,8 @@ TcpBlockModeProc(instanceData, mode) * * WaitForConnect -- * - * Waits for a connection on an asynchronously opened socket to - * be completed. + * Waits for a connection on an asynchronously opened socket to be + * completed. * * Results: * None. @@ -2023,8 +2044,8 @@ WaitForConnect(statePtr, errorCodePtr) int flags; /* fcntl flags for the socket. */ /* - * If an asynchronous connect is in progress, attempt to wait for it - * to complete before reading. + * If an asynchronous connect is in progress, attempt to wait for it to + * complete before reading. */ if (statePtr->flags & TCP_ASYNC_CONNECT) { @@ -2064,16 +2085,16 @@ WaitForConnect(statePtr, errorCodePtr) * * TcpInputProc -- * - * This procedure is invoked by the generic IO level to read input - * from a TCP socket based channel. + * This function is invoked by the generic IO level to read input from a + * TCP socket based channel. * - * NOTE: We cannot share code with FilePipeInputProc because here - * we must use recv to obtain the input from the channel, not read. + * NOTE: We cannot share code with FilePipeInputProc because here we must + * use recv to obtain the input from the channel, not read. * * Results: * The number of bytes read is returned or -1 on error. An output - * argument contains the POSIX error code on error, or zero if no - * error occurred. + * argument contains the POSIX error code on error, or zero if no error + * occurred. * * Side effects: * Reads input from the input device of the channel. @@ -2086,8 +2107,8 @@ static int TcpInputProc(instanceData, buf, bufSize, errorCodePtr) ClientData instanceData; /* Socket state. */ char *buf; /* Where to store data read. */ - int bufSize; /* How much space is available - * in the buffer? */ + int bufSize; /* How much space is available in the + * buffer? */ int *errorCodePtr; /* Where to store error code. */ { TcpState *statePtr = (TcpState *) instanceData; @@ -2118,15 +2139,15 @@ TcpInputProc(instanceData, buf, bufSize, errorCodePtr) * * TcpOutputProc -- * - * This procedure is invoked by the generic IO level to write output - * to a TCP socket based channel. + * This function is invoked by the generic IO level to write output to a + * TCP socket based channel. * - * NOTE: We cannot share code with FilePipeOutputProc because here - * we must use send, not write, to get reliable error reporting. + * NOTE: We cannot share code with FilePipeOutputProc because here we + * must use send, not write, to get reliable error reporting. * * Results: - * The number of bytes written is returned. An output argument is - * set to a POSIX error code if an error occurred, or zero. + * The number of bytes written is returned. An output argument is set to + * a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. @@ -2163,9 +2184,9 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr) * * TcpCloseProc -- * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a TCP socket based channel - * is closed. + * This function is invoked by the generic IO level to perform + * channel-type-specific cleanup when a TCP socket based channel is + * closed. * * Results: * 0 if successful, the value of errno if failed. @@ -2186,12 +2207,11 @@ TcpCloseProc(instanceData, interp) int errorCode = 0; /* - * Delete a file handler that may be active for this socket if this - * is a server socket - the file handler was created automatically - * by Tcl as part of the mechanism to accept new client connections. - * Channel handlers are already deleted in the generic IO channel - * closing code that called this function, so we do not have to - * delete them here. + * Delete a file handler that may be active for this socket if this is a + * server socket - the file handler was created automatically by Tcl as + * part of the mechanism to accept new client connections. Channel + * handlers are already deleted in the generic IO channel closing code + * that called this function, so we do not have to delete them here. */ Tcl_DeleteFileHandler(statePtr->fd); @@ -2209,15 +2229,15 @@ TcpCloseProc(instanceData, interp) * * TcpGetOptionProc -- * - * Computes an option value for a TCP socket based channel, or a - * list of all options and their values. + * Computes an option value for a TCP socket based channel, or a list of + * all options and their values. * * Note: This code is based on code contributed by John Haxby. * * Results: - * A standard Tcl result. The value of the specified option or a - * list of all options and their values is returned in the - * supplied DString. Sets Error message if needed. + * A standard Tcl result. The value of the specified option or a list of + * all options and their values is returned in the supplied DString. Sets + * Error message if needed. * * Side effects: * None. @@ -2229,12 +2249,11 @@ static int TcpGetOptionProc(instanceData, interp, optionName, dsPtr) ClientData instanceData; /* Socket state. */ Tcl_Interp *interp; /* For error reporting - can be NULL. */ - CONST char *optionName; /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr; /* Where to store the computed - * value; initialized by caller. */ + CONST char *optionName; /* Name of the option to retrieve the value + * for, or NULL to get all options and their + * values. */ + Tcl_DString *dsPtr; /* Where to store the computed value; + * initialized by caller. */ { TcpState *statePtr = (TcpState *) instanceData; struct sockaddr_in sockname; @@ -2296,9 +2315,9 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) } else { /* * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could - * be an fconfigure request on a server socket. (which have - * no peer). same must be done on win&mac. + * (len==0), don't flag an error at that point because it could be + * an fconfigure request on a server socket (which have no peer). + * Same must be done on win&mac. */ if (len) { @@ -2367,8 +2386,8 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr) * None. * * Side effects: - * Sets up the notifier so that a future event on the channel will - * be seen by Tcl. + * Sets up the notifier so that a future event on the channel will be + * seen by Tcl. * *---------------------------------------------------------------------- */ @@ -2404,12 +2423,12 @@ TcpWatchProc(instanceData, mask) * * TcpGetHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve OS handles from inside - * a TCP socket based channel. + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * TCP socket based channel. * * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if - * there is no handle for the specified direction. + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. * * Side effects: * None. @@ -2435,12 +2454,12 @@ TcpGetHandleProc(instanceData, direction, handlePtr) * * CreateSocket -- * - * This function opens a new socket in client or server mode - * and initializes the TcpState structure. + * This function opens a new socket in client or server mode and + * initializes the TcpState structure. * * Results: - * Returns a new TcpState, or NULL with an error in the interp's - * result, if interp is not NULL. + * Returns a new TcpState, or NULL with an error in the interp's result, + * if interp is not NULL. * * Side effects: * Opens a socket. @@ -2452,10 +2471,10 @@ static TcpState * CreateSocket(interp, port, host, server, myaddr, myport, async) Tcl_Interp *interp; /* For error reporting; can be NULL. */ int port; /* Port number to open. */ - CONST char *host; /* Name of host on which to open port. - * NULL implies INADDR_ANY */ - int server; /* 1 if socket should be a server socket, - * else 0 for a client socket. */ + CONST char *host; /* Name of host on which to open port. NULL + * implies INADDR_ANY */ + int server; /* 1 if socket should be a server socket, else + * 0 for a client socket. */ CONST char *myaddr; /* Optional client-side address */ int myport; /* Optional client-side port */ int async; /* If nonzero and creating a client socket, @@ -2483,8 +2502,8 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) } /* - * Set the close-on-exec flag so that the socket will not get - * inherited by child processes. + * Set the close-on-exec flag so that the socket will not get inherited by + * child processes. */ fcntl(sock, F_SETFD, FD_CLOEXEC); @@ -2510,9 +2529,9 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) sizeof(struct sockaddr)); if (status != -1) { status = listen(sock, SOMAXCONN); - } + } } else { - if (myaddr != NULL || myport != 0) { + if (myaddr != NULL || myport != 0) { curState = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &curState, sizeof(curState)); @@ -2525,9 +2544,9 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) /* * Attempt to connect. The connect may fail at present with an - * EINPROGRESS but at a later time it will complete. The caller - * will set up a file handler on the socket if she is interested in - * being informed when the connect completes. + * EINPROGRESS but at a later time it will complete. The caller will + * set up a file handler on the socket if she is interested in being + * informed when the connect completes. */ if (async) { @@ -2554,10 +2573,11 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) /* * Here we are if the connect succeeds. In case of an * asynchronous connect we have to reset the channel to - * blocking mode. This appears to happen not very often, - * but e.g. on a HP 9000/800 under HP-UX B.11.00 we enter - * this stage. [Bug: 4388] + * blocking mode. This appears to happen not very often, but + * e.g. on a HP 9000/800 under HP-UX B.11.00 we enter this + * stage. [Bug: 4388] */ + if (async) { #ifndef USE_FIONBIO origState = fcntl(sock, F_GETFL); @@ -2572,7 +2592,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async) } } -bindError: + bindError: if (status < 0) { if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", @@ -2597,7 +2617,7 @@ bindError: return statePtr; -addressError: + addressError: if (sock != -1) { close(sock); } @@ -2616,8 +2636,8 @@ addressError: * This function initializes a sockaddr structure for a host and port. * * Results: - * 1 if the host was valid, 0 if the host could not be converted to - * an IP address. + * 1 if the host was valid, 0 if the host could not be converted to an IP + * address. * * Side effects: * Fills in the *sockaddrPtr structure. @@ -2679,10 +2699,10 @@ CreateSocketAddress(sockaddrPtr, host, port) } /* - * NOTE: On 64 bit machines the assignment below is rumored to not - * do the right thing. Please report errors related to this if you - * observe incorrect behavior on 64 bit machines such as DEC Alphas. - * Should we modify this code to do an explicit memcpy? + * NOTE: On 64 bit machines the assignment below is rumored to not do the + * right thing. Please report errors related to this if you observe + * incorrect behavior on 64 bit machines such as DEC Alphas. Should we + * modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; @@ -2697,8 +2717,8 @@ CreateSocketAddress(sockaddrPtr, host, port) * Opens a TCP client socket and creates a channel around it. * * Results: - * The channel or NULL if failed. An error message is returned - * in the interpreter on failure. + * The channel or NULL if failed. An error message is returned in the + * interpreter on failure. * * Side effects: * Opens a client socket and creates a new channel. @@ -2819,9 +2839,8 @@ MakeTcpClientChannelMode(sock, mode) * Opens a TCP server socket and creates a channel around it. * * Results: - * The channel or NULL if failed. If an error occurred, an - * error message is left in the interp's result if interp is - * not NULL. + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. * * Side effects: * Opens a server socket and creates a new channel. @@ -2855,8 +2874,8 @@ Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) statePtr->acceptProcData = acceptProcData; /* - * Set up the callback mechanism for accepting connections - * from new clients. + * Set up the callback mechanism for accepting connections from new + * clients. */ Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept, @@ -2877,8 +2896,8 @@ Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) * None. * * Side effects: - * Creates a new connection socket. Calls the registered callback - * for the connection acceptance mechanism. + * Creates a new connection socket. Calls the registered callback for the + * connection acceptance mechanism. * *---------------------------------------------------------------------- */ @@ -2893,7 +2912,7 @@ TcpAccept(data, mask) int newsock; /* The new client socket */ TcpState *newSockState; /* State for new socket. */ struct sockaddr_in addr; /* The remote address */ - socklen_t len; /* For accept interface */ + socklen_t len; /* For accept interface */ char channelName[16 + TCL_INTEGER_SPACE]; sockState = (TcpState *) data; @@ -2905,8 +2924,8 @@ TcpAccept(data, mask) } /* - * Set close-on-exec flag to prevent the newly accepted socket from - * being inherited by child processes. + * Set close-on-exec flag to prevent the newly accepted socket from being + * inherited by child processes. */ (void) fcntl(newsock, F_SETFD, FD_CLOEXEC); @@ -2937,15 +2956,14 @@ TcpAccept(data, mask) * * TclpGetDefaultStdChannel -- * - * Creates channels for standard input, standard output or standard - * error output if they do not already exist. + * Creates channels for standard input, standard output or standard error + * output if they do not already exist. * * Results: * Returns the specified default standard channel, or NULL. * * Side effects: - * May cause the creation of a standard channel and the underlying - * file. + * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ @@ -2962,40 +2980,41 @@ TclpGetDefaultStdChannel(type) /* * Some #def's to make the code a little clearer! */ + #define ZERO_OFFSET ((Tcl_SeekOffset) 0) #define ERROR_OFFSET ((Tcl_SeekOffset) -1) switch (type) { - case TCL_STDIN: - if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) - && (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 0; - mode = TCL_READABLE; - bufMode = "line"; - break; - case TCL_STDOUT: - if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) - && (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 1; - mode = TCL_WRITABLE; - bufMode = "line"; - break; - case TCL_STDERR: - if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) - && (errno == EBADF)) { - return (Tcl_Channel) NULL; - } - fd = 2; - mode = TCL_WRITABLE; - bufMode = "none"; - break; - default: - Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type"); - break; + case TCL_STDIN: + if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + && (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 0; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + && (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 1; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + && (errno == EBADF)) { + return (Tcl_Channel) NULL; + } + fd = 2; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; } #undef ZERO_OFFSET @@ -3024,16 +3043,16 @@ TclpGetDefaultStdChannel(type) * * Tcl_GetOpenFile -- * - * Given a name of a channel registered in the given interpreter, - * returns a FILE * for it. + * Given a name of a channel registered in the given interpreter, returns + * a FILE * for it. * * Results: * A standard Tcl result. If the channel is registered in the given - * interpreter and it is managed by the "file" channel driver, and - * it is open for the requested mode, then the output parameter - * filePtr is set to a FILE * for the underlying file. On error, the - * filePtr is not set, TCL_ERROR is returned and an error message is - * left in the interp's result. + * interpreter and it is managed by the "file" channel driver, and it is + * open for the requested mode, then the output parameter filePtr is set + * to a FILE * for the underlying file. On error, the filePtr is not set, + * TCL_ERROR is returned and an error message is left in the interp's + * result. * * Side effects: * May invoke fdopen to create the FILE * for the requested file. @@ -3045,13 +3064,13 @@ int Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr) Tcl_Interp *interp; /* Interpreter in which to find file. */ CONST char *chanID; /* String that identifies file. */ - int forWriting; /* 1 means the file is going to be used - * for writing, 0 means for reading. */ - int checkUsage; /* 1 means verify that the file was opened - * in a mode that allows the access specified - * by "forWriting". Ignored, we always - * check that the channel is open for the - * requested mode. */ + int forWriting; /* 1 means the file is going to be used for + * writing, 0 means for reading. */ + int checkUsage; /* 1 means verify that the file was opened in + * a mode that allows the access specified by + * "forWriting". Ignored, we always check that + * the channel is open for the requested + * mode. */ ClientData *filePtr; /* Store pointer to FILE structure here. */ { Tcl_Channel chan; @@ -3095,8 +3114,8 @@ Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr) /* * The call to fdopen below is probably dangerous, since it will - * truncate an existing file if the file is being opened - * for writing.... + * truncate an existing file if the file is being opened for + * writing.... */ f = fdopen(fd, (forWriting ? "w" : "r")); @@ -3112,7 +3131,7 @@ Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr) Tcl_AppendResult(interp, "\"", chanID, "\" cannot be used to get a FILE *", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } /* @@ -3120,18 +3139,17 @@ Tcl_GetOpenFile(interp, chanID, forWriting, checkUsage, filePtr) * * TclUnixWaitForFile -- * - * This procedure waits synchronously for a file to become readable - * or writable, with an optional timeout. + * This function waits synchronously for a file to become readable or + * writable, with an optional timeout. * * Results: * The return value is an OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions - * that are present on file at the time of the return. This - * procedure will not return until either "timeout" milliseconds - * have elapsed or at least one of the conditions given by mask - * has occurred for file (a return value of 0 means that a timeout - * occurred). No normal events will be serviced during the - * execution of this procedure. + * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions that are + * present on file at the time of the return. This function will not + * return until either "timeout" milliseconds have elapsed or at least + * one of the conditions given by mask has occurred for file (a return + * value of 0 means that a timeout occurred). No normal events will be + * serviced during the execution of this function. * * Side effects: * Time passes. @@ -3145,11 +3163,11 @@ TclUnixWaitForFile(fd, mask, timeout) int mask; /* What to wait for: OR'ed combination of * TCL_READABLE, TCL_WRITABLE, and * TCL_EXCEPTION. */ - int timeout; /* Maximum amount of time to wait for one - * of the conditions in mask to occur, in + int timeout; /* Maximum amount of time to wait for one of + * the conditions in mask to occur, in * milliseconds. A value of 0 means don't - * wait at all, and a value of -1 means - * wait forever. */ + * wait at all, and a value of -1 means wait + * forever. */ { Tcl_Time abortTime, now; struct timeval blockTime, *timeoutPtr; @@ -3161,8 +3179,8 @@ TclUnixWaitForFile(fd, mask, timeout) * last call to select. */ /* - * If there is a non-zero finite timeout, compute the time when - * we give up. + * If there is a non-zero finite timeout, compute the time when we give + * up. */ if (timeout > 0) { @@ -3194,8 +3212,8 @@ TclUnixWaitForFile(fd, mask, timeout) bit = 1 << (fd%(NBBY*sizeof(fd_mask))); /* - * Loop in a mini-event loop of our own, waiting for either the - * file to become ready or a timeout to occur. + * Loop in a mini-event loop of our own, waiting for either the file to + * become ready or a timeout to occur. */ while (1) { @@ -3230,7 +3248,10 @@ TclUnixWaitForFile(fd, mask, timeout) * Wait for the event or a timeout. */ - /* This is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * This is needed to satisfy GCC 3.3's strict aliasing rules. + */ + maskp[0] = &readyMasks[0]; maskp[1] = &readyMasks[MASK_SIZE]; maskp[2] = &readyMasks[2*MASK_SIZE]; @@ -3296,25 +3317,25 @@ FileThreadActionProc (instanceData, action) FileState *fsPtr = (FileState *) instanceData; if (action == TCL_CHANNEL_THREAD_INSERT) { - fsPtr->nextPtr = tsdPtr->firstFilePtr; + fsPtr->nextPtr = tsdPtr->firstFilePtr; tsdPtr->firstFilePtr = fsPtr; } else { - FileState **nextPtrPtr; + FileState **nextPtrPtr; int removed = 0; for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { if ((*nextPtrPtr) == fsPtr) { - (*nextPtrPtr) = fsPtr->nextPtr; + (*nextPtrPtr) = fsPtr->nextPtr; removed = 1; break; } } /* - * This could happen if the channel was created in one - * thread and then moved to another without updating - * the thread local data in each thread. + * This could happen if the channel was created in one thread and then + * moved to another without updating the thread local data in each + * thread. */ if (!removed) { @@ -3332,14 +3353,13 @@ FileThreadActionProc (instanceData, action) * Truncates a file to a given length. * * Results: - * 0 if the operation succeeded, and -1 if it failed (in which - * case *errorCodePtr will be set to errno). + * 0 if the operation succeeded, and -1 if it failed (in which case + * *errorCodePtr will be set to errno). * * Side effects: - * The underlying file is potentially truncated. This can have a - * wide variety of side effects, including moving file pointers - * that point at places later in the file than the truncate - * point. + * The underlying file is potentially truncated. This can have a wide + * variety of side effects, including moving file pointers that point at + * places later in the file than the truncate point. * *---------------------------------------------------------------------- */ @@ -3356,6 +3376,7 @@ FileTruncateProc(instanceData, length) /* * We assume this goes with the type for now... */ + result = ftruncate64(fsPtr->fd, (off64_t) length); #else result = ftruncate(fsPtr->fd, (off_t) length); @@ -3365,3 +3386,11 @@ FileTruncateProc(instanceData, length) } return 0; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c index 2e7cb4e..688938b 100644 --- a/unix/tclUnixEvent.c +++ b/unix/tclUnixEvent.c @@ -5,10 +5,10 @@ * * Copyright (c) 1997 by Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixEvent.c,v 1.7 2005/05/10 18:35:27 kennykb Exp $ + * RCS: @(#) $Id: tclUnixEvent.c,v 1.8 2005/07/20 23:16:00 dkf Exp $ */ #include "tclInt.h" @@ -37,10 +37,9 @@ Tcl_Sleep(ms) Tcl_Time before, after, vdelay; /* - * The only trick here is that select appears to return early - * under some conditions, so we have to check to make sure that - * the right amount of time really has elapsed. If it's too - * early, go back to sleep again. + * The only trick here is that select appears to return early under some + * conditions, so we have to check to make sure that the right amount of + * time really has elapsed. If it's too early, go back to sleep again. */ Tcl_GetTime(&before); @@ -52,7 +51,9 @@ Tcl_Sleep(ms) after.sec += 1; } while (1) { - /* TIP #233: Scale from virtual time to real-time for select */ + /* + * TIP #233: Scale from virtual time to real-time for select. + */ vdelay.sec = after.sec - before.sec; vdelay.usec = after.usec - before.usec; @@ -70,8 +71,8 @@ Tcl_Sleep(ms) delay.tv_usec = vdelay.usec; /* - * Special note: must convert delay.tv_sec to int before comparing - * to zero, since delay.tv_usec is unsigned on some platforms. + * Special note: must convert delay.tv_sec to int before comparing to + * zero, since delay.tv_usec is unsigned on some platforms. */ if ((((int) delay.tv_sec) < 0) @@ -83,3 +84,11 @@ Tcl_Sleep(ms) Tcl_GetTime(&before); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index cc910d1..2e74592 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1,28 +1,27 @@ /* * tclUnixFCmd.c * - * This file implements the unix specific portion of file manipulation - * subcommands of the "file" command. All filename arguments should + * This file implements the unix specific portion of file manipulation + * subcommands of the "file" command. All filename arguments should * already be translated to native format. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.43 2005/05/11 00:53:51 hobbs Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.44 2005/07/20 23:16:00 dkf Exp $ * - * Portions of this code were derived from NetBSD source code which has - * the following copyright notice: + * Portions of this code were derived from NetBSD source code which has the + * following copyright notice: * * Copyright (c) 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. + * modification, are permitted provided that the following conditions are met: + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. @@ -30,21 +29,21 @@ * must display the following acknowledgement: * This product includes software developed by the University of * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software + * 4. Neither the name of the University nor the names of its contributors may + * be used to endorse or promote products derived from this software * without specific prior written permission. * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + * DAMAGE. */ #include "tclInt.h" @@ -61,9 +60,9 @@ * TraverseUnixTree() calls the traverseProc() */ -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ /* * Callbacks for file attributes code. @@ -109,57 +108,51 @@ typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, /* * Constants and variables necessary for file attributes subcommand. - * - * IMPORTANT: The permissions attribute is assumed to be the third - * item (i.e. to be indexed with '2' in arrays) in code in tclIOUtil.c - * and possibly elsewhere in Tcl's core. + * + * IMPORTANT: The permissions attribute is assumed to be the third item (i.e. + * to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly + * elsewhere in Tcl's core. */ #ifdef DJGPP -/*See contrib/djgpp/tclDjgppFCmd.c for definitio*/ +/* + * See contrib/djgpp/tclDjgppFCmd.c for definition. + */ + extern TclFileAttrProcs tclpFileAttrProcs[]; extern char *tclpFileAttrStrings[]; #else enum { - UNIX_GROUP_ATTRIBUTE, - UNIX_OWNER_ATTRIBUTE, - UNIX_PERMISSIONS_ATTRIBUTE, + UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) UNIX_READONLY_ATTRIBUTE, #endif #ifdef MAC_OSX_TCL - MACOSX_CREATOR_ATTRIBUTE, - MACOSX_TYPE_ATTRIBUTE, - MACOSX_HIDDEN_ATTRIBUTE, + MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, MACOSX_RSRCLENGTH_ATTRIBUTE, #endif UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */ }; CONST char *tclpFileAttrStrings[] = { - "-group", - "-owner", - "-permissions", + "-group", "-owner", "-permissions", #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) "-readonly", #endif #ifdef MAC_OSX_TCL - "-creator", - "-type", - "-hidden", - "-rsrclength", + "-creator", "-type", "-hidden", "-rsrclength", #endif (char *) NULL }; CONST TclFileAttrProcs tclpFileAttrProcs[] = { - {GetGroupAttribute, SetGroupAttribute}, - {GetOwnerAttribute, SetOwnerAttribute}, - {GetPermissionsAttribute, SetPermissionsAttribute}, + {GetGroupAttribute, SetGroupAttribute}, + {GetOwnerAttribute, SetOwnerAttribute}, + {GetPermissionsAttribute, SetPermissionsAttribute}, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) - {GetReadOnlyAttribute, SetReadOnlyAttribute}, + {GetReadOnlyAttribute, SetReadOnlyAttribute}, #endif #ifdef MAC_OSX_TCL {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, @@ -195,11 +188,12 @@ static int TraverseUnixTree _ANSI_ARGS_(( #ifdef PURIFY /* - * realpath and purify don't mix happily. It has been noted that realpath + * realpath and purify don't mix happily. It has been noted that realpath * should not be used with purify because of bogus warnings, but just - * memset'ing the resolved path will squelch those. This assumes we are + * memset'ing the resolved path will squelch those. This assumes we are * passing the standard MAXPATHLEN size resolved arg. */ + static char * Realpath _ANSI_ARGS_((CONST char *path, char *resolved)); @@ -214,50 +208,48 @@ Realpath(path, resolved) #else #define Realpath realpath #endif - /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * - * Changes the name of an existing file or directory, from src to dst. - * If src and dst refer to the same file or directory, does nothing - * and returns success. Otherwise if dst already exists, it will be - * deleted and replaced by src subject to the following conditions: + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing and + * returns success. Otherwise if dst already exists, it will be deleted + * and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. - * In any other situation where dst already exists, the rename will - * fail. + * In any other situation where dst already exists, the rename will fail. * * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: + * If the directory was successfully created, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: src or dst parent directory can't be read and/or written. + * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. * ENOENT: src doesn't exist, or src or dst is "". - * ENOTDIR: src is a directory, but dst is not. + * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. - * + * * Side effects: - * The implementation of rename may allow cross-filesystem renames, - * but the caller should be prepared to emulate it with copy and - * delete if errno is EXDEV. + * The implementation of rename may allow cross-filesystem renames, but + * the caller should be prepared to emulate it with copy and delete if + * errno is EXDEV. * *--------------------------------------------------------------------------- */ -int +int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } static int @@ -275,21 +267,21 @@ DoRenameFile(src, dst) } /* - * IRIX returns EIO when you attept to move a directory into - * itself. We just map EIO to EINVAL get the right message on SGI. - * Most platforms don't return EIO except in really strange cases. + * IRIX returns EIO when you attept to move a directory into itself. We + * just map EIO to EINVAL get the right message on SGI. Most platforms + * don't return EIO except in really strange cases. */ - + if (errno == EIO) { errno = EINVAL; } - + #ifndef NO_REALPATH /* - * SunOS 4.1.4 reports overwriting a non-empty directory with a - * directory as EINVAL instead of EEXIST (first rule out the correct - * EINVAL result code for moving a directory into itself). Must be - * conditionally compiled because realpath() not defined on all systems. + * SunOS 4.1.4 reports overwriting a non-empty directory with a directory + * as EINVAL instead of EEXIST (first rule out the correct EINVAL result + * code for moving a directory into itself). Must be conditionally + * compiled because realpath() not defined on all systems. */ if (errno == EINVAL) { @@ -298,12 +290,12 @@ DoRenameFile(src, dst) Tcl_DirEntry *dirEntPtr; if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */ - && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */ + && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native */ && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { dirPtr = opendir(dst); /* INTL: Native. */ if (dirPtr != NULL) { while (1) { - dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */ + dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */ if (dirEntPtr == NULL) { break; } @@ -326,15 +318,15 @@ DoRenameFile(src, dst) * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, * instead of EINVAL. */ - + errno = EINVAL; } /* - * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a - * file across filesystems and the parent directory of that file is - * not writable. Most other systems return EXDEV. Does nothing to - * correct this behavior. + * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a file + * across filesystems and the parent directory of that file is not + * writable. Most other systems return EXDEV. Does nothing to correct this + * behavior. */ return TCL_ERROR; @@ -345,48 +337,48 @@ DoRenameFile(src, dst) * * TclpObjCopyFile, DoCopyFile -- * - * Copy a single file (not a directory). If dst already exists and - * is not a directory, it is removed. + * Copy a single file (not a directory). If dst already exists and is not + * a directory, it is removed. * * Results: - * If the file was successfully copied, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: + * If the file was successfully copied, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: src or dst parent directory can't be read and/or written. + * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. * ENOENT: src doesn't exist. src or dst is "". * * Side effects: - * This procedure will also copy symbolic links, block, and - * character devices, and fifos. For symbolic links, the links - * themselves will be copied and not what they point to. For the - * other special file types, the directory entry will be copied and - * not the contents of the device that it refers to. + * This procedure will also copy symbolic links, block, and character + * devices, and fifos. For symbolic links, the links themselves will be + * copied and not what they point to. For the other special file types, + * the directory entry will be copied and not the contents of the device + * that it refers to. * *--------------------------------------------------------------------------- */ -int +int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile(src, dst) - CONST char *src; /* Pathname of file to be copied (native). */ - CONST char *dst; /* Pathname of file to copy to (native). */ + CONST char *src; /* Pathname of file to be copied (native). */ + CONST char *dst; /* Pathname of file to copy to (native). */ { Tcl_StatBuf srcStatBuf, dstStatBuf; /* * Have to do a stat() to determine the filetype. */ - + if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ return TCL_ERROR; } @@ -396,10 +388,10 @@ DoCopyFile(src, dst) } /* - * symlink, and some of the other calls will fail if the target - * exists, so we remove it first + * symlink, and some of the other calls will fail if the target exists, so + * we remove it first. */ - + if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */ if (S_ISDIR(dstStatBuf.st_mode)) { errno = EISDIR; @@ -409,43 +401,40 @@ DoCopyFile(src, dst) if (unlink(dst) != 0) { /* INTL: Native. */ if (errno != ENOENT) { return TCL_ERROR; - } + } } switch ((int) (srcStatBuf.st_mode & S_IFMT)) { #ifndef DJGPP - case S_IFLNK: { - char link[MAXPATHLEN]; - int length; + case S_IFLNK: { + char link[MAXPATHLEN]; + int length; - length = readlink(src, link, sizeof(link)); /* INTL: Native. */ - if (length == -1) { - return TCL_ERROR; - } - link[length] = '\0'; - if (symlink(link, dst) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - break; + length = readlink(src, link, sizeof(link)); /* INTL: Native. */ + if (length == -1) { + return TCL_ERROR; } -#endif - case S_IFBLK: - case S_IFCHR: { - if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ - srcStatBuf.st_rdev) < 0) { - return TCL_ERROR; - } - return CopyFileAtts(src, dst, &srcStatBuf); + link[length] = '\0'; + if (symlink(link, dst) < 0) { /* INTL: Native. */ + return TCL_ERROR; } - case S_IFIFO: { - if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - return CopyFileAtts(src, dst, &srcStatBuf); + break; + } +#endif + case S_IFBLK: + case S_IFCHR: + if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ + srcStatBuf.st_rdev) < 0) { + return TCL_ERROR; } - default: { - return TclUnixCopyFile(src, dst, &srcStatBuf, 0); + return CopyFileAtts(src, dst, &srcStatBuf); + case S_IFIFO: + if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ + return TCL_ERROR; } + return CopyFileAtts(src, dst, &srcStatBuf); + default: + return TclUnixCopyFile(src, dst, &srcStatBuf, 0); } return TCL_OK; } @@ -453,31 +442,30 @@ DoCopyFile(src, dst) /* *---------------------------------------------------------------------- * - * TclUnixCopyFile - + * TclUnixCopyFile - * - * Helper function for TclpCopyFile. Copies one regular file, - * using read() and write(). + * Helper function for TclpCopyFile. Copies one regular file, using + * read() and write(). * * Results: * A standard Tcl result. * * Side effects: - * A file is copied. Dst will be overwritten if it exists. + * A file is copied. Dst will be overwritten if it exists. * *---------------------------------------------------------------------- */ -int -TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) +int +TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) CONST char *src; /* Pathname of file to copy (native). */ CONST char *dst; /* Pathname of file to create/overwrite * (native). */ CONST Tcl_StatBuf *statBufPtr; /* Used to determine mode and blocksize. */ - int dontCopyAtts; /* if flag set, don't copy attributes. */ + int dontCopyAtts; /* If flag set, don't copy attributes. */ { - int srcFd; - int dstFd; + int srcFd, dstFd; unsigned blockSize; /* Optimal I/O blocksize for filesystem */ char *buffer; /* Data buffer for copy */ size_t nread; @@ -488,30 +476,37 @@ TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) #define BINMODE #endif - if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native. */ + if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native */ return TCL_ERROR; } - dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native. */ + dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native */ statBufPtr->st_mode); if (dstFd < 0) { - close(srcFd); + close(srcFd); return TCL_ERROR; } + /* + * Try to work out the best size of buffer to use for copying. If we + * can't, it's no big deal as we can just use a (32-bit) page, since + * that's likely to be fairly efficient anyway. + */ + #ifdef HAVE_ST_BLKSIZE blockSize = statBufPtr->st_blksize; #else #ifndef NO_FSTATFS { struct statfs fs; + if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) { blockSize = fs.f_bsize; } else { blockSize = 4096; } } -#else +#else blockSize = 4096; #endif #endif @@ -527,7 +522,7 @@ TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) break; } } - + ckfree(buffer); close(srcFd); if ((close(dstFd) != 0) || (nread == -1)) { @@ -536,9 +531,8 @@ TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) } if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { /* - * The copy succeeded, but setting the permissions failed, so be in - * a consistent state, we remove the file that was created by the - * copy. + * The copy succeeded, but setting the permissions failed, so be in a + * consistent state, we remove the file that was created by the copy. */ unlink(dst); /* INTL: Native. */ @@ -552,24 +546,24 @@ TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) * * TclpObjDeleteFile, TclpDeleteFile -- * - * Removes a single file (not a directory). + * Removes a single file (not a directory). * * Results: - * If the file was successfully deleted, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: + * If the file was successfully deleted, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: a parent directory can't be read and/or written. + * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * * Side effects: - * The file is deleted, even if it is read-only. + * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ -int +int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { @@ -578,7 +572,7 @@ TclpObjDeleteFile(pathPtr) int TclpDeleteFile(path) - CONST char *path; /* Pathname of file to be removed (native). */ + CONST char *path; /* Pathname of file to be removed (native). */ { if (unlink(path) != 0) { /* INTL: Native. */ return TCL_ERROR; @@ -591,28 +585,28 @@ TclpDeleteFile(path) * * TclpCreateDirectory, DoCreateDirectory -- * - * Creates the specified directory. All parent directories of the - * specified directory must already exist. The directory is - * automatically created with permissions so that user can access - * the new directory and create new files or subdirectories in it. + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is automatically + * created with permissions so that user can access the new directory and + * create new files or subdirectories in it. * * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: + * If the directory was successfully created, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: * - * EACCES: a parent directory can't be read and/or written. + * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: - * A directory is created with the current umask, except that - * permission for u+rwx will always be added. + * A directory is created with the current umask, except that permission + * for u+rwx will always be added. * *--------------------------------------------------------------------------- */ -int +int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { @@ -645,28 +639,26 @@ DoCreateDirectory(path) * * TclpObjCopyDirectory -- * - * Recursively copies a directory. The target directory dst must - * not already exist. Note that this function does not merge two - * directory hierarchies, even if the target directory is an an - * empty directory. + * Recursively copies a directory. The target directory dst must not + * already exist. Note that this function does not merge two directory + * hierarchies, even if the target directory is an an empty directory. * * Results: - * If the directory was successfully copied, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. See TclpObjCreateDirectory and - * TclpObjCopyFile for a description of possible values for errno. + * If the directory was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * See TclpObjCreateDirectory and TclpObjCopyFile for a description of + * possible values for errno. * * Side effects: - * An exact copy of the directory hierarchy src will be created - * with the name dst. If an error occurs, the error will - * be returned immediately, and remaining files will not be - * processed. + * An exact copy of the directory hierarchy src will be created with the + * name dst. If an error occurs, the error will be returned immediately, + * and remaining files will not be processed. * *--------------------------------------------------------------------------- */ -int +int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; @@ -676,18 +668,18 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_DString srcString, dstString; int ret; Tcl_Obj *transPtr; - + transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), - -1, &srcString); + Tcl_UtfToExternalDString(NULL, + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), + -1, &srcString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), - -1, &dstString); + Tcl_UtfToExternalDString(NULL, + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), + -1, &dstString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -714,25 +706,25 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) * Removes directory (and its contents, if the recursive flag is set). * * Results: - * If the directory was successfully removed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. Some possible values for errno are: + * If the directory was successfully removed, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * Some possible values for errno are: * - * EACCES: path directory can't be read and/or written. + * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * Side effects: - * Directory removed. If an error occurs, the error will be returned + * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *--------------------------------------------------------------------------- */ - -int + +int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; @@ -743,9 +735,9 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), - -1, &pathString); + Tcl_UtfToExternalDString(NULL, + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), + -1, &pathString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } @@ -764,32 +756,35 @@ static int DoRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_DString *pathPtr; /* Pathname of directory to be removed * (native). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int recursive; /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { CONST char *path; mode_t oldPerm = 0; int result; - + path = Tcl_DStringValue(pathPtr); - + if (recursive != 0) { - /* We should try to change permissions so this can be deleted */ + /* + * We should try to change permissions so this can be deleted. + */ + Tcl_StatBuf statBuf; int newPerm; if (TclOSstat(path, &statBuf) == 0) { oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF); } - + newPerm = oldPerm | (64+128+256); chmod(path, (mode_t) newPerm); } - + if (rmdir(path) == 0) { /* INTL: Native. */ return TCL_OK; } @@ -804,46 +799,49 @@ DoRemoveDirectory(pathPtr, recursive, errorPtr) } result = TCL_ERROR; } - + /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. + * The directory is nonempty, but the recursive flag has been specified, + * so we recursively remove all the files in the directory. */ if (result == TCL_OK) { result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1); } - + if ((result != TCL_OK) && (recursive != 0)) { - /* Try to restore permissions */ - chmod(path, oldPerm); + /* + * Try to restore permissions. + */ + + chmod(path, oldPerm); } return result; } - + /* *--------------------------------------------------------------------------- * * TraverseUnixTree -- * - * Traverse directory tree specified by sourcePtr, calling the function - * traverseProc for each file and directory encountered. If destPtr - * is non-null, each of name in the sourcePtr directory is appended to - * the directory specified by destPtr and passed as the second argument - * to traverseProc() . + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr is + * non-null, each of name in the sourcePtr directory is appended to the + * directory specified by destPtr and passed as the second argument to + * traverseProc(). * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * None caused by TraverseUnixTree, however the user specified - * traverseProc() may change state. If an error occurs, the error will - * be returned immediately, and remaining files will not be processed. + * None caused by TraverseUnixTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will be + * returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ -static int +static int TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) TraversalProc *traverseProc;/* Function to call for every file and * directory in source hierarchy. */ @@ -851,15 +849,16 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) * traversed (native). */ Tcl_DString *targetPtr; /* Pathname of directory to traverse in * parallel with source directory (native). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ int doRewind; /* Flag indicating that to ensure complete * traversal of source hierarchy, the readdir * loop should be rewound whenever * traverseProc has returned TCL_OK; this is * required when traverseProc modifies the - * source hierarchy, e.g. by deleting files. */ + * source hierarchy, e.g. by deleting + * files. */ { Tcl_StatBuf statBuf; CONST char *source, *errfile; @@ -888,7 +887,7 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) } dirPtr = opendir(source); /* INTL: Native. */ if (dirPtr == NULL) { - /* + /* * Can't read directory */ @@ -901,9 +900,9 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) closedir(dirPtr); return result; } - + Tcl_DStringAppend(sourcePtr, "/", 1); - sourceLen = Tcl_DStringLength(sourcePtr); + sourceLen = Tcl_DStringLength(sourcePtr); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, "/", 1); @@ -912,17 +911,17 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) do { needRewind = 0; - while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */ + while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native */ if ((dirEntPtr->d_name[0] == '.') && ((dirEntPtr->d_name[1] == '\0') || (strcmp(dirEntPtr->d_name, "..") == 0))) { continue; } - - /* + + /* * Append name after slash, and recurse on the file. */ - + Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); @@ -935,11 +934,11 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) } else { needRewind = doRewind; } - + /* * Remove name after slash. */ - + Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen); @@ -950,7 +949,7 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) } } while (needRewind); closedir(dirPtr); - + /* * Strip off the trailing slash we added */ @@ -962,21 +961,22 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) if (result == TCL_OK) { /* - * Call traverseProc() on a directory after visiting all the - * files in that directory. + * Call traverseProc() on a directory after visiting all the files in + * that directory. */ result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD, errorPtr); } - end: + + end: if (errfile != NULL) { if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); } result = TCL_ERROR; } - + return result; } @@ -985,56 +985,55 @@ TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind) * * TraversalCopy * - * Called from TraverseUnixTree in order to execute a recursive copy - * of a directory. + * Called from TraverseUnixTree in order to execute a recursive copy of a + * directory. * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * The file or directory src may be copied to dst, depending on - * the value of type. - * + * The file or directory src may be copied to dst, depending on the value + * of type. + * *---------------------------------------------------------------------- */ -static int -TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) +static int +TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname to copy (native). */ Tcl_DString *dstPtr; /* Destination pathname of copy (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ - int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { switch (type) { - case DOTREE_F: - if (DoCopyFile(Tcl_DStringValue(srcPtr), - Tcl_DStringValue(dstPtr)) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { - return TCL_OK; - } - break; + case DOTREE_F: + if (DoCopyFile(Tcl_DStringValue(srcPtr), + Tcl_DStringValue(dstPtr)) == TCL_OK) { + return TCL_OK; + } + break; - case DOTREE_POSTD: - if (CopyFileAtts(Tcl_DStringValue(srcPtr), - Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { - return TCL_OK; - } - break; + case DOTREE_PRED: + if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_POSTD: + if (CopyFileAtts(Tcl_DStringValue(srcPtr), + Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { + return TCL_OK; + } + break; } /* - * There shouldn't be a problem with src, because we already checked it - * to get here. + * There shouldn't be a problem with src, because we already checked it to + * get here. */ if (errorPtr != NULL) { @@ -1049,47 +1048,44 @@ TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) * * TraversalDelete -- * - * Called by procedure TraverseUnixTree for every file and directory - * that it encounters in a directory hierarchy. This procedure unlinks - * files, and removes directories after all the containing files - * have been processed. + * Called by procedure TraverseUnixTree for every file and directory that + * it encounters in a directory hierarchy. This procedure unlinks files, + * and removes directories after all the containing files have been + * processed. * * Results: - * Standard Tcl result. + * Standard Tcl result. * * Side effects: - * Files or directory specified by src will be deleted. + * Files or directory specified by src will be deleted. * *---------------------------------------------------------------------- */ static int -TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) +TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname (native). */ Tcl_DString *ignore; /* Destination pathname (not used). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ - int type; /* Reason for call - see TraverseUnixTree(). */ - Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free - * DString filled with UTF-8 name of file - * causing error. */ + int type; /* Reason for call - see TraverseUnixTree(). */ + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ { switch (type) { - case DOTREE_F: { - if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { - return TCL_OK; - } - break; + case DOTREE_F: + if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { + return TCL_OK; } - case DOTREE_PRED: { + break; + case DOTREE_PRED: + return TCL_OK; + case DOTREE_POSTD: + if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { return TCL_OK; } - case DOTREE_POSTD: { - if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { - return TCL_OK; - } - break; - } + break; } if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), @@ -1103,22 +1099,21 @@ TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) * * CopyFileAtts -- * - * Copy the file attributes such as owner, group, permissions, - * and modification date from one file to another. + * Copy the file attributes such as owner, group, permissions, and + * modification date from one file to another. * * Results: * Standard Tcl result. * * Side effects: - * user id, group id, permission bits, last modification time, and - * last access time are updated in the new file to reflect the - * old file. + * User id, group id, permission bits, last modification time, and last + * access time are updated in the new file to reflect the old file. * *--------------------------------------------------------------------------- */ static int -CopyFileAtts(src, dst, statBufPtr) +CopyFileAtts(src, dst, statBufPtr) CONST char *src; /* Path name of source file (native). */ CONST char *dst; /* Path name of target file (native). */ CONST Tcl_StatBuf *statBufPtr; @@ -1126,19 +1121,18 @@ CopyFileAtts(src, dst, statBufPtr) { struct utimbuf tval; mode_t newMode; - + newMode = statBufPtr->st_mode & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); - - /* - * Note that if you copy a setuid file that is owned by someone - * else, and you are not root, then the copy will be setuid to you. - * The most correct implementation would probably be to have the - * copy not setuid to anyone if the original file was owned by - * someone else, but this corner case isn't currently handled. - * It would require another lstat(), or getuid(). + + /* + * Note that if you copy a setuid file that is owned by someone else, and + * you are not root, then the copy will be setuid to you. The most correct + * implementation would probably be to have the copy not setuid to anyone + * if the original file was owned by someone else, but this corner case + * isn't currently handled. It would require another lstat(), or getuid(). */ - + if (chmod(dst, newMode)) { /* INTL: Native. */ newMode &= ~(S_ISUID | S_ISGID); if (chmod(dst, newMode)) { /* INTL: Native. */ @@ -1146,8 +1140,8 @@ CopyFileAtts(src, dst, statBufPtr) } } - tval.actime = statBufPtr->st_atime; - tval.modtime = statBufPtr->st_mtime; + tval.actime = statBufPtr->st_atime; + tval.modtime = statBufPtr->st_mtime; if (utime(dst, &tval)) { /* INTL: Native. */ return TCL_ERROR; @@ -1164,15 +1158,15 @@ CopyFileAtts(src, dst, statBufPtr) * * GetGroupAttribute * - * Gets the group attribute of a file. + * Gets the group attribute of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ @@ -1188,10 +1182,10 @@ GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1205,7 +1199,7 @@ GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_DString ds; CONST char *utf; - utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, -1); Tcl_DStringFree(&ds); } @@ -1218,15 +1212,15 @@ GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) * * GetOwnerAttribute * - * Gets the owner attribute of a file. + * Gets the owner attribute of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ @@ -1242,10 +1236,10 @@ GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1259,7 +1253,7 @@ GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_DString ds; CONST char *utf; - utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); + utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } @@ -1272,15 +1266,15 @@ GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) * * GetPermissionsAttribute * - * Gets the group attribute of a file. + * Gets the group attribute of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. The object will have ref count 0. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. The object will have ref count 0. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ @@ -1296,10 +1290,10 @@ GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1309,7 +1303,7 @@ GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); *attributePtrPtr = Tcl_NewStringObj(returnString, -1); - + return TCL_OK; } @@ -1318,23 +1312,23 @@ GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) * * SetGroupAttribute -- * - * Sets the group of the file to the specified group. + * Sets the group of the file to the specified group. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * As above. - * + * As above. + * *--------------------------------------------------------------------------- */ static int SetGroupAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New group for file. */ + Tcl_Interp *interp; /* The interp for error reporting. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New group for file. */ { long gid; int result; @@ -1356,7 +1350,7 @@ SetGroupAttribute(interp, objIndex, fileName, attributePtr) endgrent(); if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", - Tcl_GetString(fileName), "\": group \"", + Tcl_GetString(fileName), "\": group \"", string, "\" does not exist", (char *) NULL); } @@ -1372,11 +1366,11 @@ SetGroupAttribute(interp, objIndex, fileName, attributePtr) if (result != 0) { if (interp != NULL) { Tcl_AppendResult(interp, "could not set group for file \"", - Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; - } + } return TCL_OK; } @@ -1385,23 +1379,23 @@ SetGroupAttribute(interp, objIndex, fileName, attributePtr) * * SetOwnerAttribute -- * - * Sets the owner of the file to the specified owner. + * Sets the owner of the file to the specified owner. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * As above. - * + * As above. + * *--------------------------------------------------------------------------- */ static int SetOwnerAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp for error reporting. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* New owner for file. */ + Tcl_Interp *interp; /* The interp for error reporting. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* New owner for file. */ { long uid; int result; @@ -1435,7 +1429,7 @@ SetOwnerAttribute(interp, objIndex, fileName, attributePtr) if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set owner for file \"", + Tcl_AppendResult(interp, "could not set owner for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1449,23 +1443,23 @@ SetOwnerAttribute(interp, objIndex, fileName, attributePtr) * * SetPermissionsAttribute * - * Sets the file to the given permission. + * Sets the file to the given permission. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * The permission of the file is changed. - * + * The permission of the file is changed. + * *--------------------------------------------------------------------------- */ static int SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* The attribute to set. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* The attribute to set. */ { long mode; mode_t newMode; @@ -1475,8 +1469,9 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) /* * First try if the string is a number */ + if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { - newMode = (mode_t) (mode & 0x00007FFF); + newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; char *modeStringPtr = Tcl_GetString(attributePtr); @@ -1484,13 +1479,14 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) /* * Try the forms "rwxrwxrwx" and "ugo=rwx" * - * We get the current mode of the file, in order to allow for - * ug+-=rwx style chmod strings. + * We get the current mode of the file, in order to allow for ug+-=rwx + * style chmod strings. */ + result = TclpObjStat(fileName, &buf); if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1511,7 +1507,7 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) result = chmod(native, newMode); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set permissions for file \"", + Tcl_AppendResult(interp, "could not set permissions for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1552,9 +1548,9 @@ TclpObjListVolumes(void) * * GetModeFromPermString -- * - * This procedure is invoked to process the "file permissions" - * Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "file permissions" Tcl + * command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1572,78 +1568,79 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) mode_t *modePtr; /* pointer to the mode value */ { mode_t newMode; - mode_t oldMode; /* Storage for the value of the old mode - * (that is passed in), to allow for the - * chmod style manipulation */ + mode_t oldMode; /* Storage for the value of the old mode (that + * is passed in), to allow for the chmod style + * manipulation. */ int i,n, who, op, what, op_found, who_found; /* * We start off checking for an "rwxrwxrwx" style permissions string */ + if (strlen(modeStringPtr) != 9) { - goto chmodStyleCheck; + goto chmodStyleCheck; } newMode = 0; for (i = 0; i < 9; i++) { switch (*(modeStringPtr+i)) { - case 'r': - if ((i%3) != 0) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 'w': - if ((i%3) != 1) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 'x': - if ((i%3) != 2) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - break; - case 's': - if (((i%3) != 2) || (i > 5)) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - newMode |= (1<<(11-(i/3))); - break; - case 'S': - if (((i%3) != 2) || (i > 5)) { - goto chmodStyleCheck; - } - newMode |= (1<<(11-(i/3))); - break; - case 't': - if (i != 8) { - goto chmodStyleCheck; - } - newMode |= (1<<(8-i)); - newMode |= (1<<9); - break; - case 'T': - if (i != 8) { - goto chmodStyleCheck; - } - newMode |= (1<<9); - break; - case '-': - break; - default: - /* - * Oops, not what we thought it was, so go on - */ + case 'r': + if ((i%3) != 0) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + break; + case 'w': + if ((i%3) != 1) { goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + break; + case 'x': + if ((i%3) != 2) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + break; + case 's': + if (((i%3) != 2) || (i > 5)) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + newMode |= (1<<(11-(i/3))); + break; + case 'S': + if (((i%3) != 2) || (i > 5)) { + goto chmodStyleCheck; + } + newMode |= (1<<(11-(i/3))); + break; + case 't': + if (i != 8) { + goto chmodStyleCheck; + } + newMode |= (1<<(8-i)); + newMode |= (1<<9); + break; + case 'T': + if (i != 8) { + goto chmodStyleCheck; + } + newMode |= (1<<9); + break; + case '-': + break; + default: + /* + * Oops, not what we thought it was, so go on + */ + goto chmodStyleCheck; } } *modePtr = newMode; return TCL_OK; - chmodStyleCheck: + chmodStyleCheck: /* * We now check for an "ugoa+-=rwxst" style permissions string */ @@ -1655,18 +1652,18 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) if (!who_found) { /* who */ switch (*(modeStringPtr+n+i)) { - case 'u' : - who |= 0x9c0; - continue; - case 'g' : - who |= 0x438; - continue; - case 'o' : - who |= 0x207; - continue; - case 'a' : - who |= 0xfff; - continue; + case 'u': + who |= 0x9c0; + continue; + case 'g': + who |= 0x438; + continue; + case 'o': + who |= 0x207; + continue; + case 'a': + who |= 0xfff; + continue; } } who_found = 1; @@ -1676,43 +1673,43 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) if (!op_found) { /* op */ switch (*(modeStringPtr+n+i)) { - case '+' : - op = 1; - op_found = 1; - continue; - case '-' : - op = 2; - op_found = 1; - continue; - case '=' : - op = 3; - op_found = 1; - continue; - default : - return TCL_ERROR; - } - } - /* what */ - switch (*(modeStringPtr+n+i)) { - case 'r' : - what |= 0x124; - continue; - case 'w' : - what |= 0x92; + case '+': + op = 1; + op_found = 1; continue; - case 'x' : - what |= 0x49; + case '-': + op = 2; + op_found = 1; continue; - case 's' : - what |= 0xc00; + case '=': + op = 3; + op_found = 1; continue; - case 't' : - what |= 0x200; - continue; - case ',' : - break; - default : + default: return TCL_ERROR; + } + } + /* what */ + switch (*(modeStringPtr+n+i)) { + case 'r': + what |= 0x124; + continue; + case 'w': + what |= 0x92; + continue; + case 'x': + what |= 0x49; + continue; + case 's': + what |= 0xc00; + continue; + case 't': + what |= 0x200; + continue; + case ',': + break; + default: + return TCL_ERROR; } if (*(modeStringPtr+n+i) == ',') { i++; @@ -1720,15 +1717,15 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) } } switch (op) { - case 1 : - *modePtr = oldMode | (who & what); - continue; - case 2 : - *modePtr = oldMode & ~(who & what); - continue; - case 3 : - *modePtr = (oldMode & ~who) | (who & what); - continue; + case 1 : + *modePtr = oldMode | (who & what); + continue; + case 2 : + *modePtr = oldMode & ~(who & what); + continue; + case 3 : + *modePtr = (oldMode & ~who) | (who & what); + continue; } } return TCL_OK; @@ -1739,21 +1736,21 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) * * TclpObjNormalizePath -- * - * This function scans through a path specification and replaces - * it, in place, with a normalized version. A normalized version - * is one in which all symlinks in the path are replaced with - * their expanded form (except a symlink at the very end of the - * path). + * This function scans through a path specification and replaces it, in + * place, with a normalized version. A normalized version is one in which + * all symlinks in the path are replaced with their expanded form (except + * a symlink at the very end of the path). * * Results: - * The new 'nextCheckpoint' value, giving as far as we could - * understand in the path. + * The new 'nextCheckpoint' value, giving as far as we could understand + * in the path. * * Side effects: * The pathPtr string, is modified. * *--------------------------------------------------------------------------- */ + int TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_Interp *interp; @@ -1767,122 +1764,166 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) #ifndef NO_REALPATH char normPath[MAXPATHLEN]; Tcl_DString ds; - CONST char *nativePath; + CONST char *nativePath; #endif - /* - * We add '1' here because if nextCheckpoint is zero we know - * that '/' exists, and if it isn't zero, it must point at - * a directory separator which we also know exists. + + /* + * We add '1' here because if nextCheckpoint is zero we know that '/' + * exists, and if it isn't zero, it must point at a directory separator + * which we also know exists. */ + currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } #ifndef NO_REALPATH - /* For speed, try to get the entire path in one go */ + /* + * For speed, try to get the entire path in one go. + */ + if (nextCheckpoint == 0) { - char *lastDir = strrchr(currentPathEndPosition, '/'); + char *lastDir = strrchr(currentPathEndPosition, '/'); + if (lastDir != NULL) { - nativePath = Tcl_UtfToExternalDString(NULL, path, - lastDir - path, &ds); + nativePath = Tcl_UtfToExternalDString(NULL, path, + lastDir-path, &ds); if (Realpath(nativePath, normPath) != NULL) { nextCheckpoint = lastDir - path; goto wholeStringOk; } } } - /* Else do it the slow way */ + + /* + * Else do it the slow way. + */ #endif - + while (1) { cur = *currentPathEndPosition; if ((cur == '/') && (path != currentPathEndPosition)) { - /* Reached directory separator */ + /* + * Reached directory separator. + */ + Tcl_DString ds; CONST char *nativePath; int accessOk; - nativePath = Tcl_UtfToExternalDString(NULL, path, + nativePath = Tcl_UtfToExternalDString(NULL, path, currentPathEndPosition - path, &ds); accessOk = access(nativePath, F_OK); Tcl_DStringFree(&ds); + if (accessOk != 0) { - /* File doesn't exist */ + /* + * File doesn't exist. + */ + break; } - /* Update the acceptable point */ + + /* + * Update the acceptable point. + */ + nextCheckpoint = currentPathEndPosition - path; } else if (cur == 0) { - /* Reached end of string */ + /* + * Reached end of string. + */ + break; } currentPathEndPosition++; } - /* - * We should really now convert this to a canonical path. We do - * that with 'realpath' if we have it available. Otherwise we could - * step through every single path component, checking whether it is a - * symlink, but that would be a lot of work, and most modern OSes - * have 'realpath'. + + /* + * We should really now convert this to a canonical path. We do that with + * 'realpath' if we have it available. Otherwise we could step through + * every single path component, checking whether it is a symlink, but that + * would be a lot of work, and most modern OSes have 'realpath'. */ + #ifndef NO_REALPATH - /* - * If we only had '/foo' or '/' then we never increment nextCheckpoint - * and we don't need or want to go through 'Realpath'. Also, on some + /* + * If we only had '/foo' or '/' then we never increment nextCheckpoint and + * we don't need or want to go through 'Realpath'. Also, on some * platforms, passing an empty string to 'Realpath' will give us the * normalized pwd, which is not what we want at all! */ - if (nextCheckpoint == 0) return 0; - + + if (nextCheckpoint == 0) { + return 0; + } + nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds); if (Realpath(nativePath, normPath) != NULL) { int newNormLen; - wholeStringOk: + + wholeStringOk: newNormLen = strlen(normPath); if ((newNormLen == Tcl_DStringLength(&ds)) && (strcmp(normPath, nativePath) == 0)) { - /* String is unchanged */ + /* + * String is unchanged. + */ + Tcl_DStringFree(&ds); + /* - * Enable this to have the native FS claim normalization of - * the whole path for existing files. That would permit the - * caller to declare normalization complete without calls to - * additional filesystems. Saving lots of calls is probably - * worth the extra access() time here. When no other FS's - * are registered though, things are less clear. + * Enable this to have the native FS claim normalization of the + * whole path for existing files. That would permit the caller to + * declare normalization complete without calls to additional + * filesystems. Saving lots of calls is probably worth the extra + * access() time here. When no other FS's are registered though, + * things are less clear. * if (0 == access(normPath, F_OK)) { return pathLen; } */ + return nextCheckpoint; } - - /* - * Free up the native path and put in its place the - * converted, normalized path. + + /* + * Free up the native path and put in its place the converted, + * normalized path. */ + Tcl_DStringFree(&ds); Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds); if (path[nextCheckpoint] != '\0') { - /* not at end, append remaining path */ + /* + * Not at end, append remaining path. + */ + int normLen = Tcl_DStringLength(&ds); + Tcl_DStringAppend(&ds, path + nextCheckpoint, pathLen - nextCheckpoint); - /* - * We recognise up to and including the directory - * separator. - */ + + /* + * We recognise up to and including the directory separator. + */ + nextCheckpoint = normLen + 1; } else { - /* We recognise the whole string */ + /* + * We recognise the whole string. + */ + nextCheckpoint = Tcl_DStringLength(&ds); } - /* + + /* * Overwrite with the normalized path. */ + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); } @@ -1898,41 +1939,41 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) * * GetReadOnlyAttribute * - * Gets the readonly attribute (user immutable flag) of a file. + * Gets the readonly attribute (user immutable flag) of a file. * * Results: - * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr - * if there is no error. The object will have ref count 0. + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr if there + * is no error. The object will have ref count 0. * * Side effects: - * A new object is allocated. - * + * A new object is allocated. + * *---------------------------------------------------------------------- */ static int GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; int result; result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } - *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags & UF_IMMUTABLE) != 0); - + *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags&UF_IMMUTABLE) != 0); + return TCL_OK; } @@ -1941,23 +1982,23 @@ GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr) * * SetReadOnlyAttribute * - * Sets the readonly attribute (user immutable flag) of a file. + * Sets the readonly attribute (user immutable flag) of a file. * * Results: - * Standard TCL result. + * Standard TCL result. * * Side effects: - * The readonly attribute of the file is changed. - * + * The readonly attribute of the file is changed. + * *--------------------------------------------------------------------------- */ static int SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) - Tcl_Interp *interp; /* The interp we are using for errors. */ - int objIndex; /* The index of the attribute. */ - Tcl_Obj *fileName; /* The name of the file (UTF-8). */ - Tcl_Obj *attributePtr; /* The attribute to set. */ + Tcl_Interp *interp; /* The interp we are using for errors. */ + int objIndex; /* The index of the attribute. */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *attributePtr; /* The attribute to set. */ { Tcl_StatBuf statBuf; int result; @@ -1965,14 +2006,14 @@ SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) CONST char *native; if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } result = TclpObjStat(fileName, &statBuf); - + if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1980,16 +2021,16 @@ SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) } if (readonly) { - statBuf.st_flags |= UF_IMMUTABLE; + statBuf.st_flags |= UF_IMMUTABLE; } else { - statBuf.st_flags &= ~UF_IMMUTABLE; + statBuf.st_flags &= ~UF_IMMUTABLE; } native = Tcl_FSGetNativePath(fileName); result = chflags(native, statBuf.st_flags); /* INTL: Native. */ if (result != 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not set flags for file \"", + Tcl_AppendResult(interp, "could not set flags for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); } @@ -1998,3 +2039,11 @@ SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) return TCL_OK; } #endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 9ae8129..b26691d 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1,29 +1,28 @@ -/* +/* * tclUnixFile.c -- * - * This file contains wrappers around UNIX file handling functions. - * These wrappers mask differences between Windows and UNIX. + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.44 2004/12/01 23:18:55 dgp Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.45 2005/07/20 23:16:00 dkf Exp $ */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); - /* *--------------------------------------------------------------------------- * * TclpFindExecutable -- * - * This procedure computes the absolute path name of the current + * This function computes the absolute path name of the current * application, given its argv[0] value. * * Results: @@ -54,8 +53,8 @@ TclpFindExecutable(argv0) for (p = name; *p != '\0'; p++) { if (*p == '/') { /* - * The name contains a slash, so use the name directly - * without doing a path search. + * The name contains a slash, so use the name directly without + * doing a path search. */ goto gotName; @@ -65,8 +64,8 @@ TclpFindExecutable(argv0) p = getenv("PATH"); /* INTL: Native. */ if (p == NULL) { /* - * There's no PATH environment variable; use the default that - * is used by sh. + * There's no PATH environment variable; use the default that is used + * by sh. */ p = ":/bin:/usr/bin"; @@ -79,13 +78,12 @@ TclpFindExecutable(argv0) } /* - * Search through all the directories named in the PATH variable - * to see if argv[0] is in one of them. If so, use that file - * name. + * Search through all the directories named in the PATH variable to see if + * argv[0] is in one of them. If so, use that file name. */ while (1) { - while (isspace(UCHAR(*p))) { /* INTL: BUG */ + while (isspace(UCHAR(*p))) { /* INTL: BUG */ p++; } name = p; @@ -127,12 +125,13 @@ TclpFindExecutable(argv0) * If the name starts with "/" then just store it */ -gotName: + gotName: #ifdef DJGPP - if (name[1] == ':') { + if (name[1] == ':') #else - if (name[0] == '/') { + if (name[0] == '/') #endif + { encoding = Tcl_GetEncoding(NULL, NULL); Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); TclSetObjNameOfExecutable( @@ -142,9 +141,9 @@ gotName: } /* - * The name is relative to the current working directory. First - * strip off a leading "./", if any, then add the full path name of - * the current working directory. + * The name is relative to the current working directory. First strip off + * a leading "./", if any, then add the full path name of the current + * working directory. */ if ((name[0] == '.') && (name[1] == '/')) { @@ -168,12 +167,13 @@ gotName: Tcl_DStringFree(&nameString); encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, &utfName); + Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, + &utfName); TclSetObjNameOfExecutable( Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); Tcl_DStringFree(&utfName); - -done: + + done: Tcl_DStringFree(&buffer); } @@ -182,24 +182,25 @@ done: * * TclpMatchInDirectory -- * - * This routine is used by the globbing code to search a - * directory for all files which match a given pattern. + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. * - * Results: - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Errors are left in interp, good - * results are lappended to resultPtr (which must be a valid object) + * Results: + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * [lappend]ed to resultPtr (which must be a valid object). * * Side effects: * None. * - *---------------------------------------------------------------------- */ + *---------------------------------------------------------------------- + */ int TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive errors. */ Tcl_Obj *resultPtr; /* List object to lappend results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory @@ -209,7 +210,10 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Obj *fileNamePtr; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { - /* The native filesystem never adds mounts */ + /* + * The native filesystem never adds mounts. + */ + return TCL_OK; } @@ -217,9 +221,12 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) if (fileNamePtr == NULL) { return TCL_ERROR; } - + if (pattern == NULL || (*pattern == '\0')) { - /* Match a file directly */ + /* + * Match a file directly. + */ + native = (CONST char*) Tcl_FSGetNativePath(pathPtr); if (NativeMatchType(native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); @@ -234,26 +241,30 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) int matchHidden; int nativeDirLen; Tcl_StatBuf statBuf; - Tcl_DString ds; /* native encoding of dir */ - Tcl_DString dsOrig; /* utf-8 encoding of dir */ + Tcl_DString ds; /* native encoding of dir */ + Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); - + /* * Make sure that the directory part of the name really is a - * directory. If the directory name is "", use the name "." - * instead, because some UNIX systems don't treat "" like "." - * automatically. Keep the "" for use in generating file names, - * otherwise "glob foo.c" would return "./foo.c". + * directory. If the directory name is "", use the name "." instead, + * because some UNIX systems don't treat "" like "." automatically. + * Keep the "" for use in generating file names, otherwise "glob + * foo.c" would return "./foo.c". */ if (dirLength == 0) { dirName = "."; } else { dirName = Tcl_DStringValue(&dsOrig); - /* Make sure we have a trailing directory delimiter */ + + /* + * Make sure we have a trailing directory delimiter. + */ + if (dirName[dirLength-1] != '/') { dirName = Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; @@ -291,18 +302,20 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) /* * Check to see if -type or the pattern requests hidden files. */ - matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) || - ((pattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.')))); - while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ + matchHidden = ((types && (types->perm & TCL_GLOB_PERM_HIDDEN)) + || ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.')))); + + while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ Tcl_DString utfDs; CONST char *utfname; - /* - * Skip this file if it doesn't agree with the hidden - * parameters requested by the user (via -type or pattern). + /* + * Skip this file if it doesn't agree with the hidden parameters + * requested by the user (via -type or pattern). */ + if (*entryPtr->d_name == '.') { if (!matchHidden) continue; } else { @@ -311,11 +324,11 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) /* * Now check to see if the file matches, according to both type - * and pattern. If so, add the file to the result. + * and pattern. If so, add the file to the result. */ - utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, - -1, &utfDs); + utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, + &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; @@ -325,9 +338,9 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) typeOk = NativeMatchType(native, types); } if (typeOk) { - Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, - Tcl_DStringLength(&utfDs))); + Tcl_DStringLength(&utfDs))); } } Tcl_DStringFree(&utfDs); @@ -340,44 +353,45 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) return TCL_OK; } } -static int + +static int NativeMatchType( - CONST char* nativeEntry, /* Native path to check */ - Tcl_GlobTypeData *types) /* Type description to match against */ + CONST char* nativeEntry, /* Native path to check. */ + Tcl_GlobTypeData *types) /* Type description to match against. */ { Tcl_StatBuf buf; if (types == NULL) { - /* - * Simply check for the file's existence, but do it - * with lstat, in case it is a link to a file which - * doesn't exist (since that case would not show up - * if we used 'access' or 'stat') + /* + * Simply check for the file's existence, but do it with lstat, in + * case it is a link to a file which doesn't exist (since that case + * would not show up if we used 'access' or 'stat') */ + if (TclOSlstat(nativeEntry, &buf) != 0) { return 0; } } else { if (types->perm != 0) { if (TclOSstat(nativeEntry, &buf) != 0) { - /* - * Either the file has disappeared between the - * 'readdir' call and the 'stat' call, or - * the file is a link to a file which doesn't - * exist (which we could ascertain with - * lstat), or there is some other strange - * problem. In all these cases, we define this - * to mean the file does not match any defined - * permission, and therefore it is not - * added to the list of files to return. + /* + * Either the file has disappeared between the 'readdir' call + * and the 'stat' call, or the file is a link to a file which + * doesn't exist (which we could ascertain with lstat), or + * there is some other strange problem. In all these cases, we + * define this to mean the file does not match any defined + * permission, and therefore it is not added to the list of + * files to return. */ + return 0; } - - /* - * readonly means that there are NO write permissions - * (even for user), but execute is OK for anybody - * OR that the user immutable flag is set (where supported). + + /* + * readonly means that there are NO write permissions (even for + * user), but execute is OK for anybody OR that the user immutable + * flag is set (where supported). */ + if (((types->perm & TCL_GLOB_PERM_RONLY) && #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) !(buf.st_flags & UF_IMMUTABLE) && @@ -395,14 +409,17 @@ NativeMatchType( } if (types->type != 0) { if (types->perm == 0) { - /* We haven't yet done a stat on the file */ + /* + * We haven't yet done a stat on the file. + */ + if (TclOSstat(nativeEntry, &buf) != 0) { - /* - * Posix error occurred. The only ok - * case is if this is a link to a nonexistent - * file, and the user did 'glob -l'. So - * we check that here: + /* + * Posix error occurred. The only ok case is if this is a + * link to a nonexistent file, and the user did 'glob -l'. + * So we check that here: */ + if (types->type & TCL_GLOB_TYPE_LINK) { if (TclOSlstat(nativeEntry, &buf) == 0) { if (S_ISLNK(buf.st_mode)) { @@ -413,26 +430,23 @@ NativeMatchType( return 0; } } + /* * In order bcdpfls as in 'find -t' */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) + + if (((types->type & TCL_GLOB_TYPE_BLOCK)&& S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && S_ISFIFO(buf.st_mode))|| + ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode)) #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) + ||((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode)) #endif /* S_ISSOCK */ ) { - /* Do nothing -- this file is ok */ + /* + * Do nothing - this file is ok. + */ } else { #ifdef S_ISLNK if (types->type & TCL_GLOB_TYPE_LINK) { @@ -455,15 +469,15 @@ NativeMatchType( * * TclpGetUserHome -- * - * This function takes the specified user name and finds their - * home directory. + * This function takes the specified user name and finds their home + * directory. * * Results: * The result is a pointer to a string specifying the user's home * directory, or NULL if the user's home directory could not be - * determined. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * determined. Storage for the result string is allocated in bufferPtr; + * the caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * None. @@ -474,8 +488,8 @@ NativeMatchType( char * TclpGetUserHome(name, bufferPtr) CONST char *name; /* User name for desired home directory. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of user's home directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name of user's home directory. */ { struct passwd *pwPtr; Tcl_DString ds; @@ -484,7 +498,7 @@ TclpGetUserHome(name, bufferPtr) native = Tcl_UtfToExternalDString(NULL, name, -1, &ds); pwPtr = getpwnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); - + if (pwPtr == NULL) { endpwent(); return NULL; @@ -510,10 +524,10 @@ TclpGetUserHome(name, bufferPtr) *--------------------------------------------------------------------------- */ -int +int TclpObjAccess(pathPtr, mode) - Tcl_Obj *pathPtr; /* Path of file to access */ - int mode; /* Permission setting. */ + Tcl_Obj *pathPtr; /* Path of file to access */ + int mode; /* Permission setting. */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { @@ -534,14 +548,14 @@ TclpObjAccess(pathPtr, mode) * See chdir() documentation. * * Side effects: - * See chdir() documentation. + * See chdir() documentation. * *--------------------------------------------------------------------------- */ -int +int TclpObjChdir(pathPtr) - Tcl_Obj *pathPtr; /* Path to new working directory */ + Tcl_Obj *pathPtr; /* Path to new working directory */ { CONST char *path = Tcl_FSGetNativePath(pathPtr); if (path == NULL) { @@ -567,7 +581,7 @@ TclpObjChdir(pathPtr) *---------------------------------------------------------------------- */ -int +int TclpObjLstat(pathPtr, bufPtr) Tcl_Obj *pathPtr; /* Path of file to stat */ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ @@ -583,13 +597,12 @@ TclpObjLstat(pathPtr, bufPtr) * This function replaces the library version of getcwd(). * * Results: - * The input and output are filesystem paths in native form. The - * result is either the given clientData, if the working directory - * hasn't changed, or a new clientData (owned by our caller), - * giving the new native path, or NULL if the current directory - * could not be determined. If NULL is returned, the caller can - * examine the standard posix error codes to determine the cause of - * the problem. + * The input and output are filesystem paths in native form. The result + * is either the given clientData, if the working directory hasn't + * changed, or a new clientData (owned by our caller), giving the new + * native path, or NULL if the current directory could not be determined. + * If NULL is returned, the caller can examine the standard posix error + * codes to determine the cause of the problem. * * Side effects: * None. @@ -604,18 +617,21 @@ TclpGetNativeCwd(clientData) char buffer[MAXPATHLEN+1]; #ifdef USEGETWD - if (getwd(buffer) == NULL) { /* INTL: Native. */ + if (getwd(buffer) == NULL) /* INTL: Native. */ #else - if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ + if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ #endif + { return NULL; } if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) { - /* No change to pwd */ + /* + * No change to pwd. + */ + return clientData; } else { - char *newCd = (char *) ckalloc((unsigned) - (strlen(buffer) + 1)); + char *newCd = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); strcpy(newCd, buffer); return (ClientData) newCd; } @@ -626,17 +642,16 @@ TclpGetNativeCwd(clientData) * * TclpGetCwd -- * - * This function replaces the library version of getcwd(). - * (Obsolete function, only retained for old extensions which - * may call it directly). - * + * This function replaces the library version of getcwd(). (Obsolete + * function, only retained for old extensions which may call it + * directly). + * * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. + * The result is a pointer to a string specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. Storage for + * the result string is allocated in bufferPtr; the caller must call + * Tcl_DStringFree() when the result is no longer needed. * * Side effects: * None. @@ -647,16 +662,17 @@ TclpGetNativeCwd(clientData) CONST char * TclpGetCwd(interp, bufferPtr) Tcl_Interp *interp; /* If non-NULL, used for error reporting. */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name of current directory. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name of current directory. */ { char buffer[MAXPATHLEN+1]; #ifdef USEGETWD - if (getwd(buffer) == NULL) { /* INTL: Native. */ + if (getwd(buffer) == NULL) /* INTL: Native. */ #else - if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */ + if (getcwd(buffer, MAXPATHLEN+1) == NULL) /* INTL: Native. */ #endif + { if (interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", @@ -675,11 +691,11 @@ TclpGetCwd(interp, bufferPtr) * This function replaces the library version of readlink(). * * Results: - * The result is a pointer to a string specifying the contents - * of the symbolic link given by 'path', or NULL if the symbolic - * link could not be read. Storage for the result string is - * allocated in bufferPtr; the caller must call Tcl_DStringFree() - * when the result is no longer needed. + * The result is a pointer to a string specifying the contents of the + * symbolic link given by 'path', or NULL if the symbolic link could not + * be read. Storage for the result string is allocated in bufferPtr; the + * caller must call Tcl_DStringFree() when the result is no longer + * needed. * * Side effects: * See readlink() documentation. @@ -690,8 +706,8 @@ TclpGetCwd(interp, bufferPtr) char * TclpReadlink(path, linkPtr) CONST char *path; /* Path of file to readlink (UTF-8). */ - Tcl_DString *linkPtr; /* Uninitialized or free DString filled - * with contents of link (UTF-8). */ + Tcl_DString *linkPtr; /* Uninitialized or free DString filled with + * contents of link (UTF-8). */ { #ifndef DJGPP char link[MAXPATHLEN]; @@ -702,7 +718,7 @@ TclpReadlink(path, linkPtr) native = Tcl_UtfToExternalDString(NULL, path, -1, &ds); length = readlink(native, link, sizeof(link)); /* INTL: Native. */ Tcl_DStringFree(&ds); - + if (length < 0) { return NULL; } @@ -730,7 +746,7 @@ TclpReadlink(path, linkPtr) *---------------------------------------------------------------------- */ -int +int TclpObjStat(pathPtr, bufPtr) Tcl_Obj *pathPtr; /* Path of file to stat */ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ @@ -743,10 +759,9 @@ TclpObjStat(pathPtr, bufPtr) } } - #ifdef S_IFLNK -Tcl_Obj* +Tcl_Obj* TclpObjLink(pathPtr, toPtr, linkAction) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; @@ -756,42 +771,52 @@ TclpObjLink(pathPtr, toPtr, linkAction) CONST char *src = Tcl_FSGetNativePath(pathPtr); CONST char *target = NULL; if (src == NULL) return NULL; - - /* - * If we're making a symbolic link and the path is relative, - * then we must check whether it exists _relative_ to the - * directory in which the src is found (not relative to the - * current cwd which is just not relevant in this case). - * - * If we're making a hard link, then a relative path is - * just converted to absolute relative to the cwd. + + /* + * If we're making a symbolic link and the path is relative, then we + * must check whether it exists _relative_ to the directory in which + * the src is found (not relative to the current cwd which is just not + * relevant in this case). + * + * If we're making a hard link, then a relative path is just converted + * to absolute relative to the cwd. */ + if ((linkAction & TCL_CREATE_SYMBOLIC_LINK) - && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { + && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) { Tcl_Obj *dirPtr, *absPtr; + dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME); if (dirPtr == NULL) { - return NULL; + return NULL; } absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr); Tcl_IncrRefCount(absPtr); if (Tcl_FSAccess(absPtr, F_OK) == -1) { Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); - /* target doesn't exist */ + + /* + * Target doesn't exist. + */ + errno = ENOENT; - return NULL; + return NULL; } - /* - * Target exists; we'll construct the relative - * path we want below. + + /* + * Target exists; we'll construct the relative path we want below. */ + Tcl_DecrRefCount(absPtr); Tcl_DecrRefCount(dirPtr); } else { target = Tcl_FSGetNativePath(toPtr); if (access(target, F_OK) == -1) { - /* target doesn't exist */ + /* + * Target doesn't exist. + */ + errno = ENOENT; return NULL; } @@ -799,25 +824,31 @@ TclpObjLink(pathPtr, toPtr, linkAction) return NULL; } } - + if (access(src, F_OK) != -1) { - /* src exists */ + /* + * Src exists. + */ + errno = EEXIST; return NULL; } - /* - * Check symbolic link flag first, since we prefer to - * create these. + + /* + * Check symbolic link flag first, since we prefer to create these. */ + if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { int targetLen; Tcl_DString ds; Tcl_Obj *transPtr; - /* + + /* * Now we don't want to link to the absolute, normalized path. - * Relative links are quite acceptable (but links to ~user - * are not -- these must be expanded first). + * Relative links are quite acceptable (but links to ~user are not + * -- these must be expanded first). */ + transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr); if (transPtr == NULL) { return NULL; @@ -825,9 +856,9 @@ TclpObjLink(pathPtr, toPtr, linkAction) target = Tcl_GetStringFromObj(transPtr, &targetLen); target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); Tcl_DecrRefCount(transPtr); - + if (symlink(target, src) != 0) { - toPtr = NULL; + toPtr = NULL; } Tcl_DStringFree(&ds); } else if (linkAction & TCL_CREATE_HARD_LINK) { @@ -846,7 +877,7 @@ TclpObjLink(pathPtr, toPtr, linkAction) int length; Tcl_DString ds; Tcl_Obj *transPtr; - + transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); if (transPtr == NULL) { return NULL; @@ -859,8 +890,8 @@ TclpObjLink(pathPtr, toPtr, linkAction) } Tcl_ExternalToUtfDString(NULL, link, length, &ds); - linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); + linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); if (linkPtr != NULL) { Tcl_IncrRefCount(linkPtr); @@ -868,33 +899,35 @@ TclpObjLink(pathPtr, toPtr, linkAction) return linkPtr; } } - -#endif - +#endif /* S_IFLNK */ /* *--------------------------------------------------------------------------- * * TclpFilesystemPathType -- * - * This function is part of the native filesystem support, and - * returns the path type of the given path. Right now it simply - * returns NULL. In the future it could return specific path - * types, like 'nfs', 'samba', 'FAT32', etc. + * This function is part of the native filesystem support, and returns + * the path type of the given path. Right now it simply returns NULL. In + * the future it could return specific path types, like 'nfs', 'samba', + * 'FAT32', etc. * * Results: - * NULL at present. + * NULL at present. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + Tcl_Obj* TclpFilesystemPathType(pathPtr) Tcl_Obj* pathPtr; { - /* All native paths are of the same type */ + /* + * All native paths are of the same type. + */ + return NULL; } @@ -903,39 +936,39 @@ TclpFilesystemPathType(pathPtr) * * TclpNativeToNormalized -- * - * Convert native format to a normalized path object, with refCount - * of zero. - * - * Currently assumes all native paths are actually normalized - * already, so if the path given is not normalized this will - * actually just convert to a valid string path, but not - * necessarily a normalized one. + * Convert native format to a normalized path object, with refCount of + * zero. + * + * Currently assumes all native paths are actually normalized already, so + * if the path given is not normalized this will actually just convert to + * a valid string path, but not necessarily a normalized one. * * Results: - * A valid normalized path. + * A valid normalized path. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* + +Tcl_Obj* TclpNativeToNormalized(clientData) ClientData clientData; { Tcl_DString ds; Tcl_Obj *objPtr; int len; - + CONST char *copy; Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); - + copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); objPtr = Tcl_NewStringObj(copy,len); Tcl_DStringFree(&ds); - + return objPtr; } @@ -944,17 +977,18 @@ TclpNativeToNormalized(clientData) * * TclNativeCreateNativeRep -- * - * Create a native representation for the given path. + * Create a native representation for the given path. * * Results: - * The nativePath representation. + * The nativePath representation. * * Side effects: * Memory will be allocated. The path may need to be normalized. * *--------------------------------------------------------------------------- */ -ClientData + +ClientData TclNativeCreateNativeRep(pathPtr) Tcl_Obj* pathPtr; { @@ -965,15 +999,18 @@ TclNativeCreateNativeRep(pathPtr) char *str; if (TclFSCwdIsNative()) { - /* - * The cwd is native, which means we can use the translated - * path without worrying about normalization (this will also - * usually be shorter so the utf-to-external conversion will - * be somewhat faster). + /* + * The cwd is native, which means we can use the translated path + * without worrying about normalization (this will also usually be + * shorter so the utf-to-external conversion will be somewhat faster). */ + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); } else { - /* Make sure the normalized path is set */ + /* + * Make sure the normalized path is set. + */ + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); Tcl_IncrRefCount(validPathPtr); } @@ -984,7 +1021,7 @@ TclNativeCreateNativeRep(pathPtr) Tcl_DecrRefCount(validPathPtr); nativePathPtr = ckalloc((unsigned) len); memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); - + Tcl_DStringFree(&ds); return (ClientData)nativePathPtr; } @@ -994,18 +1031,19 @@ TclNativeCreateNativeRep(pathPtr) * * TclNativeDupInternalRep -- * - * Duplicate the native representation. + * Duplicate the native representation. * * Results: - * The copied native representation, or NULL if it is not possible - * to copy the representation. + * The copied native representation, or NULL if it is not possible to + * copy the representation. * * Side effects: * Memory will be allocated for the copy. * *--------------------------------------------------------------------------- */ -ClientData + +ClientData TclNativeDupInternalRep(clientData) ClientData clientData; { @@ -1016,11 +1054,14 @@ TclNativeDupInternalRep(clientData) return NULL; } - /* ascii representation when running on Unix */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); - + /* + * ASCII representation when running on Unix. + */ + + len = sizeof(char) + (strlen((CONST char*) clientData) * sizeof(char)); + copy = (char *) ckalloc(len); - memcpy((VOID*)copy, (VOID*)clientData, len); + memcpy((VOID *) copy, (VOID *) clientData, len); return (ClientData)copy; } @@ -1039,10 +1080,19 @@ TclNativeDupInternalRep(clientData) * *--------------------------------------------------------------------------- */ -int + +int TclpUtime(pathPtr, tval) - Tcl_Obj *pathPtr; /* File to modify */ - struct utimbuf *tval; /* New modification date structure */ + Tcl_Obj *pathPtr; /* File to modify */ + struct utimbuf *tval; /* New modification date structure */ { - return utime(Tcl_FSGetNativePath(pathPtr),tval); + return utime(Tcl_FSGetNativePath(pathPtr), tval); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 5c833b4..c634083 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.58 2005/05/23 20:21:02 das Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.59 2005/07/20 23:16:01 dkf Exp $ */ #include "tclInt.h" @@ -31,33 +31,32 @@ #endif /* - * Define this if you want to revert to the old behavior of - * never checking the stack. + * Define this if you want to revert to the old behavior of never checking the + * stack. */ + #undef TCL_NO_STACK_CHECK /* - * Define this if you want to see a lot of output regarding - * stack checking. + * Define this if you want to see a lot of output regarding stack checking. */ + #undef TCL_DEBUG_STACK_CHECK /* - * Values used to compute how much space is really available for Tcl's - * use for the stack. + * Values used to compute how much space is really available for Tcl's use for + * the stack. * - * NOTE: Now I have some idea why the maximum stack size must be - * divided by 64 on FreeBSD with threads enabled to get a reasonably - * correct value. + * NOTE: Now I have some idea why the maximum stack size must be divided by 64 + * on FreeBSD with threads enabled to get a reasonably correct value. * - * The getrlimit() function is documented to return the maximum stack - * size in bytes. However, with threads enabled, the pthread library - * does bad things to the stack size limits. First, the limits cannot - * be changed. Second, they appear to be reported incorrectly by a - * factor of about 64. + * The getrlimit() function is documented to return the maximum stack size in + * bytes. However, with threads enabled, the pthread library does bad things + * to the stack size limits. First, the limits cannot be changed. Second, + * they appear to be reported incorrectly by a factor of about 64. * - * The defines below may need to be adjusted if more platforms have - * this broken behavior with threads enabled. + * The defines below may need to be adjusted if more platforms have this + * broken behavior with threads enabled. */ #if defined(__FreeBSD__) @@ -94,9 +93,9 @@ static Tcl_ThreadDataKey dataKey; #endif /* TCL_DEBUG_STACK_CHECK */ /* - * Tcl tries to use standard and homebrew methods to guess the right - * encoding on the platform. However, there is always a final fallback, - * and this value is it. Make sure it is a real Tcl encoding. + * Tcl tries to use standard and homebrew methods to guess the right encoding + * on the platform. However, there is always a final fallback, and this value + * is it. Make sure it is a real Tcl encoding. */ #ifndef TCL_DEFAULT_ENCODING @@ -104,26 +103,25 @@ static Tcl_ThreadDataKey dataKey; #endif /* - * Default directory in which to look for Tcl library scripts. The - * symbol is defined by Makefile. + * Default directory in which to look for Tcl library scripts. The symbol is + * defined by Makefile. */ static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY; /* * Directory in which to look for packages (each package is typically - * installed as a subdirectory of this directory). The symbol is - * defined by Makefile. + * installed as a subdirectory of this directory). The symbol is defined by + * Makefile. */ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; /* - * The following table is used to map from Unix locale strings to - * encoding files. If HAVE_LANGINFO is defined, then this is a fallback - * table when the result from nl_langinfo isn't a recognized encoding. - * Otherwise this is the first list checked for a mapping from env - * encoding to Tcl encoding name. + * The following table is used to map from Unix locale strings to encoding + * files. If HAVE_LANGINFO is defined, then this is a fallback table when the + * result from nl_langinfo isn't a recognized encoding. Otherwise this is the + * first list checked for a mapping from env encoding to Tcl encoding name. */ typedef struct LocaleTable { @@ -131,14 +129,14 @@ typedef struct LocaleTable { CONST char *encoding; } LocaleTable; -/* - * The table below is sorted for the sake of doing binary searches on it. - * The indenting reflects different categories of data. The leftmost - * data represent the encoding names directly implemented by data files - * in Tcl's default encoding directory. Indented by one TAB are the - * encoding names that are common alternative spellings. Indented by - * two TABs are the accumulated "bug fixes" that have been added to - * deal with the wide variability seen among existing platforms. +/* + * The table below is sorted for the sake of doing binary searches on it. The + * indenting reflects different categories of data. The leftmost data + * represent the encoding names directly implemented by data files in Tcl's + * default encoding directory. Indented by one TAB are the encoding names that + * are common alternative spellings. Indented by two TABs are the accumulated + * "bug fixes" that have been added to deal with the wide variability seen + * among existing platforms. */ static CONST LocaleTable localeTable[] = { @@ -267,7 +265,7 @@ static CONST LocaleTable localeTable[] = { #endif {"ja_jp", "euc-jp"}, {"ja_jp.euc", "euc-jp"}, - {"ja_jp.eucjp", "euc-jp"}, + {"ja_jp.eucjp", "euc-jp"}, {"ja_jp.jis", "iso2022-jp"}, {"ja_jp.mscode", "shiftjis"}, {"ja_jp.sjis", "shiftjis"}, @@ -286,13 +284,13 @@ static CONST LocaleTable localeTable[] = { {"jis0208", "jis0208"}, {"jis0212", "jis0212"}, {"jp_jp", "shiftjis"}, - {"ko", "euc-kr"}, - {"ko_kr", "euc-kr"}, - {"ko_kr.euc", "euc-kr"}, - {"ko_kw.euckw", "euc-kr"}, + {"ko", "euc-kr"}, + {"ko_kr", "euc-kr"}, + {"ko_kr.euc", "euc-kr"}, + {"ko_kw.euckw", "euc-kr"}, {"koi8-r", "koi8-r"}, {"koi8-u", "koi8-u"}, - {"korean", "euc-kr"}, + {"korean", "euc-kr"}, {"ksc5601", "ksc5601"}, {"maccenteuro", "macCentEuro"}, {"maccroatian", "macCroatian"}, @@ -378,13 +376,12 @@ TclpInitPlatform() } /* - * The code below causes SIGPIPE (broken pipe) errors to - * be ignored. This is needed so that Tcl processes don't - * die if they create child processes (e.g. using "exec" or - * "open") that terminate prematurely. The signal handler - * is only set up when the first interpreter is created; - * after this the application can override the handler with - * a different one of its own, if it wants. + * The code below causes SIGPIPE (broken pipe) errors to be ignored. This + * is needed so that Tcl processes don't die if they create child + * processes (e.g. using "exec" or "open") that terminate prematurely. + * The signal handler is only set up when the first interpreter is + * created; after this the application can override the handler with a + * different one of its own, if it wants. */ #ifdef SIGPIPE @@ -402,22 +399,23 @@ TclpInitPlatform() */ (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ #endif + /* - * Initialize the C library's locale subsystem. This is required - * for input methods to work properly on X11. We only do this for - * LC_CTYPE because that's the necessary one, and we don't want to - * affect LC_TIME here. The side effect of setting the default - * locale should be to load any locale specific modules that are - * needed by X. [BUG: 5422 3345 4236 2522 2521]. + * Initialize the C library's locale subsystem. This is required for input + * methods to work properly on X11. We only do this for LC_CTYPE because + * that's the necessary one, and we don't want to affect LC_TIME here. + * The side effect of setting the default locale should be to load any + * locale specific modules that are needed by X. [BUG: 5422 3345 4236 2522 + * 2521]. */ setlocale(LC_CTYPE, ""); /* * In case the initial locale is not "C", ensure that the numeric - * processing is done in "C" locale regardless. This is needed because - * Tcl relies on routines like strtod, but should not have locale - * dependent behavior. + * processing is done in "C" locale regardless. This is needed because Tcl + * relies on routines like strtod, but should not have locale dependent + * behavior. */ setlocale(LC_NUMERIC, "C"); @@ -428,18 +426,17 @@ TclpInitPlatform() * * TclpInitLibraryPath -- * - * This is the fallback routine that sets the library path - * if the application has not set one by the first time - * it is needed. + * This is the fallback routine that sets the library path if the + * application has not set one by the first time it is needed. * * Results: - * None. + * None. * * Side effects: - * Sets the library path to an initial value. + * Sets the library path to an initial value. * *------------------------------------------------------------------------- - */ + */ void TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) @@ -459,18 +456,18 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) pathPtr = Tcl_NewObj(); /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable - * is installed. + * Initialize the substrings used when locating an executable. The + * installLib variable computes the path as though the executable is + * installed. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* - * Look for the library relative to the TCL_LIBRARY env variable. - * If the last dirname in the TCL_LIBRARY path does not match the - * last dirname in the installLib variable, use the last dir name - * of installLib in addition to the orginal TCL_LIBRARY path. + * Look for the library relative to the TCL_LIBRARY env variable. If the + * last dirname in the TCL_LIBRARY path does not match the last dirname in + * the installLib variable, use the last dir name of installLib in + * addition to the orginal TCL_LIBRARY path. */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ @@ -491,8 +488,8 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) * If TCL_LIBRARY is set but refers to a different tcl * installation than the current version, try fiddling with the * specified directory to make it refer to this installation by - * removing the old "tclX.Y" and substituting the current - * version string. + * removing the old "tclX.Y" and substituting the current version + * string. */ pathv[pathc - 1] = installLib + 4; @@ -505,27 +502,30 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) } /* - * Finally, look for the library relative to the compiled-in path. - * This is needed when users install Tcl with an exec-prefix that - * is different from the prtefix. + * Finally, look for the library relative to the compiled-in path. This is + * needed when users install Tcl with an exec-prefix that is different + * from the prtefix. */ { #ifdef HAVE_COREFOUNDATION - char tclLibPath[MAXPATHLEN + 1]; + char tclLibPath[MAXPATHLEN + 1]; - if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { - str = tclLibPath; - } else + if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { + str = tclLibPath; + } else #endif /* HAVE_COREFOUNDATION */ - { - /* TODO: Pull this value from the TIP 59 table */ - str = defaultLibraryDir; - } - if (str[0] != '\0') { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } + { + /* + * TODO: Pull this value from the TIP 59 table. + */ + + str = defaultLibraryDir; + } + if (str[0] != '\0') { + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + } } Tcl_DStringFree(&buffer); @@ -541,21 +541,21 @@ TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) * * TclpSetInitialEncodings -- * - * Based on the locale, determine the encoding of the operating - * system and the default encoding for newly opened files. + * Based on the locale, determine the encoding of the operating system + * and the default encoding for newly opened files. * - * Called at process initialization time, and part way through - * startup, we verify that the initial encodings were correctly - * setup. Depending on Tcl's environment, there may not have been - * enough information first time through (above). + * Called at process initialization time, and part way through startup, + * we verify that the initial encodings were correctly setup. Depending + * on Tcl's environment, there may not have been enough information first + * time through (above). * * Results: * None. * * Side effects: - * The Tcl library path is converted from native encoding to UTF-8, - * on the first call, and the encodings may be changed on first or - * second call. + * The Tcl library path is converted from native encoding to UTF-8, on + * the first call, and the encodings may be changed on first or second + * call. * *--------------------------------------------------------------------------- */ @@ -581,9 +581,11 @@ SearchKnownEncodings(encoding) { int left = 0; int right = sizeof(localeTable)/sizeof(LocaleTable); + while (left <= right) { int test = (left + right)/2; int code = strcmp(localeTable[test].lang, encoding); + if (code == 0) { return localeTable[test].encoding; } @@ -607,14 +609,18 @@ TclpGetEncodingNameFromEnvironment(bufPtr) /* * Determine the current encoding from the LC_* or LANG environment - * variables. We previously used setlocale() to determine the locale, - * but this does not work on some systems (e.g. Linux/i386 RH 5.0). + * variables. We previously used setlocale() to determine the locale, but + * this does not work on some systems (e.g. Linux/i386 RH 5.0). */ + #ifdef HAVE_LANGINFO if (setlocale(LC_CTYPE, "") != NULL) { Tcl_DString ds; - /* Use a DString so we can modify case. */ + /* + * Use a DString so we can modify case. + */ + Tcl_DStringInit(&ds); encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); Tcl_UtfToLower(Tcl_DStringValue(&ds)); @@ -632,9 +638,10 @@ TclpGetEncodingNameFromEnvironment(bufPtr) #endif /* HAVE_LANGINFO */ /* - * Classic fallback check. This tries a homebrew algorithm to - * determine what encoding should be used based on env vars. + * Classic fallback check. This tries a homebrew algorithm to determine + * what encoding should be used based on env vars. */ + encoding = getenv("LC_ALL"); if (encoding == NULL || encoding[0] == '\0') { @@ -668,8 +675,8 @@ TclpGetEncodingNameFromEnvironment(bufPtr) } /* - * We didn't recognize the full value as an encoding name. - * If there is an encoding subfield, we can try to guess from that. + * We didn't recognize the full value as an encoding name. If there is + * an encoding subfield, we can try to guess from that. */ for (p = encoding; *p != '\0'; p++) { @@ -699,9 +706,9 @@ TclpGetEncodingNameFromEnvironment(bufPtr) * * TclpSetVariables -- * - * Performs platform-specific interpreter initialization related to - * the tcl_library and tcl_platform variables, and other platform- - * specific things. + * Performs platform-specific interpreter initialization related to the + * tcl_library and tcl_platform variables, and other platform-specific + * things. * * Results: * None. @@ -728,63 +735,72 @@ TclpSetVariables(interp) char tclLibPath[MAXPATHLEN + 1]; if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) { - CONST char *str; - Tcl_DString ds; - CFBundleRef bundleRef; - - Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, - TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); - if ((str != NULL) && (str[0] != '\0')) { - char *p = Tcl_DStringValue(&ds); - /* convert DYLD_FRAMEWORK_PATH from colon to space separated */ - do { - if(*p == ':') *p = ' '; - } while (*p++); - Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_DStringFree(&ds); - } - if ((bundleRef = CFBundleGetMainBundle())) { - CFURLRef frameworksURL; - Tcl_StatBuf statBuf; - if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) { - if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE, - (unsigned char*) tclLibPath, MAXPATHLEN) && - ! TclOSstat(tclLibPath, &statBuf) && - S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - } - CFRelease(frameworksURL); - } - if((frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef))) { - if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE, - (unsigned char*) tclLibPath, MAXPATHLEN) && - ! TclOSstat(tclLibPath, &statBuf) && - S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - } - CFRelease(frameworksURL); - } - } - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + CONST char *str; + Tcl_DString ds; + CFBundleRef bundleRef; + + Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + + str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); + if ((str != NULL) && (str[0] != '\0')) { + char *p = Tcl_DStringValue(&ds); + + /* + * Convert DYLD_FRAMEWORK_PATH from colon to space separated. + */ + + do { + if (*p == ':') { + *p = ' '; + } + } while (*p++); + Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_DStringFree(&ds); + } + bundleRef = CFBundleGetMainBundle(); + if (bundleRef) { + CFURLRef frameworksURL; + Tcl_StatBuf statBuf; + + frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef); + if (frameworksURL) { + if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, + (unsigned char*) tclLibPath, MAXPATHLEN) && + ! TclOSstat(tclLibPath, &statBuf) && + S_ISDIR(statBuf.st_mode)) { + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + } + CFRelease(frameworksURL); + } + frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef); + if (frameworksURL) { + if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, + (unsigned char*) tclLibPath, MAXPATHLEN) && + ! TclOSstat(tclLibPath, &statBuf) && + S_ISDIR(statBuf.st_mode)) { + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + } + CFRelease(frameworksURL); + } + } + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } else #endif /* HAVE_COREFOUNDATION */ { - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); } #ifdef DJGPP @@ -792,6 +808,7 @@ TclpSetVariables(interp) #else Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); #endif + unameOK = 0; #ifndef NO_UNAME if (uname(&name) >= 0) { @@ -804,11 +821,11 @@ TclpSetVariables(interp) Tcl_DStringFree(&ds); /* - * The following code is a special hack to handle differences in - * the way version information is returned by uname. On most - * systems the full version number is available in name.release. - * However, under AIX the major version number is in - * name.version and the minor version number is in name.release. + * The following code is a special hack to handle differences in the + * way version information is returned by uname. On most systems the + * full version number is available in name.release. However, under + * AIX the major version number is in name.version and the minor + * version number is in name.release. */ if ((strchr(name.release, '.') != NULL) @@ -817,9 +834,12 @@ TclpSetVariables(interp) TCL_GLOBAL_ONLY); } else { #ifdef DJGPP - /* For some obscure reason DJGPP puts major version into - * name.release and minor into name.version. As of DJGPP 2.04 - * this is documented in djgpp libc.info file*/ + /* + * For some obscure reason DJGPP puts major version into + * name.release and minor into name.version. As of DJGPP 2.04 this + * is documented in djgpp libc.info file. + */ + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", @@ -847,7 +867,7 @@ TclpSetVariables(interp) } /* - * Copy USER or LOGNAME environment variable into tcl_platform(user) + * Copy USER or LOGNAME environment variable into tcl_platform(user). */ Tcl_DStringInit(&ds); @@ -860,7 +880,6 @@ TclpSetVariables(interp) } Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); - } /* @@ -868,15 +887,14 @@ TclpSetVariables(interp) * * TclpFindVariable -- * - * Locate the entry in environ for a given name. On Unix this - * routine is case sensetive, on Windows this matches mixed case. + * Locate the entry in environ for a given name. On Unix this routine is + * case sensetive, on Windows this matches mixed case. * * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). + * The return value is the index in environ of an entry with the name + * "name", or -1 if there is no such entry. The integer at *lengthPtr is + * filled in with the length of name (if a matching entry is found) or + * the length of the environ array (if no matching entry is found). * * Side effects: * None. @@ -916,7 +934,7 @@ TclpFindVariable(name, lengthPtr) *lengthPtr = i; - done: + done: Tcl_DStringFree(&envString); return result; } @@ -926,8 +944,8 @@ TclpFindVariable(name, lengthPtr) * * TclpCheckStackSpace -- * - * Detect if we are about to blow the stack. Called before an - * evaluation can happen when nesting depth is checked. + * Detect if we are about to blow the stack. Called before an evaluation + * can happen when nesting depth is checked. * * Results: * 1 if there is enough stack space to continue; 0 if not. @@ -944,8 +962,8 @@ TclpCheckStackSpace() #ifdef TCL_NO_STACK_CHECK /* - * This function was normally unimplemented on Unix platforms and - * this implements old behavior, i.e. no stack checking performed. + * This function was normally unimplemented on Unix platforms and this + * implements old behavior, i.e. no stack checking performed. */ return 1; @@ -962,8 +980,12 @@ TclpCheckStackSpace() * possible. */ if (tsdPtr == NULL) { - /* this should probably be a panic(). */ - Tcl_Panic("failed to get thread specific stack check data"); + /* + * This should probably be a panic(); if we're out of stack, we might + * have virtually no room to manoeuver at all. + */ + + Tcl_Panic("failed to get thread specific stack check data"); } /* @@ -976,11 +998,11 @@ TclpCheckStackSpace() if (tsdPtr->initialised == 0) { /* - * We appear to have not computed the stack size before. - * Attempt to retrieve it from either the current thread or, - * failing that, the process accounting limit. Note that we - * assume that stack sizes do not change throughout the - * lifespan of the thread/process; this is almost always true. + * We appear to have not computed the stack size before. Attempt to + * retrieve it from either the current thread or, failing that, the + * process accounting limit. Note that we assume that stack sizes do + * not change throughout the lifespan of the thread/process; this is + * almost always true. */ tsdPtr->stackDetermineResult = GetStackSize(&tsdPtr->stackSize); @@ -1008,8 +1030,7 @@ TclpCheckStackSpace() } /* - * Now we perform the actual check. Are we about to blow - * our stack frame? + * Now we perform the actual check. Are we about to blow our stack frame? */ if (stackUsed < (ptrdiff_t) tsdPtr->stackSize) { @@ -1029,17 +1050,17 @@ TclpCheckStackSpace() * * GetStackSize -- * - * Discover what the stack size for the current thread/process - * actually is. Expects to only ever be called once per thread - * and then only at a point when there is a reasonable amount of - * space left on the current stack; TclpCheckStackSpace is called - * sufficiently frequently that that is true. + * Discover what the stack size for the current thread/process actually + * is. Expects to only ever be called once per thread and then only at a + * point when there is a reasonable amount of space left on the current + * stack; TclpCheckStackSpace is called sufficiently frequently that that + * is true. * * Results: - * TCL_OK if the stack space was discovered, TCL_BREAK if the - * stack space was undiscoverable in a way that stack checks - * should fail, and TCL_CONTINUE if the stack space was - * undiscoverable in a way that stack checks should succeed. + * TCL_OK if the stack space was discovered, TCL_BREAK if the stack space + * was undiscoverable in a way that stack checks should fail, and + * TCL_CONTINUE if the stack space was undiscoverable in a way that stack + * checks should succeed. * * Side effects: * None @@ -1068,10 +1089,9 @@ GetStackSize(stackSizePtr) } /* - * If we have zero or an error, try the system limits - * instead. After all, the pthread documentation states that - * threads should always be bound by the system stack size limit - * in any case. + * If we have zero or an error, try the system limits instead. After all, + * the pthread documentation states that threads should always be bound by + * the system stack size limit in any case. */ #endif /* TCL_THREADS */ @@ -1090,9 +1110,9 @@ GetStackSize(stackSizePtr) rawStackSize = rLimit.rlim_cur; /* - * Final sanity check on the determined stack size. If we fail - * this, assume there are bogus values about and that we can't - * actually figure out what the stack size really is. + * Final sanity check on the determined stack size. If we fail this, + * assume there are bogus values about and that we can't actually figure + * out what the stack size really is. */ #ifdef TCL_THREADS /* Stop warning... */ @@ -1118,9 +1138,8 @@ GetStackSize(stackSizePtr) * * MacOSXGetLibraryPath -- * - * If we have a bundle structure for the Tcl installation, - * then check there first to see if we can find the libraries - * there. + * If we have a bundle structure for the Tcl installation, then check + * there first to see if we can find the libraries there. * * Results: * TCL_OK if we have found the tcl library; TCL_ERROR otherwise. @@ -1136,10 +1155,21 @@ static int MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath) { int foundInFramework = TCL_ERROR; + #ifdef TCL_FRAMEWORK - foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, - "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, tclLibPath); + foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, + "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, + tclLibPath); #endif + return foundInFramework; } #endif /* HAVE_COREFOUNDATION */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 19e73c5..bb07c24 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -6,8 +6,8 @@ * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 */ @@ -19,30 +19,29 @@ #include "pthread.h" typedef struct ThreadSpecificData { - char nabuf[16]; + char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* - * masterLock is used to serialize creation of mutexes, condition - * variables, and thread local storage. - * This is the only place that can count on the ability to statically - * initialize the mutex. + * masterLock is used to serialize creation of mutexes, condition variables, + * and thread local storage. This is the only place that can count on the + * ability to statically initialize the mutex. */ static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER; /* - * initLock is used to serialize initialization and finalization - * of Tcl. It cannot use any dyamically allocated storage. + * initLock is used to serialize initialization and finalization of Tcl. It + * cannot use any dyamically allocated storage. */ static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER; /* - * allocLock is used by Tcl's version of malloc for synchronization. - * For obvious reasons, cannot use any dyamically allocated storage. + * allocLock is used by Tcl's version of malloc for synchronization. For + * obvious reasons, cannot use any dyamically allocated storage. */ static pthread_mutex_t allocLock = PTHREAD_MUTEX_INITIALIZER; @@ -66,8 +65,8 @@ static pthread_mutex_t *allocLockPtr = &allocLock; * This procedure creates a new thread. * * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. + * TCL_OK if the thread could be created. The thread ID is returned in a + * parameter. * * Side effects: * A new thread is created. @@ -81,8 +80,8 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadCreateProc proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ + int flags; /* Flags controlling behaviour of the + * new thread. */ { #ifdef TCL_THREADS pthread_attr_t attr; @@ -94,14 +93,14 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) #ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE if (stackSize != TCL_THREAD_STACK_DEFAULT) { - pthread_attr_setstacksize(&attr, (size_t) stackSize); + pthread_attr_setstacksize(&attr, (size_t) stackSize); #ifdef TCL_THREAD_STACK_MIN } else { - /* - * Certain systems define a thread stack size that by default is - * too small for many operations. The user has the option of - * defining TCL_THREAD_STACK_MIN to a value large enough to work - * for their needs. This would look like (for 128K min stack): + /* + * Certain systems define a thread stack size that by default is too + * small for many operations. The user has the option of defining + * TCL_THREAD_STACK_MIN to a value large enough to work for their + * needs. This would look like (for 128K min stack): * make MEM_DEBUG_FLAGS=-DTCL_THREAD_STACK_MIN=131072L * * This solution is not optimal, as we should allow the user to @@ -109,7 +108,7 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) * down, and that would still leave the main thread at the default. */ - size_t size; + size_t size; result = pthread_attr_getstacksize(&attr, &size); if (!result && (size < TCL_THREAD_STACK_MIN)) { pthread_attr_setstacksize(&attr, (size_t) TCL_THREAD_STACK_MIN); @@ -118,7 +117,7 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) } #endif if (! (flags & TCL_THREAD_JOINABLE)) { - pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); + pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED); } @@ -149,18 +148,17 @@ TclpThreadCreate(idPtr, proc, clientData, stackSize, flags) * TCL_OK if the wait was successful, TCL_ERROR else. * * Side effects: - * The result area is set to the exit code of the thread we - * waited upon. + * The result area is set to the exit code of the thread we waited upon. * *---------------------------------------------------------------------- */ int Tcl_JoinThread(threadId, state) - Tcl_ThreadId threadId; /* Id of the thread to wait upon */ - int* state; /* Reference to the storage the result - * of the thread we wait upon will be - * written into. */ + Tcl_ThreadId threadId; /* Id of the thread to wait upon. */ + int *state; /* Reference to the storage the result of the + * thread we wait upon will be written + * into. */ { #ifdef TCL_THREADS int result; @@ -237,10 +235,10 @@ TclpThreadGetStackSize() return (int) stackSize; #else /* - * Cannot determine the real stack size of this thread. The - * caller might want to try looking at the process accounting - * limits instead. + * Cannot determine the real stack size of this thread. The caller might + * want to try looking at the process accounting limits instead. */ + return 0; #endif } @@ -279,9 +277,9 @@ Tcl_GetCurrentThread() * TclpInitLock * * This procedure is used to grab a lock that serializes initialization - * and finalization of Tcl. On some platforms this may also initialize - * the mutex used to serialize creation of more mutexes and thread - * local storage keys. + * and finalization of Tcl. On some platforms this may also initialize + * the mutex used to serialize creation of more mutexes and thread local + * storage keys. * * Results: * None. @@ -305,15 +303,15 @@ TclpInitLock() * * TclpFinalizeLock * - * This procedure is used to destroy all private resources used in - * this file. + * This procedure is used to destroy all private resources used in this + * file. * * Results: * None. * * Side effects: - * Destroys everything private. TclpInitLock must be held - * entering this function. + * Destroys everything private. TclpInitLock must be held entering this + * function. * *---------------------------------------------------------------------- */ @@ -324,9 +322,10 @@ TclFinalizeLock () #ifdef TCL_THREADS /* * You do not need to destroy mutexes that were created with the - * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need - * any destruction: masterLock, allocLock, and initLock. + * PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any + * destruction: masterLock, allocLock, and initLock. */ + pthread_mutex_unlock(&initLock); #endif } @@ -336,8 +335,8 @@ TclFinalizeLock () * * TclpInitUnlock * - * This procedure is used to release a lock that serializes initialization - * and finalization of Tcl. + * This procedure is used to release a lock that serializes + * initialization and finalization of Tcl. * * Results: * None. @@ -361,13 +360,12 @@ TclpInitUnlock() * * TclpMasterLock * - * This procedure is used to grab a lock that serializes creation - * and finalization of serialization objects. This interface is - * only needed in finalization; it is hidden during - * creation of the objects. + * This procedure is used to grab a lock that serializes creation and + * finalization of serialization objects. This interface is only needed + * in finalization; it is hidden during creation of the objects. * - * This lock must be different than the initLock because the - * initLock is held during creation of syncronization objects. + * This lock must be different than the initLock because the initLock is + * held during creation of syncronization objects. * * Results: * None. @@ -392,8 +390,8 @@ TclpMasterLock() * * TclpMasterUnlock * - * This procedure is used to release a lock that serializes creation - * and finalization of synchronization objects. + * This procedure is used to release a lock that serializes creation and + * finalization of synchronization objects. * * Results: * None. @@ -418,13 +416,13 @@ TclpMasterUnlock() * * Tcl_GetAllocMutex * - * This procedure returns a pointer to a statically initialized - * mutex for use by the memory allocator. The alloctor must - * use this lock, because all other locks are allocated... + * This procedure returns a pointer to a statically initialized mutex for + * use by the memory allocator. The alloctor must use this lock, because + * all other locks are allocated... * * Results: - * A pointer to a mutex that is suitable for passing to - * Tcl_MutexLock and Tcl_MutexUnlock. + * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and + * Tcl_MutexUnlock. * * Side effects: * None. @@ -449,18 +447,18 @@ Tcl_GetAllocMutex() * * Tcl_MutexLock -- * - * This procedure is invoked to lock a mutex. This procedure - * handles initializing the mutex, if necessary. The caller - * can rely on the fact that Tcl_Mutex is an opaque pointer. - * This routine will change that pointer from NULL after first use. + * This procedure is invoked to lock a mutex. This procedure handles + * initializing the mutex, if necessary. The caller can rely on the fact + * that Tcl_Mutex is an opaque pointer. This routine will change that + * pointer from NULL after first use. * * Results: * None. * * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a pthread_mutex_t - * and initialize this the first time this Tcl_Mutex is used. + * May block the current thread. The mutex is aquired when this returns. + * Will allocate memory for a pthread_mutex_t and initialize this the + * first time this Tcl_Mutex is used. * *---------------------------------------------------------------------- */ @@ -494,8 +492,8 @@ Tcl_MutexLock(mutexPtr) * * Tcl_MutexUnlock -- * - * This procedure is invoked to unlock a mutex. The mutex must - * have been locked by Tcl_MutexLock. + * This procedure is invoked to unlock a mutex. The mutex must have been + * locked by Tcl_MutexLock. * * Results: * None. @@ -520,8 +518,8 @@ Tcl_MutexUnlock(mutexPtr) * * TclpFinalizeMutex -- * - * This procedure is invoked to clean up one mutex. This is only - * safe to call at the end of time. + * This procedure is invoked to clean up one mutex. This is only safe to + * call at the end of time. * * This assumes the Master Lock is held. * @@ -540,7 +538,7 @@ TclpFinalizeMutex(mutexPtr) { pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr; if (pmutexPtr != NULL) { - pthread_mutex_destroy(pmutexPtr); + pthread_mutex_destroy(pmutexPtr); ckfree((char *)pmutexPtr); *mutexPtr = NULL; } @@ -552,22 +550,21 @@ TclpFinalizeMutex(mutexPtr) * * TclpThreadDataKeyInit -- * - * This procedure initializes a thread specific data block key. - * Each thread has table of pointers to thread specific data. - * all threads agree on which table entry is used by each module. - * this is remembered in a "data key", that is just an index into - * this table. To allow self initialization, the interface - * passes a pointer to this key and the first thread to use - * the key fills in the pointer to the key. The key should be - * a process-wide static. + * This procedure initializes a thread specific data block key. Each + * thread has table of pointers to thread specific data. All threads + * agree on which table entry is used by each module. This is remembered + * in a "data key", that is just an index into this table. To allow self + * initialization, the interface passes a pointer to this key and the + * first thread to use the key fills in the pointer to the key. The key + * should be a process-wide static. * * Results: * None. * * Side effects: - * Will allocate memory the first time this process calls for - * this key. In this case it modifies its argument - * to hold the pointer to information about the key. + * Will allocate memory the first time this process calls for this key. + * In this case it modifies its argument to hold the pointer to + * information about the key. * *---------------------------------------------------------------------- */ @@ -581,7 +578,7 @@ TclpThreadDataKeyInit(keyPtr) MASTER_LOCK; if (*keyPtr == NULL) { - pkeyPtr = (pthread_key_t *)ckalloc(sizeof(pthread_key_t)); + pkeyPtr = (pthread_key_t *) ckalloc(sizeof(pthread_key_t)); pthread_key_create(pkeyPtr, NULL); *keyPtr = (Tcl_ThreadDataKey)pkeyPtr; TclRememberDataKey(keyPtr); @@ -597,8 +594,8 @@ TclpThreadDataKeyInit(keyPtr) * This procedure returns a pointer to a block of thread local storage. * * Results: - * A thread-specific pointer to the data structure, or NULL - * if the memory has not been assigned to this key for this thread. + * A thread-specific pointer to the data structure, or NULL if the memory + * has not been assigned to this key for this thread. * * Side effects: * None. @@ -608,8 +605,8 @@ TclpThreadDataKeyInit(keyPtr) VOID * TclpThreadDataKeyGet(keyPtr) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ { pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; if (pkeyPtr == NULL) { @@ -631,16 +628,16 @@ TclpThreadDataKeyGet(keyPtr) * None. * * Side effects: - * Sets up the thread so future calls to TclpThreadDataKeyGet with - * this key will return the data pointer. + * Sets up the thread so future calls to TclpThreadDataKeyGet with this + * key will return the data pointer. * *---------------------------------------------------------------------- */ void TclpThreadDataKeySet(keyPtr, data) - Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, - * really (pthread_key_t **) */ + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, really + * (pthread_key_t **) */ VOID *data; /* Thread local storage */ { pthread_key_t *pkeyPtr = *(pthread_key_t **)keyPtr; @@ -652,8 +649,8 @@ TclpThreadDataKeySet(keyPtr, data) * * TclpFinalizeThreadData -- * - * This procedure cleans up the thread-local storage. This is - * called once for each thread. + * This procedure cleans up the thread-local storage. This is called once + * for each thread. * * Results: * None. @@ -686,9 +683,9 @@ TclpFinalizeThreadData(keyPtr) * * TclpFinalizeThreadDataKey -- * - * This procedure is invoked to clean up one key. This is a - * process-wide storage identifier. The thread finalization code - * cleans up the thread local storage itself. + * This procedure is invoked to clean up one key. This is a process-wide + * storage identifier. The thread finalization code cleans up the thread + * local storage itself. * * This assumes the master lock is held. * @@ -720,9 +717,9 @@ TclpFinalizeThreadDataKey(keyPtr) * * Tcl_ConditionWait -- * - * This procedure is invoked to wait on a condition variable. - * The mutex is automically released as part of the wait, and - * automatically grabbed when the condition is signaled. + * This procedure is invoked to wait on a condition variable. The mutex + * is automically released as part of the wait, and automatically grabbed + * when the condition is signaled. * * The mutex must be held when this procedure is called. * @@ -730,9 +727,9 @@ TclpFinalizeThreadDataKey(keyPtr) * None. * * Side effects: - * May block the current thread. The mutex is aquired when - * this returns. Will allocate memory for a pthread_mutex_t - * and initialize this the first time this Tcl_Mutex is used. + * May block the current thread. The mutex is aquired when this returns. + * Will allocate memory for a pthread_mutex_t and initialize this the + * first time this Tcl_Mutex is used. * *---------------------------------------------------------------------- */ @@ -751,8 +748,8 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr) MASTER_LOCK; /* - * Double check inside mutex to avoid race, - * then initialize condition variable if necessary. + * Double check inside mutex to avoid race, then initialize condition + * variable if necessary. */ if (*condPtr == NULL) { @@ -790,8 +787,8 @@ Tcl_ConditionWait(condPtr, mutexPtr, timePtr) * * This procedure is invoked to signal a condition variable. * - * The mutex must be held during this call to avoid races, - * but this interface does not enforce that. + * The mutex must be held during this call to avoid races, but this + * interface does not enforce that. * * Results: * None. @@ -822,8 +819,8 @@ Tcl_ConditionNotify(condPtr) * * TclpFinalizeCondition -- * - * This procedure is invoked to clean up a condition variable. - * This is only safe to call at the end of time. + * This procedure is invoked to clean up a condition variable. This is + * only safe to call at the end of time. * * This assumes the Master Lock is held. * @@ -854,8 +851,8 @@ TclpFinalizeCondition(condPtr) * * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa -- * - * These procedures replace core C versions to be used in a - * threaded environment. + * These procedures replace core C versions to be used in a threaded + * environment. * * Results: * See documentation of C functions. @@ -864,8 +861,9 @@ TclpFinalizeCondition(condPtr) * See documentation of C functions. * * Notes: - * TclpReaddir is no longer used by the core (see 1095909), - * but it appears in the internal stubs table (see #589526). + * TclpReaddir is no longer used by the core (see 1095909), but it + * appears in the internal stubs table (see #589526). + * *---------------------------------------------------------------------- */ @@ -881,8 +879,8 @@ TclpInetNtoa(struct in_addr addr) #ifdef TCL_THREADS ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); union { - unsigned long l; - unsigned char b[4]; + unsigned long l; + unsigned char b[4]; } u; u.l = (unsigned long) addr.s_addr; @@ -892,17 +890,18 @@ TclpInetNtoa(struct in_addr addr) return inet_ntoa(addr); #endif } - + #ifdef TCL_THREADS /* * Additions by AOL for specialized thread memory allocator. */ + #ifdef USE_THREAD_ALLOC static volatile int initialized = 0; static pthread_key_t key; typedef struct allocMutex { - Tcl_Mutex tlock; + Tcl_Mutex tlock; pthread_mutex_t plock; } allocMutex; @@ -925,7 +924,9 @@ TclpFreeAllocMutex(mutex) Tcl_Mutex *mutex; /* The alloc mutex to free. */ { allocMutex* lockPtr = (allocMutex*) mutex; - if (!lockPtr) return; + if (!lockPtr) { + return; + } pthread_mutex_destroy(&lockPtr->plock); free(lockPtr); } @@ -934,17 +935,20 @@ void TclpFreeAllocCache(ptr) void *ptr; { if (ptr != NULL) { - /* - * Called by the pthread lib when a thread exits - */ - TclFreeAllocCache(ptr); + /* + * Called by the pthread lib when a thread exits + */ + + TclFreeAllocCache(ptr); + } else if (initialized) { - /* - * Called by us in TclFinalizeThreadAlloc() during - * the library finalization initiated from Tcl_Finalize() - */ - pthread_key_delete(key); - initialized = 0; + /* + * Called by us in TclFinalizeThreadAlloc() during the library + * finalization initiated from Tcl_Finalize() + */ + + pthread_key_delete(key); + initialized = 0; } } @@ -967,6 +971,13 @@ TclpSetAllocCache(void *arg) { pthread_setspecific(key, arg); } - #endif /* USE_THREAD_ALLOC */ #endif /* TCL_THREADS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index e51f3fe..1ebec63 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -1,26 +1,26 @@ -/* +/* * tclUnixTime.c -- * - * Contains Unix specific versions of Tcl functions that - * obtain time values from the operating system. + * Contains Unix specific versions of Tcl functions that obtain time + * values from the operating system. * * Copyright (c) 1995 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixTime.c,v 1.24 2005/05/10 18:35:29 kennykb Exp $ + * RCS: @(#) $Id: tclUnixTime.c,v 1.25 2005/07/20 23:16:01 dkf Exp $ */ #include "tclInt.h" #include <locale.h> #define TM_YEAR_BASE 1900 -#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0)) +#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) /* - * TclpGetDate is coded to return a pointer to a 'struct tm'. For - * thread safety, this structure must be in thread-specific data. - * The 'tmKey' variable is the key to this buffer. + * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread + * safety, this structure must be in thread-specific data. The 'tmKey' + * variable is the key to this buffer. */ static Tcl_ThreadDataKey tmKey; @@ -30,40 +30,42 @@ typedef struct ThreadSpecificData { } ThreadSpecificData; /* - * If we fall back on the thread-unsafe versions of gmtime and localtime, - * use this mutex to try to protect them. + * If we fall back on the thread-unsafe versions of gmtime and localtime, use + * this mutex to try to protect them. */ TCL_DECLARE_MUTEX(tmMutex) -static char* lastTZ = NULL; /* Holds the last setting of the - * TZ environment variable, or an - * empty string if the variable was - * not set. */ - -/* Static functions declared in this file */ +static char *lastTZ = NULL; /* Holds the last setting of the TZ + * environment variable, or an empty string if + * the variable was not set. */ -static void SetTZIfNecessary _ANSI_ARGS_((void)); -static void CleanupMemory _ANSI_ARGS_((ClientData)); +/* + * Static functions declared in this file. + */ -static void NativeScaleTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); -static void NativeGetTime _ANSI_ARGS_ ((Tcl_Time* timebuf, ClientData clientData)); +static void SetTZIfNecessary _ANSI_ARGS_((void)); +static void CleanupMemory _ANSI_ARGS_((ClientData)); +static void NativeScaleTime _ANSI_ARGS_((Tcl_Time *timebuf, + ClientData clientData)); +static void NativeGetTime _ANSI_ARGS_((Tcl_Time *timebuf, + ClientData clientData)); -/* TIP #233 (Virtualized Time) - * Data for the time hooks, if any. +/* + * TIP #233 (Virtualized Time): Data for the time hooks, if any. */ -Tcl_GetTimeProc* tclGetTimeProcPtr = NativeGetTime; -Tcl_ScaleTimeProc* tclScaleTimeProcPtr = NativeScaleTime; -ClientData tclTimeClientData = NULL; +Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; +Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; +ClientData tclTimeClientData = NULL; /* *----------------------------------------------------------------------------- * * TclpGetSeconds -- * - * This procedure returns the number of seconds from the epoch. On - * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * This procedure returns the number of seconds from the epoch. On most + * Unix systems the epoch is Midnight Jan 1, 1970 GMT. * * Results: * Number of seconds from the epoch. @@ -86,8 +88,8 @@ TclpGetSeconds() * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution - * clock available on the system. There are no garantees on what the - * resolution will be. In Tcl we will call this value a "click". The + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependant. * * Results: @@ -106,13 +108,17 @@ TclpGetClicks() #ifdef NO_GETTOD if (tclGetTimeProcPtr != NativeGetTime) { - Tcl_Time time; - (*tclGetTimeProcPtr) (&time, tclTimeClientData); + Tcl_Time time; + + (*tclGetTimeProcPtr) (&time, tclTimeClientData); now = time.sec*1000000 + time.usec; } else { - /* A semi-NativeGetTime, specialized to clicks */ - struct tms dummy; - now = (unsigned long) times(&dummy); + /* + * A semi-NativeGetTime, specialized to clicks. + */ + struct tms dummy; + + now = (unsigned long) times(&dummy); } #else Tcl_Time time; @@ -129,13 +135,12 @@ TclpGetClicks() * * TclpGetTimeZone -- * - * Determines the current timezone. The method varies wildly - * between different platform implementations, so its hidden in - * this function. + * Determines the current timezone. The method varies wildly between + * different platform implementations, so its hidden in this function. * * Results: - * The return value is the local time zone, measured in - * minutes away from GMT (-ve for east, +ve for west). + * The return value is the local time zone, measured in minutes away from + * GMT (-ve for east, +ve for west). * * Side effects: * None. @@ -144,102 +149,101 @@ TclpGetClicks() */ int -TclpGetTimeZone (currentTime) - unsigned long currentTime; +TclpGetTimeZone(currentTime) + unsigned long currentTime; { + int timeZone; + /* - * We prefer first to use the time zone in "struct tm" if the - * structure contains such a member. Following that, we try - * to locate the external 'timezone' variable and use its value. - * If both of those methods fail, we attempt to convert a known - * time to local time and use the difference from UTC as the local - * time zone. In all cases, we need to undo any Daylight Saving Time - * adjustment. + * We prefer first to use the time zone in "struct tm" if the structure + * contains such a member. Following that, we try to locate the external + * 'timezone' variable and use its value. If both of those methods fail, + * we attempt to convert a known time to local time and use the difference + * from UTC as the local time zone. In all cases, we need to undo any + * Daylight Saving Time adjustment. */ - -#if defined(HAVE_TM_TZADJ) -# define TCL_GOT_TIMEZONE - /* Struct tm contains tm_tzadj - that value may be used. */ +#if defined(HAVE_TM_TZADJ) +#define TCL_GOT_TIMEZONE + /* + * Struct tm contains tm_tzadj - that value may be used. + */ - time_t curTime = (time_t) currentTime; - struct tm *timeDataPtr = TclpLocaltime(&curTime); - int timeZone; + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = TclpLocaltime(&curTime); timeZone = timeDataPtr->tm_tzadj / 60; if (timeDataPtr->tm_isdst) { - timeZone += 60; + timeZone += 60; } - - return timeZone; - #endif #if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) -# define TCL_GOT_TIMEZONE - - /* Struct tm contains tm_gmtoff - that value may be used. */ +#define TCL_GOT_TIMEZONE + /* + * Struct tm contains tm_gmtoff - that value may be used. + */ - time_t curTime = (time_t) currentTime; + time_t curTime = (time_t) currentTime; struct tm *timeDataPtr = TclpLocaltime(&curTime); - int timeZone; timeZone = -(timeDataPtr->tm_gmtoff / 60); if (timeDataPtr->tm_isdst) { - timeZone += 60; + timeZone += 60; } - - return timeZone; - #endif #if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ) -# define TCL_GOT_TIMEZONE - - int timeZone; - - /* The 'timezone' external var is present and may be used. */ +#define TCL_GOT_TIMEZONE + /* + * The 'timezone' external var is present and may be used. + */ SetTZIfNecessary(); /* - * Note: this is not a typo in "timezone" below! See tzset - * documentation for details. + * Note: this is not a typo in "timezone" below! See tzset documentation + * for details. */ timeZone = timezone / 60; - return timeZone; - #endif -#if !defined(TCL_GOT_TIMEZONE) -#define TCL_GOT_TIMEZONE 1 +#if !defined(TCL_GOT_TIMEZONE) +#define TCL_GOT_TIMEZONE /* * Fallback - determine time zone with a known reference time. */ - int timeZone; time_t tt; struct tm *stm; - tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ - stm = TclpLocaltime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ - /* The calculation below assumes a max of +12 or -12 hours from GMT */ + + tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ + stm = TclpLocaltime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */ + + /* + * The calculation below assumes a max of +12 or -12 hours from GMT. + */ + timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min); - if ( stm -> tm_isdst ) { + if (stm->tm_isdst) { timeZone += 60; } - return timeZone; /* eg +360 for CST6CDT */ + + /* + * Now have offset for our known reference time, eg +360 for CST6CDT. + */ #endif #ifndef TCL_GOT_TIMEZONE /* - * Cause compile error, we don't know how to get timezone. + * Cause fatal compile error, we don't know how to get timezone. */ -#error autoconf did not figure out how to determine the timezone. - +#error autoconf did not figure out how to determine the timezone. #endif + return timeZone; } /* @@ -247,11 +251,11 @@ TclpGetTimeZone (currentTime) * * Tcl_GetTime -- * - * Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in seconds and microseconds since the + * beginning of the epoch: 00:00 UCT, January 1, 1970. * - * This function is hooked, allowing users to specify their - * own virtual system time. + * This function is hooked, allowing users to specify their own virtual + * system time. * * Results: * Returns the current time in timePtr. @@ -274,9 +278,9 @@ Tcl_GetTime(timePtr) * * TclpGetDate -- * - * This function converts between seconds and struct tm. If - * useGMT is true, then the returned date will be in Greenwich - * Mean Time (GMT). Otherwise, it will be in the local time zone. + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. * * Results: * Returns a static tm structure. @@ -317,35 +321,37 @@ TclpGetDate(time, useGMT) */ struct tm * -TclpGmtime( timePtr ) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch */ - +TclpGmtime(timePtr) + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* * Get a thread-local buffer to hold the returned time. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey ); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); + #ifdef HAVE_GMTIME_R - gmtime_r(timePtr, &( tsdPtr->gmtime_buf )); + gmtime_r(timePtr, &(tsdPtr->gmtime_buf)); #else - Tcl_MutexLock( &tmMutex ); - memcpy( (VOID *) &( tsdPtr->gmtime_buf ), - (VOID *) gmtime( timePtr ), - sizeof( struct tm ) ); - Tcl_MutexUnlock( &tmMutex ); -#endif - return &( tsdPtr->gmtime_buf ); + Tcl_MutexLock(&tmMutex); + memcpy((VOID *) &(tsdPtr->gmtime_buf), (VOID *) gmtime(timePtr), + sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + + return &(tsdPtr->gmtime_buf); } + /* * Forwarder for obsolete item in Stubs */ + struct tm* -TclpGmtime_unix( timePtr ) - CONST time_t* timePtr; +TclpGmtime_unix(timePtr) + CONST time_t *timePtr; { - return TclpGmtime( timePtr ); + return TclpGmtime(timePtr); } /* @@ -367,35 +373,35 @@ TclpGmtime_unix( timePtr ) struct tm * TclpLocaltime(timePtr) - CONST time_t *timePtr; /* Pointer to the number of seconds - * since the local system's epoch */ - + CONST time_t *timePtr; /* Pointer to the number of seconds since the + * local system's epoch */ { /* * Get a thread-local buffer to hold the returned time. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey ); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); + SetTZIfNecessary(); #ifdef HAVE_LOCALTIME_R - localtime_r( timePtr, &( tsdPtr->localtime_buf ) ); + localtime_r(timePtr, &(tsdPtr->localtime_buf)); #else - Tcl_MutexLock( &tmMutex ); - memcpy( (VOID *) &( tsdPtr -> localtime_buf ), - (VOID *) localtime( timePtr ), - sizeof( struct tm ) ); - Tcl_MutexUnlock( &tmMutex ); -#endif - return &( tsdPtr->localtime_buf ); + Tcl_MutexLock(&tmMutex); + memcpy((VOID *) &(tsdPtr->localtime_buf), (VOID *) localtime(timePtr), + sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + + return &(tsdPtr->localtime_buf); } /* * Forwarder for obsolete item in Stubs */ struct tm* -TclpLocaltime_unix( timePtr ) - CONST time_t* timePtr; +TclpLocaltime_unix(timePtr) + CONST time_t *timePtr; { - return TclpLocaltime( timePtr ); + return TclpLocaltime(timePtr); } /* @@ -403,9 +409,8 @@ TclpLocaltime_unix( timePtr ) * * Tcl_SetTimeProc -- * - * TIP #233 (Virtualized Time) - * Registers two handlers for the virtualization of Tcl's - * access to time information. + * TIP #233 (Virtualized Time): Registers two handlers for the + * virtualization of Tcl's access to time information. * * Results: * None. @@ -417,14 +422,14 @@ TclpLocaltime_unix( timePtr ) */ void -Tcl_SetTimeProc (getProc, scaleProc, clientData) - Tcl_GetTimeProc* getProc; - Tcl_ScaleTimeProc* scaleProc; - ClientData clientData; +Tcl_SetTimeProc(getProc, scaleProc, clientData) + Tcl_GetTimeProc *getProc; + Tcl_ScaleTimeProc *scaleProc; + ClientData clientData; { - tclGetTimeProcPtr = getProc; + tclGetTimeProcPtr = getProc; tclScaleTimeProcPtr = scaleProc; - tclTimeClientData = clientData; + tclTimeClientData = clientData; } /* @@ -432,8 +437,7 @@ Tcl_SetTimeProc (getProc, scaleProc, clientData) * * Tcl_QueryTimeProc -- * - * TIP #233 (Virtualized Time) - * Query which time handlers are registered. + * TIP #233 (Virtualized Time): Query which time handlers are registered. * * Results: * None. @@ -445,19 +449,19 @@ Tcl_SetTimeProc (getProc, scaleProc, clientData) */ void -Tcl_QueryTimeProc (getProc, scaleProc, clientData) - Tcl_GetTimeProc** getProc; - Tcl_ScaleTimeProc** scaleProc; - ClientData* clientData; +Tcl_QueryTimeProc(getProc, scaleProc, clientData) + Tcl_GetTimeProc **getProc; + Tcl_ScaleTimeProc **scaleProc; + ClientData *clientData; { if (getProc) { - *getProc = tclGetTimeProcPtr; + *getProc = tclGetTimeProcPtr; } if (scaleProc) { - *scaleProc = tclScaleTimeProcPtr; + *scaleProc = tclScaleTimeProcPtr; } if (clientData) { - *clientData = tclTimeClientData; + *clientData = tclTimeClientData; } } @@ -466,9 +470,8 @@ Tcl_QueryTimeProc (getProc, scaleProc, clientData) * * NativeScaleTime -- * - * TIP #233 - * Scale from virtual time to the real-time. For native scaling the - * relationship is 1:1 and nothing has to be done. + * TIP #233: Scale from virtual time to the real-time. For native scaling + * the relationship is 1:1 and nothing has to be done. * * Results: * Scales the time in timePtr. @@ -480,11 +483,11 @@ Tcl_QueryTimeProc (getProc, scaleProc, clientData) */ static void -NativeScaleTime (timePtr, clientData) - Tcl_Time* timePtr; - ClientData clientData; +NativeScaleTime(timePtr, clientData) + Tcl_Time *timePtr; + ClientData clientData; { - /* Native scale is 1:1. Nothing is done */ + /* Native scale is 1:1. Nothing is done */ } /* @@ -492,8 +495,7 @@ NativeScaleTime (timePtr, clientData) * * NativeGetTime -- * - * TIP #233 - * Gets the current system time in seconds and microseconds + * TIP #233: Gets the current system time in seconds and microseconds * since the beginning of the epoch: 00:00 UCT, January 1, 1970. * * Results: @@ -506,15 +508,15 @@ NativeScaleTime (timePtr, clientData) */ static void -NativeGetTime (timePtr, clientData) - Tcl_Time* timePtr; - ClientData clientData; +NativeGetTime(timePtr, clientData) + Tcl_Time *timePtr; + ClientData clientData; { struct timeval tv; struct timezone tz; (void) gettimeofday(&tv, &tz); - timePtr->sec = tv.tv_sec; + timePtr->sec = tv.tv_sec; timePtr->usec = tv.tv_usec; } /* @@ -522,49 +524,49 @@ NativeGetTime (timePtr, clientData) * * SetTZIfNecessary -- * - * Determines whether a call to 'tzset' is needed prior to the - * next call to 'localtime' or examination of the 'timezone' variable. + * Determines whether a call to 'tzset' is needed prior to the next call + * to 'localtime' or examination of the 'timezone' variable. * * Results: * None. * * Side effects: - * If 'tzset' has never been called in the current process, or if - * the value of the environment variable TZ has changed since the - * last call to 'tzset', then 'tzset' is called again. + * If 'tzset' has never been called in the current process, or if the + * value of the environment variable TZ has changed since the last call + * to 'tzset', then 'tzset' is called again. * *---------------------------------------------------------------------- */ static void -SetTZIfNecessary() { +SetTZIfNecessary() +{ + CONST char *newTZ = getenv("TZ"); - CONST char* newTZ = getenv( "TZ" ); Tcl_MutexLock(&tmMutex); - if ( newTZ == NULL ) { + if (newTZ == NULL) { newTZ = ""; } - if ( lastTZ == NULL || strcmp( lastTZ, newTZ ) ) { - tzset(); - if ( lastTZ == NULL ) { - Tcl_CreateExitHandler( CleanupMemory, (ClientData) NULL ); + if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { + tzset(); + if (lastTZ == NULL) { + Tcl_CreateExitHandler(CleanupMemory, (ClientData) NULL); } else { - Tcl_Free( lastTZ ); + Tcl_Free(lastTZ); } - lastTZ = Tcl_Alloc( strlen( newTZ ) + 1 ); - strcpy( lastTZ, newTZ ); + lastTZ = Tcl_Alloc(strlen(newTZ) + 1); + strcpy(lastTZ, newTZ); } Tcl_MutexUnlock(&tmMutex); - } - + /* *---------------------------------------------------------------------- * * CleanupMemory -- * - * Releases the private copy of the TZ environment variable - * upon exit from Tcl. + * Releases the private copy of the TZ environment variable upon exit + * from Tcl. * * Results: * None. @@ -576,7 +578,15 @@ SetTZIfNecessary() { */ static void -CleanupMemory( ClientData ignored ) +CleanupMemory(ClientData ignored) { - Tcl_Free( lastTZ ); + Tcl_Free(lastTZ); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |