summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tcl.decls5
-rw-r--r--generic/tclCmdAH.c16
-rw-r--r--generic/tclCompCmds.c4
-rw-r--r--generic/tclCompExpr.c4
-rw-r--r--generic/tclCompile.c11
-rw-r--r--generic/tclDecls.h10
-rw-r--r--generic/tclGet.c10
-rw-r--r--generic/tclIO.c42
-rw-r--r--generic/tclInitScript.h4
-rw-r--r--generic/tclLiteral.c5
-rw-r--r--generic/tclStubInit.c3
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. */
generated by cgit v0.12 at 2024-11-18 17:56:23 (GMT)