/*
|
/*
|
* tclIOUtil.c --
|
* tclIOUtil.c --
|
*
|
*
|
* This file contains a collection of utility procedures that
|
* This file contains a collection of utility procedures that
|
* are shared by the platform specific IO drivers.
|
* are shared by the platform specific IO drivers.
|
*
|
*
|
* Parts of this file are based on code contributed by Karl
|
* Parts of this file are based on code contributed by Karl
|
* Lehenbauer, Mark Diekhans and Peter da Silva.
|
* Lehenbauer, Mark Diekhans and Peter da Silva.
|
*
|
*
|
* Copyright (c) 1991-1994 The Regents of the University of California.
|
* Copyright (c) 1991-1994 The Regents of the University of California.
|
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclIOUtil.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
|
* RCS: @(#) $Id: tclIOUtil.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
|
|
/*
|
/*
|
* The following typedef declarations allow for hooking into the chain
|
* The following typedef declarations allow for hooking into the chain
|
* of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
|
* of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
|
* 'Tcl_OpenFileChannel(...)'. Basically for each hookable function
|
* 'Tcl_OpenFileChannel(...)'. Basically for each hookable function
|
* a linked list is defined.
|
* a linked list is defined.
|
*/
|
*/
|
|
|
typedef struct StatProc {
|
typedef struct StatProc {
|
TclStatProc_ *proc; /* Function to process a 'stat()' call */
|
TclStatProc_ *proc; /* Function to process a 'stat()' call */
|
struct StatProc *nextPtr; /* The next 'stat()' function to call */
|
struct StatProc *nextPtr; /* The next 'stat()' function to call */
|
} StatProc;
|
} StatProc;
|
|
|
typedef struct AccessProc {
|
typedef struct AccessProc {
|
TclAccessProc_ *proc; /* Function to process a 'access()' call */
|
TclAccessProc_ *proc; /* Function to process a 'access()' call */
|
struct AccessProc *nextPtr; /* The next 'access()' function to call */
|
struct AccessProc *nextPtr; /* The next 'access()' function to call */
|
} AccessProc;
|
} AccessProc;
|
|
|
typedef struct OpenFileChannelProc {
|
typedef struct OpenFileChannelProc {
|
TclOpenFileChannelProc_ *proc; /* Function to process a
|
TclOpenFileChannelProc_ *proc; /* Function to process a
|
* 'Tcl_OpenFileChannel()' call */
|
* 'Tcl_OpenFileChannel()' call */
|
struct OpenFileChannelProc *nextPtr;
|
struct OpenFileChannelProc *nextPtr;
|
/* The next 'Tcl_OpenFileChannel()'
|
/* The next 'Tcl_OpenFileChannel()'
|
* function to call */
|
* function to call */
|
} OpenFileChannelProc;
|
} OpenFileChannelProc;
|
|
|
/*
|
/*
|
* For each type of hookable function, a static node is declared to
|
* For each type of hookable function, a static node is declared to
|
* hold the function pointer for the "built-in" routine (e.g.
|
* hold the function pointer for the "built-in" routine (e.g.
|
* 'TclpStat(...)') and the respective list is initialized as a pointer
|
* 'TclpStat(...)') and the respective list is initialized as a pointer
|
* to that node.
|
* to that node.
|
*
|
*
|
* The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
|
* The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
|
* these statically declared list entry cannot be inadvertently removed.
|
* these statically declared list entry cannot be inadvertently removed.
|
*
|
*
|
* This method avoids the need to call any sort of "initialization"
|
* This method avoids the need to call any sort of "initialization"
|
* function
|
* function
|
*/
|
*/
|
|
|
static StatProc defaultStatProc = {
|
static StatProc defaultStatProc = {
|
&TclpStat, NULL
|
&TclpStat, NULL
|
};
|
};
|
static StatProc *statProcList = &defaultStatProc;
|
static StatProc *statProcList = &defaultStatProc;
|
|
|
static AccessProc defaultAccessProc = {
|
static AccessProc defaultAccessProc = {
|
&TclpAccess, NULL
|
&TclpAccess, NULL
|
};
|
};
|
static AccessProc *accessProcList = &defaultAccessProc;
|
static AccessProc *accessProcList = &defaultAccessProc;
|
|
|
static OpenFileChannelProc defaultOpenFileChannelProc = {
|
static OpenFileChannelProc defaultOpenFileChannelProc = {
|
&TclpOpenFileChannel, NULL
|
&TclpOpenFileChannel, NULL
|
};
|
};
|
static OpenFileChannelProc *openFileChannelProcList =
|
static OpenFileChannelProc *openFileChannelProcList =
|
&defaultOpenFileChannelProc;
|
&defaultOpenFileChannelProc;
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclGetOpenMode --
|
* TclGetOpenMode --
|
*
|
*
|
* Description:
|
* Description:
|
* Computes a POSIX mode mask for opening a file, from a given string,
|
* Computes a POSIX mode mask for opening a file, from a given string,
|
* and also sets a flag to indicate whether the caller should seek to
|
* and also sets a flag to indicate whether the caller should seek to
|
* EOF after opening the file.
|
* EOF after opening the file.
|
*
|
*
|
* Results:
|
* Results:
|
* On success, returns mode to pass to "open". If an error occurs, the
|
* On success, returns mode to pass to "open". If an error occurs, the
|
* returns -1 and if interp is not NULL, sets interp->result to an
|
* returns -1 and if interp is not NULL, sets interp->result to an
|
* error message.
|
* error message.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Sets the integer referenced by seekFlagPtr to 1 to tell the caller
|
* Sets the integer referenced by seekFlagPtr to 1 to tell the caller
|
* to seek to EOF after opening the file.
|
* to seek to EOF after opening the file.
|
*
|
*
|
* Special note:
|
* Special note:
|
* This code is based on a prototype implementation contributed
|
* This code is based on a prototype implementation contributed
|
* by Mark Diekhans.
|
* by Mark Diekhans.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclGetOpenMode(interp, string, seekFlagPtr)
|
TclGetOpenMode(interp, string, seekFlagPtr)
|
Tcl_Interp *interp; /* Interpreter to use for error
|
Tcl_Interp *interp; /* Interpreter to use for error
|
* reporting - may be NULL. */
|
* reporting - may be NULL. */
|
char *string; /* Mode string, e.g. "r+" or
|
char *string; /* Mode string, e.g. "r+" or
|
* "RDONLY CREAT". */
|
* "RDONLY CREAT". */
|
int *seekFlagPtr; /* Set this to 1 if the caller
|
int *seekFlagPtr; /* Set this to 1 if the caller
|
* should seek to EOF during the
|
* should seek to EOF during the
|
* opening of the file. */
|
* opening of the file. */
|
{
|
{
|
int mode, modeArgc, c, i, gotRW;
|
int mode, modeArgc, c, i, gotRW;
|
char **modeArgv, *flag;
|
char **modeArgv, *flag;
|
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
|
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
|
|
|
/*
|
/*
|
* Check for the simpler fopen-like access modes (e.g. "r"). They
|
* Check for the simpler fopen-like access modes (e.g. "r"). They
|
* are distinguished from the POSIX access modes by the presence
|
* are distinguished from the POSIX access modes by the presence
|
* of a lower-case first letter.
|
* of a lower-case first letter.
|
*/
|
*/
|
|
|
*seekFlagPtr = 0;
|
*seekFlagPtr = 0;
|
mode = 0;
|
mode = 0;
|
if (islower(UCHAR(string[0]))) {
|
if (islower(UCHAR(string[0]))) {
|
switch (string[0]) {
|
switch (string[0]) {
|
case 'r':
|
case 'r':
|
mode = O_RDONLY;
|
mode = O_RDONLY;
|
break;
|
break;
|
case 'w':
|
case 'w':
|
mode = O_WRONLY|O_CREAT|O_TRUNC;
|
mode = O_WRONLY|O_CREAT|O_TRUNC;
|
break;
|
break;
|
case 'a':
|
case 'a':
|
mode = O_WRONLY|O_CREAT;
|
mode = O_WRONLY|O_CREAT;
|
*seekFlagPtr = 1;
|
*seekFlagPtr = 1;
|
break;
|
break;
|
default:
|
default:
|
error:
|
error:
|
if (interp != (Tcl_Interp *) NULL) {
|
if (interp != (Tcl_Interp *) NULL) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"illegal access mode \"", string, "\"",
|
"illegal access mode \"", string, "\"",
|
(char *) NULL);
|
(char *) NULL);
|
}
|
}
|
return -1;
|
return -1;
|
}
|
}
|
if (string[1] == '+') {
|
if (string[1] == '+') {
|
mode &= ~(O_RDONLY|O_WRONLY);
|
mode &= ~(O_RDONLY|O_WRONLY);
|
mode |= O_RDWR;
|
mode |= O_RDWR;
|
if (string[2] != 0) {
|
if (string[2] != 0) {
|
goto error;
|
goto error;
|
}
|
}
|
} else if (string[1] != 0) {
|
} else if (string[1] != 0) {
|
goto error;
|
goto error;
|
}
|
}
|
return mode;
|
return mode;
|
}
|
}
|
|
|
/*
|
/*
|
* The access modes are specified using a list of POSIX modes
|
* The access modes are specified using a list of POSIX modes
|
* such as O_CREAT.
|
* such as O_CREAT.
|
*
|
*
|
* IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
|
* IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
|
* a NULL interpreter is passed in.
|
* a NULL interpreter is passed in.
|
*/
|
*/
|
|
|
if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
|
if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
|
if (interp != (Tcl_Interp *) NULL) {
|
if (interp != (Tcl_Interp *) NULL) {
|
Tcl_AddErrorInfo(interp,
|
Tcl_AddErrorInfo(interp,
|
"\n while processing open access modes \"");
|
"\n while processing open access modes \"");
|
Tcl_AddErrorInfo(interp, string);
|
Tcl_AddErrorInfo(interp, string);
|
Tcl_AddErrorInfo(interp, "\"");
|
Tcl_AddErrorInfo(interp, "\"");
|
}
|
}
|
return -1;
|
return -1;
|
}
|
}
|
|
|
gotRW = 0;
|
gotRW = 0;
|
for (i = 0; i < modeArgc; i++) {
|
for (i = 0; i < modeArgc; i++) {
|
flag = modeArgv[i];
|
flag = modeArgv[i];
|
c = flag[0];
|
c = flag[0];
|
if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
|
if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
|
mode = (mode & ~RW_MODES) | O_RDONLY;
|
mode = (mode & ~RW_MODES) | O_RDONLY;
|
gotRW = 1;
|
gotRW = 1;
|
} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
|
} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
|
mode = (mode & ~RW_MODES) | O_WRONLY;
|
mode = (mode & ~RW_MODES) | O_WRONLY;
|
gotRW = 1;
|
gotRW = 1;
|
} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
|
} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
|
mode = (mode & ~RW_MODES) | O_RDWR;
|
mode = (mode & ~RW_MODES) | O_RDWR;
|
gotRW = 1;
|
gotRW = 1;
|
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
|
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
|
mode |= O_APPEND;
|
mode |= O_APPEND;
|
*seekFlagPtr = 1;
|
*seekFlagPtr = 1;
|
} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
|
} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
|
mode |= O_CREAT;
|
mode |= O_CREAT;
|
} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
|
} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
|
mode |= O_EXCL;
|
mode |= O_EXCL;
|
} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
|
} else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
|
#ifdef O_NOCTTY
|
#ifdef O_NOCTTY
|
mode |= O_NOCTTY;
|
mode |= O_NOCTTY;
|
#else
|
#else
|
if (interp != (Tcl_Interp *) NULL) {
|
if (interp != (Tcl_Interp *) NULL) {
|
Tcl_AppendResult(interp, "access mode \"", flag,
|
Tcl_AppendResult(interp, "access mode \"", flag,
|
"\" not supported by this system", (char *) NULL);
|
"\" not supported by this system", (char *) NULL);
|
}
|
}
|
ckfree((char *) modeArgv);
|
ckfree((char *) modeArgv);
|
return -1;
|
return -1;
|
#endif
|
#endif
|
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
|
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
|
#if defined(O_NDELAY) || defined(O_NONBLOCK)
|
#if defined(O_NDELAY) || defined(O_NONBLOCK)
|
# ifdef O_NONBLOCK
|
# ifdef O_NONBLOCK
|
mode |= O_NONBLOCK;
|
mode |= O_NONBLOCK;
|
# else
|
# else
|
mode |= O_NDELAY;
|
mode |= O_NDELAY;
|
# endif
|
# endif
|
#else
|
#else
|
if (interp != (Tcl_Interp *) NULL) {
|
if (interp != (Tcl_Interp *) NULL) {
|
Tcl_AppendResult(interp, "access mode \"", flag,
|
Tcl_AppendResult(interp, "access mode \"", flag,
|
"\" not supported by this system", (char *) NULL);
|
"\" not supported by this system", (char *) NULL);
|
}
|
}
|
ckfree((char *) modeArgv);
|
ckfree((char *) modeArgv);
|
return -1;
|
return -1;
|
#endif
|
#endif
|
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
|
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
|
mode |= O_TRUNC;
|
mode |= O_TRUNC;
|
} else {
|
} else {
|
if (interp != (Tcl_Interp *) NULL) {
|
if (interp != (Tcl_Interp *) NULL) {
|
Tcl_AppendResult(interp, "invalid access mode \"", flag,
|
Tcl_AppendResult(interp, "invalid access mode \"", flag,
|
"\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
|
"\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
|
" EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
|
" EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
|
}
|
}
|
ckfree((char *) modeArgv);
|
ckfree((char *) modeArgv);
|
return -1;
|
return -1;
|
}
|
}
|
}
|
}
|
ckfree((char *) modeArgv);
|
ckfree((char *) modeArgv);
|
if (!gotRW) {
|
if (!gotRW) {
|
if (interp != (Tcl_Interp *) NULL) {
|
if (interp != (Tcl_Interp *) NULL) {
|
Tcl_AppendResult(interp, "access mode must include either",
|
Tcl_AppendResult(interp, "access mode must include either",
|
" RDONLY, WRONLY, or RDWR", (char *) NULL);
|
" RDONLY, WRONLY, or RDWR", (char *) NULL);
|
}
|
}
|
return -1;
|
return -1;
|
}
|
}
|
return mode;
|
return mode;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_EvalFile --
|
* Tcl_EvalFile --
|
*
|
*
|
* Read in a file and process the entire file as one gigantic
|
* Read in a file and process the entire file as one gigantic
|
* Tcl command.
|
* Tcl command.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result, which is either the result of executing
|
* A standard Tcl result, which is either the result of executing
|
* the file or an error indicating why the file couldn't be read.
|
* the file or an error indicating why the file couldn't be read.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Depends on the commands in the file.
|
* Depends on the commands in the file.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_EvalFile(interp, fileName)
|
Tcl_EvalFile(interp, fileName)
|
Tcl_Interp *interp; /* Interpreter in which to process file. */
|
Tcl_Interp *interp; /* Interpreter in which to process file. */
|
char *fileName; /* Name of file to process. Tilde-substitution
|
char *fileName; /* Name of file to process. Tilde-substitution
|
* will be performed on this name. */
|
* will be performed on this name. */
|
{
|
{
|
int result;
|
int result;
|
struct stat statBuf;
|
struct stat statBuf;
|
char *cmdBuffer = (char *) NULL;
|
char *cmdBuffer = (char *) NULL;
|
char *oldScriptFile;
|
char *oldScriptFile;
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
char *nativeName;
|
char *nativeName;
|
Tcl_Channel chan;
|
Tcl_Channel chan;
|
Tcl_Obj *cmdObjPtr;
|
Tcl_Obj *cmdObjPtr;
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
oldScriptFile = iPtr->scriptFile;
|
oldScriptFile = iPtr->scriptFile;
|
iPtr->scriptFile = fileName;
|
iPtr->scriptFile = fileName;
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
|
nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
|
if (nativeName == NULL) {
|
if (nativeName == NULL) {
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/*
|
/*
|
* If Tcl_TranslateFileName didn't already copy the file name, do it
|
* If Tcl_TranslateFileName didn't already copy the file name, do it
|
* here. This way we don't depend on fileName staying constant
|
* here. This way we don't depend on fileName staying constant
|
* throughout the execution of the script (e.g., what if it happens
|
* throughout the execution of the script (e.g., what if it happens
|
* to point to a Tcl variable that the script could change?).
|
* to point to a Tcl variable that the script could change?).
|
*/
|
*/
|
|
|
if (nativeName != Tcl_DStringValue(&buffer)) {
|
if (nativeName != Tcl_DStringValue(&buffer)) {
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringAppend(&buffer, nativeName, -1);
|
Tcl_DStringAppend(&buffer, nativeName, -1);
|
nativeName = Tcl_DStringValue(&buffer);
|
nativeName = Tcl_DStringValue(&buffer);
|
}
|
}
|
if (TclStat(nativeName, &statBuf) == -1) {
|
if (TclStat(nativeName, &statBuf) == -1) {
|
Tcl_SetErrno(errno);
|
Tcl_SetErrno(errno);
|
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
|
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
goto error;
|
goto error;
|
}
|
}
|
chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644);
|
chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
|
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
goto error;
|
goto error;
|
}
|
}
|
cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
|
cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
|
result = Tcl_Read(chan, cmdBuffer, statBuf.st_size);
|
result = Tcl_Read(chan, cmdBuffer, statBuf.st_size);
|
if (result < 0) {
|
if (result < 0) {
|
Tcl_Close(interp, chan);
|
Tcl_Close(interp, chan);
|
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
|
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
"\": ", Tcl_PosixError(interp), (char *) NULL);
|
goto error;
|
goto error;
|
}
|
}
|
cmdBuffer[result] = 0;
|
cmdBuffer[result] = 0;
|
if (Tcl_Close(interp, chan) != TCL_OK) {
|
if (Tcl_Close(interp, chan) != TCL_OK) {
|
goto error;
|
goto error;
|
}
|
}
|
|
|
/*
|
/*
|
* Transfer the buffer memory allocated above to the object system.
|
* Transfer the buffer memory allocated above to the object system.
|
* Tcl_EvalObj will own this new string object if needed,
|
* Tcl_EvalObj will own this new string object if needed,
|
* so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer)
|
* so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer)
|
* but rather use the reference counting mechanism.
|
* but rather use the reference counting mechanism.
|
* (Nb: and we must not thus not use goto error after this point)
|
* (Nb: and we must not thus not use goto error after this point)
|
*/
|
*/
|
cmdObjPtr = Tcl_NewObj();
|
cmdObjPtr = Tcl_NewObj();
|
cmdObjPtr->bytes = cmdBuffer;
|
cmdObjPtr->bytes = cmdBuffer;
|
cmdObjPtr->length = result;
|
cmdObjPtr->length = result;
|
|
|
Tcl_IncrRefCount(cmdObjPtr);
|
Tcl_IncrRefCount(cmdObjPtr);
|
result = Tcl_EvalObj(interp, cmdObjPtr);
|
result = Tcl_EvalObj(interp, cmdObjPtr);
|
Tcl_DecrRefCount(cmdObjPtr);
|
Tcl_DecrRefCount(cmdObjPtr);
|
|
|
if (result == TCL_RETURN) {
|
if (result == TCL_RETURN) {
|
result = TclUpdateReturnInfo(iPtr);
|
result = TclUpdateReturnInfo(iPtr);
|
} else if (result == TCL_ERROR) {
|
} else if (result == TCL_ERROR) {
|
char msg[200];
|
char msg[200];
|
|
|
/*
|
/*
|
* Record information telling where the error occurred.
|
* Record information telling where the error occurred.
|
*/
|
*/
|
|
|
sprintf(msg, "\n (file \"%.150s\" line %d)", fileName,
|
sprintf(msg, "\n (file \"%.150s\" line %d)", fileName,
|
interp->errorLine);
|
interp->errorLine);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
}
|
}
|
iPtr->scriptFile = oldScriptFile;
|
iPtr->scriptFile = oldScriptFile;
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return result;
|
return result;
|
|
|
error:
|
error:
|
if (cmdBuffer != (char *) NULL) {
|
if (cmdBuffer != (char *) NULL) {
|
ckfree(cmdBuffer);
|
ckfree(cmdBuffer);
|
}
|
}
|
iPtr->scriptFile = oldScriptFile;
|
iPtr->scriptFile = oldScriptFile;
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetErrno --
|
* Tcl_GetErrno --
|
*
|
*
|
* Gets the current value of the Tcl error code variable. This is
|
* Gets the current value of the Tcl error code variable. This is
|
* currently the global variable "errno" but could in the future
|
* currently the global variable "errno" but could in the future
|
* change to something else.
|
* change to something else.
|
*
|
*
|
* Results:
|
* Results:
|
* The value of the Tcl error code variable.
|
* The value of the Tcl error code variable.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None. Note that the value of the Tcl error code variable is
|
* None. Note that the value of the Tcl error code variable is
|
* UNDEFINED if a call to Tcl_SetErrno did not precede this call.
|
* UNDEFINED if a call to Tcl_SetErrno did not precede this call.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_GetErrno()
|
Tcl_GetErrno()
|
{
|
{
|
return errno;
|
return errno;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SetErrno --
|
* Tcl_SetErrno --
|
*
|
*
|
* Sets the Tcl error code variable to the supplied value.
|
* Sets the Tcl error code variable to the supplied value.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Modifies the value of the Tcl error code variable.
|
* Modifies the value of the Tcl error code variable.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
void
|
void
|
Tcl_SetErrno(err)
|
Tcl_SetErrno(err)
|
int err; /* The new value. */
|
int err; /* The new value. */
|
{
|
{
|
errno = err;
|
errno = err;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_PosixError --
|
* Tcl_PosixError --
|
*
|
*
|
* This procedure is typically called after UNIX kernel calls
|
* This procedure is typically called after UNIX kernel calls
|
* return errors. It stores machine-readable information about
|
* return errors. It stores machine-readable information about
|
* the error in $errorCode returns an information string for
|
* the error in $errorCode returns an information string for
|
* the caller's use.
|
* the caller's use.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a human-readable string describing the
|
* The return value is a human-readable string describing the
|
* error.
|
* error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* The global variable $errorCode is reset.
|
* The global variable $errorCode is reset.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
char *
|
char *
|
Tcl_PosixError(interp)
|
Tcl_PosixError(interp)
|
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
|
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
|
* is to be changed. */
|
* is to be changed. */
|
{
|
{
|
char *id, *msg;
|
char *id, *msg;
|
|
|
msg = Tcl_ErrnoMsg(errno);
|
msg = Tcl_ErrnoMsg(errno);
|
id = Tcl_ErrnoId();
|
id = Tcl_ErrnoId();
|
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
|
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
|
return msg;
|
return msg;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclStat --
|
* TclStat --
|
*
|
*
|
* This procedure replaces the library version of stat and lsat.
|
* This procedure replaces the library version of stat and lsat.
|
* The chain of functions that have been "inserted" into the
|
* The chain of functions that have been "inserted" into the
|
* 'statProcList' will be called in succession until either
|
* 'statProcList' will be called in succession until either
|
* a value of zero is returned, or the entire list is visited.
|
* a value of zero is returned, or the entire list is visited.
|
*
|
*
|
* Results:
|
* Results:
|
* See stat documentation.
|
* See stat documentation.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See stat documentation.
|
* See stat documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclStat(path, buf)
|
TclStat(path, buf)
|
CONST char *path; /* Path of file to stat (in current CP). */
|
CONST char *path; /* Path of file to stat (in current CP). */
|
TclStat_ *buf; /* Filled with results of stat call. */
|
TclStat_ *buf; /* Filled with results of stat call. */
|
{
|
{
|
StatProc *statProcPtr = statProcList;
|
StatProc *statProcPtr = statProcList;
|
int retVal = -1;
|
int retVal = -1;
|
|
|
/*
|
/*
|
* Call each of the "stat" function in succession. A non-return
|
* Call each of the "stat" function in succession. A non-return
|
* value of -1 indicates the particular function has succeeded.
|
* value of -1 indicates the particular function has succeeded.
|
*/
|
*/
|
|
|
while ((retVal == -1) && (statProcPtr != NULL)) {
|
while ((retVal == -1) && (statProcPtr != NULL)) {
|
retVal = (*statProcPtr->proc)(path, buf);
|
retVal = (*statProcPtr->proc)(path, buf);
|
statProcPtr = statProcPtr->nextPtr;
|
statProcPtr = statProcPtr->nextPtr;
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclAccess --
|
* TclAccess --
|
*
|
*
|
* This procedure replaces the library version of access.
|
* This procedure replaces the library version of access.
|
* The chain of functions that have been "inserted" into the
|
* The chain of functions that have been "inserted" into the
|
* 'accessProcList' will be called in succession until either
|
* 'accessProcList' will be called in succession until either
|
* a value of zero is returned, or the entire list is visited.
|
* a value of zero is returned, or the entire list is visited.
|
*
|
*
|
* Results:
|
* Results:
|
* See access documentation.
|
* See access documentation.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See access documentation.
|
* See access documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclAccess(path, mode)
|
TclAccess(path, mode)
|
CONST char *path; /* Path of file to access (in current CP). */
|
CONST char *path; /* Path of file to access (in current CP). */
|
int mode; /* Permission setting. */
|
int mode; /* Permission setting. */
|
{
|
{
|
AccessProc *accessProcPtr = accessProcList;
|
AccessProc *accessProcPtr = accessProcList;
|
int retVal = -1;
|
int retVal = -1;
|
|
|
/*
|
/*
|
* Call each of the "access" function in succession. A non-return
|
* Call each of the "access" function in succession. A non-return
|
* value of -1 indicates the particular function has succeeded.
|
* value of -1 indicates the particular function has succeeded.
|
*/
|
*/
|
|
|
while ((retVal == -1) && (accessProcPtr != NULL)) {
|
while ((retVal == -1) && (accessProcPtr != NULL)) {
|
retVal = (*accessProcPtr->proc)(path, mode);
|
retVal = (*accessProcPtr->proc)(path, mode);
|
accessProcPtr = accessProcPtr->nextPtr;
|
accessProcPtr = accessProcPtr->nextPtr;
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_OpenFileChannel --
|
* Tcl_OpenFileChannel --
|
*
|
*
|
* The chain of functions that have been "inserted" into the
|
* The chain of functions that have been "inserted" into the
|
* 'openFileChannelProcList' will be called in succession until
|
* 'openFileChannelProcList' will be called in succession until
|
* either a valid file channel is returned, or the entire list is
|
* either a valid file channel is returned, or the entire list is
|
* visited.
|
* visited.
|
*
|
*
|
* Results:
|
* Results:
|
* The new channel or NULL, if the named file could not be opened.
|
* The new channel or NULL, if the named file could not be opened.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May open the channel and may cause creation of a file on the
|
* May open the channel and may cause creation of a file on the
|
* file system.
|
* file system.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Tcl_Channel
|
Tcl_Channel
|
Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
|
Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
|
Tcl_Interp *interp; /* Interpreter for error reporting;
|
Tcl_Interp *interp; /* Interpreter for error reporting;
|
* can be NULL. */
|
* can be NULL. */
|
char *fileName; /* Name of file to open. */
|
char *fileName; /* Name of file to open. */
|
char *modeString; /* A list of POSIX open modes or
|
char *modeString; /* A list of POSIX open modes or
|
* a string such as "rw". */
|
* a string such as "rw". */
|
int permissions; /* If the open involves creating a
|
int permissions; /* If the open involves creating a
|
* file, with what modes to create
|
* file, with what modes to create
|
* it? */
|
* it? */
|
{
|
{
|
OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList;
|
OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList;
|
Tcl_Channel retVal = NULL;
|
Tcl_Channel retVal = NULL;
|
|
|
/*
|
/*
|
* Call each of the "Tcl_OpenFileChannel" function in succession.
|
* Call each of the "Tcl_OpenFileChannel" function in succession.
|
* A non-NULL return value indicates the particular function has
|
* A non-NULL return value indicates the particular function has
|
* succeeded.
|
* succeeded.
|
*/
|
*/
|
|
|
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
|
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
|
retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
|
retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
|
modeString, permissions);
|
modeString, permissions);
|
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
|
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclStatInsertProc --
|
* TclStatInsertProc --
|
*
|
*
|
* Insert the passed procedure pointer at the head of the list of
|
* Insert the passed procedure pointer at the head of the list of
|
* functions which are used during a call to 'TclStat(...)'. The
|
* functions which are used during a call to 'TclStat(...)'. The
|
* passed function should be have exactly like 'TclStat' when called
|
* passed function should be have exactly like 'TclStat' when called
|
* during that time (see 'TclStat(...)' for more informatin).
|
* during that time (see 'TclStat(...)' for more informatin).
|
* The function will be added even if it already in the list.
|
* The function will be added even if it already in the list.
|
*
|
*
|
* Results:
|
* Results:
|
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
|
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
|
* could not be allocated.
|
* could not be allocated.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory allocataed and modifies the link list for 'TclStat'
|
* Memory allocataed and modifies the link list for 'TclStat'
|
* functions.
|
* functions.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclStatInsertProc (proc)
|
TclStatInsertProc (proc)
|
TclStatProc_ *proc;
|
TclStatProc_ *proc;
|
{
|
{
|
int retVal = TCL_ERROR;
|
int retVal = TCL_ERROR;
|
|
|
if (proc != NULL) {
|
if (proc != NULL) {
|
StatProc *newStatProcPtr;
|
StatProc *newStatProcPtr;
|
|
|
newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));;
|
newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));;
|
|
|
if (newStatProcPtr != NULL) {
|
if (newStatProcPtr != NULL) {
|
newStatProcPtr->proc = proc;
|
newStatProcPtr->proc = proc;
|
newStatProcPtr->nextPtr = statProcList;
|
newStatProcPtr->nextPtr = statProcList;
|
statProcList = newStatProcPtr;
|
statProcList = newStatProcPtr;
|
|
|
retVal = TCL_OK;
|
retVal = TCL_OK;
|
}
|
}
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclStatDeleteProc --
|
* TclStatDeleteProc --
|
*
|
*
|
* Removed the passed function pointer from the list of 'TclStat'
|
* Removed the passed function pointer from the list of 'TclStat'
|
* functions. Ensures that the built-in stat function is not
|
* functions. Ensures that the built-in stat function is not
|
* removvable.
|
* removvable.
|
*
|
*
|
* Results:
|
* Results:
|
* TCL_OK if the procedure pointer was successfully removed,
|
* TCL_OK if the procedure pointer was successfully removed,
|
* TCL_ERROR otherwise.
|
* TCL_ERROR otherwise.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory is deallocated and the respective list updated.
|
* Memory is deallocated and the respective list updated.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclStatDeleteProc (proc)
|
TclStatDeleteProc (proc)
|
TclStatProc_ *proc;
|
TclStatProc_ *proc;
|
{
|
{
|
int retVal = TCL_ERROR;
|
int retVal = TCL_ERROR;
|
StatProc *tmpStatProcPtr = statProcList;
|
StatProc *tmpStatProcPtr = statProcList;
|
StatProc *prevStatProcPtr = NULL;
|
StatProc *prevStatProcPtr = NULL;
|
|
|
/*
|
/*
|
* Traverse the 'statProcList' looking for the particular node
|
* Traverse the 'statProcList' looking for the particular node
|
* whose 'proc' member matches 'proc' and remove that one from
|
* whose 'proc' member matches 'proc' and remove that one from
|
* the list. Ensure that the "default" node cannot be removed.
|
* the list. Ensure that the "default" node cannot be removed.
|
*/
|
*/
|
|
|
while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) {
|
while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) {
|
if (tmpStatProcPtr->proc == proc) {
|
if (tmpStatProcPtr->proc == proc) {
|
if (prevStatProcPtr == NULL) {
|
if (prevStatProcPtr == NULL) {
|
statProcList = tmpStatProcPtr->nextPtr;
|
statProcList = tmpStatProcPtr->nextPtr;
|
} else {
|
} else {
|
prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
|
prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
|
}
|
}
|
|
|
Tcl_Free((char *)tmpStatProcPtr);
|
Tcl_Free((char *)tmpStatProcPtr);
|
|
|
retVal = TCL_OK;
|
retVal = TCL_OK;
|
} else {
|
} else {
|
prevStatProcPtr = tmpStatProcPtr;
|
prevStatProcPtr = tmpStatProcPtr;
|
tmpStatProcPtr = tmpStatProcPtr->nextPtr;
|
tmpStatProcPtr = tmpStatProcPtr->nextPtr;
|
}
|
}
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclAccessInsertProc --
|
* TclAccessInsertProc --
|
*
|
*
|
* Insert the passed procedure pointer at the head of the list of
|
* Insert the passed procedure pointer at the head of the list of
|
* functions which are used during a call to 'TclAccess(...)'. The
|
* functions which are used during a call to 'TclAccess(...)'. The
|
* passed function should be have exactly like 'TclAccess' when
|
* passed function should be have exactly like 'TclAccess' when
|
* called during that time (see 'TclAccess(...)' for more informatin).
|
* called during that time (see 'TclAccess(...)' for more informatin).
|
* The function will be added even if it already in the list.
|
* The function will be added even if it already in the list.
|
*
|
*
|
* Results:
|
* Results:
|
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
|
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
|
* could not be allocated.
|
* could not be allocated.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory allocataed and modifies the link list for 'TclAccess'
|
* Memory allocataed and modifies the link list for 'TclAccess'
|
* functions.
|
* functions.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclAccessInsertProc(proc)
|
TclAccessInsertProc(proc)
|
TclAccessProc_ *proc;
|
TclAccessProc_ *proc;
|
{
|
{
|
int retVal = TCL_ERROR;
|
int retVal = TCL_ERROR;
|
|
|
if (proc != NULL) {
|
if (proc != NULL) {
|
AccessProc *newAccessProcPtr;
|
AccessProc *newAccessProcPtr;
|
|
|
newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));;
|
newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));;
|
|
|
if (newAccessProcPtr != NULL) {
|
if (newAccessProcPtr != NULL) {
|
newAccessProcPtr->proc = proc;
|
newAccessProcPtr->proc = proc;
|
newAccessProcPtr->nextPtr = accessProcList;
|
newAccessProcPtr->nextPtr = accessProcList;
|
accessProcList = newAccessProcPtr;
|
accessProcList = newAccessProcPtr;
|
|
|
retVal = TCL_OK;
|
retVal = TCL_OK;
|
}
|
}
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclAccessDeleteProc --
|
* TclAccessDeleteProc --
|
*
|
*
|
* Removed the passed function pointer from the list of 'TclAccess'
|
* Removed the passed function pointer from the list of 'TclAccess'
|
* functions. Ensures that the built-in access function is not
|
* functions. Ensures that the built-in access function is not
|
* removvable.
|
* removvable.
|
*
|
*
|
* Results:
|
* Results:
|
* TCL_OK if the procedure pointer was successfully removed,
|
* TCL_OK if the procedure pointer was successfully removed,
|
* TCL_ERROR otherwise.
|
* TCL_ERROR otherwise.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory is deallocated and the respective list updated.
|
* Memory is deallocated and the respective list updated.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclAccessDeleteProc(proc)
|
TclAccessDeleteProc(proc)
|
TclAccessProc_ *proc;
|
TclAccessProc_ *proc;
|
{
|
{
|
int retVal = TCL_ERROR;
|
int retVal = TCL_ERROR;
|
AccessProc *tmpAccessProcPtr = accessProcList;
|
AccessProc *tmpAccessProcPtr = accessProcList;
|
AccessProc *prevAccessProcPtr = NULL;
|
AccessProc *prevAccessProcPtr = NULL;
|
|
|
/*
|
/*
|
* Traverse the 'accessProcList' looking for the particular node
|
* Traverse the 'accessProcList' looking for the particular node
|
* whose 'proc' member matches 'proc' and remove that one from
|
* whose 'proc' member matches 'proc' and remove that one from
|
* the list. Ensure that the "default" node cannot be removed.
|
* the list. Ensure that the "default" node cannot be removed.
|
*/
|
*/
|
|
|
while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
|
while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
|
if (tmpAccessProcPtr->proc == proc) {
|
if (tmpAccessProcPtr->proc == proc) {
|
if (prevAccessProcPtr == NULL) {
|
if (prevAccessProcPtr == NULL) {
|
accessProcList = tmpAccessProcPtr->nextPtr;
|
accessProcList = tmpAccessProcPtr->nextPtr;
|
} else {
|
} else {
|
prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
|
prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
|
}
|
}
|
|
|
Tcl_Free((char *)tmpAccessProcPtr);
|
Tcl_Free((char *)tmpAccessProcPtr);
|
|
|
retVal = TCL_OK;
|
retVal = TCL_OK;
|
} else {
|
} else {
|
prevAccessProcPtr = tmpAccessProcPtr;
|
prevAccessProcPtr = tmpAccessProcPtr;
|
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
|
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
|
}
|
}
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclOpenFileChannelInsertProc --
|
* TclOpenFileChannelInsertProc --
|
*
|
*
|
* Insert the passed procedure pointer at the head of the list of
|
* Insert the passed procedure pointer at the head of the list of
|
* functions which are used during a call to
|
* functions which are used during a call to
|
* 'Tcl_OpenFileChannel(...)'. The passed function should be have
|
* 'Tcl_OpenFileChannel(...)'. The passed function should be have
|
* exactly like 'Tcl_OpenFileChannel' when called during that time
|
* exactly like 'Tcl_OpenFileChannel' when called during that time
|
* (see 'Tcl_OpenFileChannel(...)' for more informatin). The
|
* (see 'Tcl_OpenFileChannel(...)' for more informatin). The
|
* function will be added even if it already in the list.
|
* function will be added even if it already in the list.
|
*
|
*
|
* Results:
|
* Results:
|
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
|
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
|
* could not be allocated.
|
* could not be allocated.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory allocataed and modifies the link list for
|
* Memory allocataed and modifies the link list for
|
* 'Tcl_OpenFileChannel' functions.
|
* 'Tcl_OpenFileChannel' functions.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclOpenFileChannelInsertProc(proc)
|
TclOpenFileChannelInsertProc(proc)
|
TclOpenFileChannelProc_ *proc;
|
TclOpenFileChannelProc_ *proc;
|
{
|
{
|
int retVal = TCL_ERROR;
|
int retVal = TCL_ERROR;
|
|
|
if (proc != NULL) {
|
if (proc != NULL) {
|
OpenFileChannelProc *newOpenFileChannelProcPtr;
|
OpenFileChannelProc *newOpenFileChannelProcPtr;
|
|
|
newOpenFileChannelProcPtr =
|
newOpenFileChannelProcPtr =
|
(OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));;
|
(OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));;
|
|
|
if (newOpenFileChannelProcPtr != NULL) {
|
if (newOpenFileChannelProcPtr != NULL) {
|
newOpenFileChannelProcPtr->proc = proc;
|
newOpenFileChannelProcPtr->proc = proc;
|
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
|
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
|
openFileChannelProcList = newOpenFileChannelProcPtr;
|
openFileChannelProcList = newOpenFileChannelProcPtr;
|
|
|
retVal = TCL_OK;
|
retVal = TCL_OK;
|
}
|
}
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TclOpenFileChannelDeleteProc --
|
* TclOpenFileChannelDeleteProc --
|
*
|
*
|
* Removed the passed function pointer from the list of
|
* Removed the passed function pointer from the list of
|
* 'Tcl_OpenFileChannel' functions. Ensures that the built-in
|
* 'Tcl_OpenFileChannel' functions. Ensures that the built-in
|
* open file channel function is not removvable.
|
* open file channel function is not removvable.
|
*
|
*
|
* Results:
|
* Results:
|
* TCL_OK if the procedure pointer was successfully removed,
|
* TCL_OK if the procedure pointer was successfully removed,
|
* TCL_ERROR otherwise.
|
* TCL_ERROR otherwise.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Memory is deallocated and the respective list updated.
|
* Memory is deallocated and the respective list updated.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
TclOpenFileChannelDeleteProc(proc)
|
TclOpenFileChannelDeleteProc(proc)
|
TclOpenFileChannelProc_ *proc;
|
TclOpenFileChannelProc_ *proc;
|
{
|
{
|
int retVal = TCL_ERROR;
|
int retVal = TCL_ERROR;
|
OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
|
OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
|
OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
|
OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
|
|
|
/*
|
/*
|
* Traverse the 'openFileChannelProcList' looking for the particular
|
* Traverse the 'openFileChannelProcList' looking for the particular
|
* node whose 'proc' member matches 'proc' and remove that one from
|
* node whose 'proc' member matches 'proc' and remove that one from
|
* the list. Ensure that the "default" node cannot be removed.
|
* the list. Ensure that the "default" node cannot be removed.
|
*/
|
*/
|
|
|
while ((retVal == TCL_ERROR) &&
|
while ((retVal == TCL_ERROR) &&
|
(tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
|
(tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
|
if (tmpOpenFileChannelProcPtr->proc == proc) {
|
if (tmpOpenFileChannelProcPtr->proc == proc) {
|
if (prevOpenFileChannelProcPtr == NULL) {
|
if (prevOpenFileChannelProcPtr == NULL) {
|
openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
|
openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
|
} else {
|
} else {
|
prevOpenFileChannelProcPtr->nextPtr =
|
prevOpenFileChannelProcPtr->nextPtr =
|
tmpOpenFileChannelProcPtr->nextPtr;
|
tmpOpenFileChannelProcPtr->nextPtr;
|
}
|
}
|
|
|
Tcl_Free((char *)tmpOpenFileChannelProcPtr);
|
Tcl_Free((char *)tmpOpenFileChannelProcPtr);
|
|
|
retVal = TCL_OK;
|
retVal = TCL_OK;
|
} else {
|
} else {
|
prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
|
prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
|
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
|
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
|
}
|
}
|
}
|
}
|
|
|
return (retVal);
|
return (retVal);
|
}
|
}
|
|
|