summaryrefslogtreecommitdiffstats
path: root/unix
diff options
context:
space:
mode:
Diffstat (limited to 'unix')
-rw-r--r--unix/tclAppInit.c72
-rw-r--r--unix/tclUnixChan.c793
-rw-r--r--unix/tclUnixEvent.c29
-rw-r--r--unix/tclUnixFCmd.c1187
-rw-r--r--unix/tclUnixFile.c498
-rw-r--r--unix/tclUnixInit.c458
-rw-r--r--unix/tclUnixThrd.c261
-rw-r--r--unix/tclUnixTime.c370
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:
+ */