From 92e37b2bd18d8a5451699c466c1664e53403da57 Mon Sep 17 00:00:00 2001 From: hobbs Date: Thu, 19 Aug 1999 02:59:08 +0000 Subject: 1999-08-18 Jeff Hobbs * doc/OpenFileChnl.3: * doc/file.n: * tests/cmdAH.test: * tclIO.c: * tclCmdAH.c: added "file channels ?pattern?" tcl command, with associated Tcl_GetChannelNames and Tcl_GetChannelNamesEx public C APIs (added to tcl.decls as well), with docs and tests. * generic/tclCompile.c: add TCL_TOKEN_VARIABLE to the part types that cause differed compilation for exprs, to correct the expr double-evaluation problem for vars. Added test cases. --- generic/tcl.decls | 5 ++++- generic/tclCmdAH.c | 16 +++++++++++++--- generic/tclCompCmds.c | 4 ++-- generic/tclCompExpr.c | 4 ++-- generic/tclCompile.c | 11 ++++++----- generic/tclDecls.h | 10 +++++++++- generic/tclGet.c | 10 +++++----- generic/tclIO.c | 42 +++++++++++++++++++++++++++++++++++------- generic/tclInitScript.h | 4 ++-- generic/tclLiteral.c | 5 +---- generic/tclStubInit.c | 3 ++- 11 files changed, 81 insertions(+), 33 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6999f10..315d279 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.27 1999/08/10 22:45:10 redman Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.28 1999/08/19 02:59:08 hobbs Exp $ library tcl @@ -1340,6 +1340,9 @@ declare 387 generic { declare 388 generic { int Tcl_GetChannelNames(Tcl_Interp *interp) } +declare 389 generic { + int Tcl_GetChannelNamesEx(Tcl_Interp *interp, char *pattern) +} diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 8dc8c54..14ac7f6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.7 1999/07/01 23:21:06 redman Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.8 1999/08/19 02:59:08 hobbs Exp $ */ #include "tclInt.h" @@ -793,7 +793,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) */ static char *fileOptions[] = { - "atime", "attributes", "copy", "delete", + "atime", "attributes", "channels", "copy", + "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "lstat", "mtime", "mkdir", "nativename", "owned", @@ -803,7 +804,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) (char *) NULL }; enum options { - FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, + FILE_ATIME, FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY, + FILE_DELETE, FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, @@ -838,6 +840,14 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) case FILE_ATTRIBUTES: { return TclFileAttrsCmd(interp, objc, objv); } + case FILE_CHANNELS: { + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 2) ? NULL : Tcl_GetString(objv[2]))); + } case FILE_COPY: { int result; char **argv; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 09c3dd0..9566a2f 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.2 1999/04/16 00:46:43 stanton Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.3 1999/08/19 02:59:08 hobbs Exp $ */ #include "tclInt.h" @@ -1446,7 +1446,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) word[numBytes] = '\0'; if (TclLooksLikeInt(word, numBytes) - && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { + && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { if ((-127 <= n) && (n <= 127)) { haveImmValue = 1; immValue = n; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 42342b1..0b8fabf 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.3 1999/04/16 00:46:44 stanton Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.4 1999/08/19 02:59:08 hobbs Exp $ */ #include "tclInt.h" @@ -494,7 +494,7 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) hPtr = Tcl_FindHashEntry(&opHashTable, operator); if (hPtr == NULL) { code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, - envPtr, &endPtr); + envPtr, &endPtr); operator[tokenPtr->size] = (char) savedChar; if (code != TCL_OK) { goto done; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 25803a0..d83a9c1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.15 1999/04/22 22:57:06 stanton Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.16 1999/08/19 02:59:09 hobbs Exp $ */ #include "tclInt.h" @@ -1348,7 +1348,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) JumpFixup jumpFixup; int maxDepth, doExprInline, range, numBytes, i, j, code; char *script; - char saveChar; + char savedChar; int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; int saveExprIsComparison = envPtr->exprIsComparison; @@ -1370,10 +1370,10 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) script = tokenPtr[1].start; numBytes = tokenPtr[1].size; - saveChar = script[numBytes]; + savedChar = script[numBytes]; script[numBytes] = 0; code = TclCompileExpr(interp, script, numBytes, envPtr); - script[numBytes] = saveChar; + script[numBytes] = savedChar; return code; } @@ -1393,7 +1393,8 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; j++, partPtr++) { if ((partPtr->type == TCL_TOKEN_BS) - || (partPtr->type == TCL_TOKEN_COMMAND)) { + || (partPtr->type == TCL_TOKEN_COMMAND) + || (partPtr->type == TCL_TOKEN_VARIABLE)) { doExprInline = 0; break; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6b49c94..6507b61 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.28 1999/08/10 22:45:11 redman Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.29 1999/08/19 02:59:09 hobbs Exp $ */ #ifndef _TCLDECLS @@ -1212,6 +1212,9 @@ EXTERN void Tcl_SetNotifier _ANSI_ARGS_(( EXTERN Tcl_Mutex * Tcl_GetAllocMutex _ANSI_ARGS_((void)); /* 388 */ EXTERN int Tcl_GetChannelNames _ANSI_ARGS_((Tcl_Interp * interp)); +/* 389 */ +EXTERN int Tcl_GetChannelNamesEx _ANSI_ARGS_(( + Tcl_Interp * interp, char * pattern)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1668,6 +1671,7 @@ typedef struct TclStubs { void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */ int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */ + int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, char * pattern)); /* 389 */ } TclStubs; #ifdef __cplusplus @@ -3269,6 +3273,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetChannelNames \ (tclStubsPtr->tcl_GetChannelNames) /* 388 */ #endif +#ifndef Tcl_GetChannelNamesEx +#define Tcl_GetChannelNamesEx \ + (tclStubsPtr->tcl_GetChannelNamesEx) /* 389 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclGet.c b/generic/tclGet.c index 27e49cc..4e6f184 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGet.c,v 1.3 1999/04/16 00:46:46 stanton Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.4 1999/08/19 02:59:09 hobbs Exp $ */ #include "tclInt.h" @@ -69,8 +69,8 @@ Tcl_GetInt(interp, string, intPtr) if (end == p) { badInteger: if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "expected integer but got \"", string, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); } return TCL_ERROR; } @@ -155,8 +155,8 @@ TclGetLong(interp, string, longPtr) if (end == p) { badInteger: if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "expected integer but got \"", string, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); } return TCL_ERROR; } diff --git a/generic/tclIO.c b/generic/tclIO.c index c35147d..ea281a4 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.14 1999/08/10 17:35:18 redman Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.15 1999/08/19 02:59:10 hobbs Exp $ */ #include "tclInt.h" @@ -8157,7 +8157,6 @@ SetBlockMode(interp, chanPtr, mode) } return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -8178,13 +8177,39 @@ SetBlockMode(interp, chanPtr, mode) int Tcl_GetChannelNames(Tcl_Interp *interp) { + return Tcl_GetChannelNamesEx(interp, (char *) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelNamesEx -- + * + * Return the names of open channels in the interp filtered + * filtered through a pattern. If pattern is NULL, it returns + * all the open channels. + * + * Results: + * TCL_OK or TCL_ERROR. + * + * Side effects: + * Interp result modified with list of channel names. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelNamesEx(Tcl_Interp *interp, char *pattern) +{ Channel *chanPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); char *name; + Tcl_Obj *resultPtr; - Tcl_ResetResult(interp); - chanPtr = tsdPtr->firstChanPtr; - while (chanPtr != NULL) { + resultPtr = Tcl_GetObjResult(interp); + for (chanPtr = tsdPtr->firstChanPtr; + chanPtr != NULL; + chanPtr = chanPtr->nextChanPtr) { if (chanPtr == (Channel *) tsdPtr->stdinChannel) { name = "stdin"; } else if (chanPtr == (Channel *) tsdPtr->stdoutChannel) { @@ -8194,8 +8219,11 @@ Tcl_GetChannelNames(Tcl_Interp *interp) } else { name = chanPtr->channelName; } - Tcl_AppendElement(interp, name); - chanPtr = chanPtr->nextChanPtr; + if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && + (Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(name, -1)) != TCL_OK)) { + return TCL_ERROR; + } } return TCL_OK; } diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h index 751fba1..1d8ffe0 100644 --- a/generic/tclInitScript.h +++ b/generic/tclInitScript.h @@ -8,7 +8,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclInitScript.h,v 1.11 1999/07/21 17:43:21 hershey Exp $ + * RCS: @(#) $Id: tclInitScript.h,v 1.12 1999/08/19 02:59:10 hobbs Exp $ */ /* @@ -58,7 +58,7 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ set tclfile [file join $i init.tcl]\n\ if {[file exists $tclfile]} {\n\ if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\ - return\n\ + return\n\ } else {\n\ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ }\n\ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 2a7fe5b..37ef1db 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLiteral.c,v 1.7 1999/08/05 16:56:45 hobbs Exp $ + * RCS: @(#) $Id: tclLiteral.c,v 1.8 1999/08/19 02:59:10 hobbs Exp $ */ #include "tclInt.h" @@ -188,7 +188,6 @@ TclRegisterLiteral(envPtr, bytes, length, onHeap) long n; char buf[TCL_INTEGER_SPACE]; - if (length < 0) { length = (bytes? strlen(bytes) : 0); } @@ -303,7 +302,6 @@ TclRegisterLiteral(envPtr, bytes, length, onHeap) if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) { RebuildLiteralTable(globalTablePtr); } - objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); #ifdef TCL_COMPILE_DEBUG @@ -752,7 +750,6 @@ TclReleaseLiteral(interp, objPtr) * Remove the reference corresponding to the local literal table * entry. */ - Tcl_DecrRefCount(objPtr); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c433c97..ad790d9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.27 1999/08/10 02:42:14 welch Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.28 1999/08/19 02:59:10 hobbs Exp $ */ #include "tclInt.h" @@ -783,6 +783,7 @@ TclStubs tclStubs = { Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ Tcl_GetChannelNames, /* 388 */ + Tcl_GetChannelNamesEx, /* 389 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12