summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdIL.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdIL.c')
-rw-r--r--generic/tclCmdIL.c4697
1 files changed, 2300 insertions, 2397 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 21dbdc8..13db6d5 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1,62 +1,80 @@
-/*
+/*
* tclCmdIL.c --
*
- * This file contains the top-level command routines for most of
- * the Tcl built-in commands whose names begin with the letters
- * I through L. It contains only commands in the generic core
- * (i.e. those that don't depend much upon UNIX facilities).
+ * This file contains the top-level command routines for most of the Tcl
+ * built-in commands whose names begin with the letters I through L. It
+ * contains only commands in the generic core (i.e. those that don't
+ * depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2005 Donal K. Fellows.
*
- * 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.
*/
#include "tclInt.h"
-#include "tclPort.h"
#include "tclRegexp.h"
/*
- * During execution of the "lsort" command, structures of the following
- * type are used to arrange the objects being sorted into a collection
- * of linked lists.
+ * During execution of the "lsort" command, structures of the following type
+ * are used to arrange the objects being sorted into a collection of linked
+ * lists.
*/
typedef struct SortElement {
- Tcl_Obj *objPtr; /* Object being sorted. */
- int count; /* number of same elements in list */
- struct SortElement *nextPtr; /* Next element in the list, or
- * NULL for end of list. */
+ union {
+ char *strValuePtr;
+ long intValue;
+ double doubleValue;
+ Tcl_Obj *objValuePtr;
+ } index;
+ Tcl_Obj *objPtr; /* Object being sorted, or its index. */
+ struct SortElement *nextPtr;/* Next element in the list, or NULL for end
+ * of list. */
} SortElement;
/*
- * The "lsort" command needs to pass certain information down to the
- * function that compares two list elements, and the comparison function
- * needs to pass success or failure information back up to the top-level
- * "lsort" command. The following structure is used to pass this
- * information.
+ * These function pointer types are used with the "lsearch" and "lsort"
+ * commands to facilitate the "-nocase" option.
+ */
+
+typedef int (*SortStrCmpFn_t) (const char *, const char *);
+typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
+
+/*
+ * The "lsort" command needs to pass certain information down to the function
+ * that compares two list elements, and the comparison function needs to pass
+ * success or failure information back up to the top-level "lsort" command.
+ * The following structure is used to pass this information.
*/
typedef struct SortInfo {
int isIncreasing; /* Nonzero means sort in increasing order. */
- int sortMode; /* The sort mode. One of SORTMODE_*
- * values defined below */
- Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode
- * is SORTMODE_COMMAND. Pre-initialized to
- * hold base of command.*/
- int index; /* If the -index option was specified, this
- * holds the index of the list element
- * to extract for comparison. If -index
- * wasn't specified, this is -1. */
- Tcl_Interp *interp; /* The interpreter in which the sortis
- * being done. */
- int resultCode; /* Completion code for the lsort command.
- * If an error occurs during the sort this
- * is changed from TCL_OK to TCL_ERROR. */
+ int sortMode; /* The sort mode. One of SORTMODE_* values
+ * defined below. */
+ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is
+ * SORTMODE_COMMAND. Pre-initialized to hold
+ * base of command. */
+ int *indexv; /* If the -index option was specified, this
+ * holds the indexes contained in the list
+ * supplied as an argument to that option.
+ * NULL if no indexes supplied, and points to
+ * singleIndex field when only one
+ * supplied. */
+ int indexc; /* Number of indexes in indexv array. */
+ int singleIndex; /* Static space for common index case. */
+ int unique;
+ int numElements;
+ Tcl_Interp *interp; /* The interpreter in which the sort is being
+ * done. */
+ int resultCode; /* Completion code for the lsort command. If
+ * an error occurs during the sort this is
+ * changed from TCL_OK to TCL_ERROR. */
} SortInfo;
/*
@@ -64,115 +82,113 @@ typedef struct SortInfo {
* following values.
*/
-#define SORTMODE_ASCII 0
-#define SORTMODE_INTEGER 1
-#define SORTMODE_REAL 2
-#define SORTMODE_COMMAND 3
-#define SORTMODE_DICTIONARY 4
+#define SORTMODE_ASCII 0
+#define SORTMODE_INTEGER 1
+#define SORTMODE_REAL 2
+#define SORTMODE_COMMAND 3
+#define SORTMODE_DICTIONARY 4
+#define SORTMODE_ASCII_NC 8
/*
- * Magic values for the index field of the SortInfo structure.
- * Note that the index "end-1" will be translated to SORTIDX_END-1, etc.
+ * Magic values for the index field of the SortInfo structure. Note that the
+ * index "end-1" will be translated to SORTIDX_END-1, etc.
*/
-#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
-#define SORTIDX_END -2 /* Indexed from end. */
+
+#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
+#define SORTIDX_END -2 /* Indexed from end. */
/*
* Forward declarations for procedures defined in this file:
*/
-static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *listPtr, CONST char *pattern,
- int includeLinks));
-static int DictionaryCompare _ANSI_ARGS_((char *left,
- char *right));
-static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-#ifdef TCL_TIP280
+static int DictionaryCompare(char *left, char *right);
+static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
/* TIP #280 - New 'info' subcommand 'frame' */
-static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-#endif
-static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
+static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoNameOfExecutableCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoNameOfExecutableCmd _ANSI_ARGS_((
- ClientData dummy, Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
- SortInfo *infoPtr));
-static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
- SortElement *rightPtr, SortInfo *infoPtr));
-static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
- Tcl_Obj *second, SortInfo *infoPtr));
+ Tcl_Obj *CONST objv[]);
+static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
+ SortInfo *infoPtr);
+static int SortCompare(SortElement *firstPtr, SortElement *second,
+ SortInfo *infoPtr);
+static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
+ SortInfo *infoPtr);
+
+/*
+ * Array of values describing how to implement each standard subcommand of the
+ * "info" command.
+ */
+
+static const EnsembleImplMap defaultInfoMap[] = {
+ {"args", InfoArgsCmd, NULL},
+ {"body", InfoBodyCmd, NULL},
+ {"cmdcount", InfoCmdCountCmd, NULL},
+ {"commands", InfoCommandsCmd, NULL},
+ {"complete", InfoCompleteCmd, NULL},
+ {"default", InfoDefaultCmd, NULL},
+ {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd},
+ {"frame", InfoFrameCmd, NULL},
+ {"functions", InfoFunctionsCmd, NULL},
+ {"globals", TclInfoGlobalsCmd, NULL},
+ {"hostname", InfoHostnameCmd, NULL},
+ {"level", InfoLevelCmd, NULL},
+ {"library", InfoLibraryCmd, NULL},
+ {"loaded", InfoLoadedCmd, NULL},
+ {"locals", TclInfoLocalsCmd, NULL},
+ {"nameofexecutable", InfoNameOfExecutableCmd, NULL},
+ {"patchlevel", InfoPatchLevelCmd, NULL},
+ {"procs", InfoProcsCmd, NULL},
+ {"script", InfoScriptCmd, NULL},
+ {"sharedlibextension", InfoSharedlibCmd, NULL},
+ {"tclversion", InfoTclVersionCmd, NULL},
+ {"vars", TclInfoVarsCmd, NULL},
+ {NULL, NULL, NULL}
+};
/*
*----------------------------------------------------------------------
*
* Tcl_IfObjCmd --
*
- * This procedure is invoked to process the "if" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "if" Tcl command. See the
+ * user documentation for details on what it does.
*
- * With the bytecode compiler, this procedure is only called when
- * a command name is computed at runtime, and is "if" or the name
- * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
+ * With the bytecode compiler, this procedure is only called when a
+ * command name is computed at runtime, and is "if" or the name to which
+ * "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
*
* Results:
* A standard Tcl result.
@@ -183,34 +199,32 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_IfObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_IfObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- int thenScriptIndex = 0; /* then script to be evaled after syntax check */
-#ifdef TCL_TIP280
- Interp* iPtr = (Interp*) interp;
-#endif
+ int thenScriptIndex = 0; /* "then" script to be evaled after syntax
+ * check. */
+ Interp *iPtr = (Interp *) interp;
int i, result, value;
char *clause;
+
i = 1;
while (1) {
/*
- * At this point in the loop, objv and objc refer to an expression
- * to test, either for the main expression or an expression
- * following an "elseif". The arguments after the expression must
- * be "then" (optional) and a script to execute if the expression is
- * true.
+ * At this point in the loop, objv and objc refer to an expression to
+ * test, either for the main expression or an expression following an
+ * "elseif". The arguments after the expression must be "then"
+ * (optional) and a script to execute if the expression is true.
*/
if (i >= objc) {
- clause = Tcl_GetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: no expression after \"",
- clause, "\" argument", (char *) NULL);
+ clause = TclGetString(objv[i-1]);
+ Tcl_AppendResult(interp, "wrong # args: ",
+ "no expression after \"", clause, "\" argument", NULL);
return TCL_ERROR;
}
if (!thenScriptIndex) {
@@ -221,13 +235,13 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
}
i++;
if (i >= objc) {
- missingScript:
- clause = Tcl_GetString(objv[i-1]);
- Tcl_AppendResult(interp, "wrong # args: no script following \"",
- clause, "\" argument", (char *) NULL);
+ missingScript:
+ clause = TclGetString(objv[i-1]);
+ Tcl_AppendResult(interp, "wrong # args: ",
+ "no script following \"", clause, "\" argument", NULL);
return TCL_ERROR;
}
- clause = Tcl_GetString(objv[i]);
+ clause = TclGetString(objv[i]);
if ((i < objc) && (strcmp(clause, "then") == 0)) {
i++;
}
@@ -238,26 +252,25 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
thenScriptIndex = i;
value = 0;
}
-
+
/*
- * The expression evaluated to false. Skip the command, then
- * see if there is an "else" or "elseif" clause.
+ * The expression evaluated to false. Skip the command, then see if
+ * there is an "else" or "elseif" clause.
*/
i++;
if (i >= objc) {
if (thenScriptIndex) {
-#ifndef TCL_TIP280
- return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
-#else
- /* TIP #280. Make invoking context available to branch */
+ /*
+ * TIP #280. Make invoking context available to branch.
+ */
+
return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
- iPtr->cmdFramePtr,thenScriptIndex);
-#endif
+ iPtr->cmdFramePtr, thenScriptIndex);
}
return TCL_OK;
}
- clause = Tcl_GetString(objv[i]);
+ clause = TclGetString(objv[i]);
if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
i++;
continue;
@@ -266,40 +279,33 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
}
/*
- * Couldn't find a "then" or "elseif" clause to execute. Check now
- * for an "else" clause. We know that there's at least one more
- * argument when we get here.
+ * Couldn't find a "then" or "elseif" clause to execute. Check now for an
+ * "else" clause. We know that there's at least one more argument when we
+ * get here.
*/
if (strcmp(clause, "else") == 0) {
i++;
if (i >= objc) {
- Tcl_AppendResult(interp,
- "wrong # args: no script following \"else\" argument",
- (char *) NULL);
+ Tcl_AppendResult(interp, "wrong # args: ",
+ "no script following \"else\" argument", NULL);
return TCL_ERROR;
}
}
if (i < objc - 1) {
- Tcl_AppendResult(interp,
- "wrong # args: extra words after \"else\" clause in \"if\" command",
- (char *) NULL);
+ Tcl_AppendResult(interp, "wrong # args: ",
+ "extra words after \"else\" clause in \"if\" command", NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
-#ifndef TCL_TIP280
- return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
-#else
- /* TIP #280. Make invoking context available to branch/else */
+ /*
+ * TIP #280. Make invoking context available to branch/else.
+ */
+
return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
- iPtr->cmdFramePtr,thenScriptIndex);
-#endif
+ iPtr->cmdFramePtr, thenScriptIndex);
}
-#ifndef TCL_TIP280
- return Tcl_EvalObjEx(interp, objv[i], 0);
-#else
- return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
-#endif
+ return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
}
/*
@@ -307,12 +313,12 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
*
* Tcl_IncrObjCmd --
*
- * This procedure is invoked to process the "incr" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "incr" Tcl command. See the
+ * user documentation for details on what it does.
*
- * With the bytecode compiler, this procedure is only called when
- * a command name is computed at runtime, and is "incr" or the name
- * to which "incr" was renamed: e.g., "set z incr; $z i -1"
+ * With the bytecode compiler, this procedure is only called when a
+ * command name is computed at runtime, and is "incr" or the name to
+ * which "incr" was renamed: e.g., "set z incr; $z i -1"
*
* Results:
* A standard Tcl result.
@@ -323,64 +329,30 @@ Tcl_IfObjCmd(dummy, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_IncrObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_IncrObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- long incrAmount;
- Tcl_Obj *newValuePtr;
-
+ Tcl_Obj *newValuePtr, *incrPtr;
+
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
+ Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
- /*
- * Calculate the amount to increment by.
- */
-
- if (objc == 2) {
- incrAmount = 1;
+ if (objc == 3) {
+ incrPtr = objv[2];
} else {
- if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (reading increment)");
- return TCL_ERROR;
- }
- /*
- * Need to be a bit cautious to ensure that [expr]-like rules
- * are enforced for interpretation of wide integers, despite
- * the fact that the underlying API itself is a 'long' only one.
- */
- if (objv[2]->typePtr == &tclIntType) {
- incrAmount = objv[2]->internalRep.longValue;
- } else if (objv[2]->typePtr == &tclWideIntType) {
- TclGetLongFromWide(incrAmount,objv[2]);
- } else {
- Tcl_WideInt wide;
-
- if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (reading increment)");
- return TCL_ERROR;
- }
- incrAmount = Tcl_WideAsLong(wide);
- if ((wide <= Tcl_LongAsWide(LONG_MAX))
- && (wide >= Tcl_LongAsWide(LONG_MIN))) {
- objv[2]->typePtr = &tclIntType;
- objv[2]->internalRep.longValue = incrAmount;
- }
- }
+ incrPtr = Tcl_NewIntObj(1);
}
-
- /*
- * Increment the variable's value.
- */
+ Tcl_IncrRefCount(incrPtr);
+ newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
+ incrPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(incrPtr);
- newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
- TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
@@ -391,141 +363,31 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv)
*/
Tcl_SetObjResult(interp, newValuePtr);
- return TCL_OK;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_InfoObjCmd --
+ * TclInitInfoCmd --
*
- * This procedure is invoked to process the "info" Tcl command.
- * See the user documentation for details on what it does.
+ * This function is called to create the "info" Tcl command. See the user
+ * documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * FIXME
*
* Side effects:
- * See the user documentation.
+ * none
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
-int
-Tcl_InfoObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Arbitrary value passed to the command. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_Command
+TclInitInfoCmd(
+ Tcl_Interp *interp) /* Current interpreter. */
{
- static CONST char *subCmds[] = {
- "args", "body", "cmdcount", "commands",
- "complete", "default", "exists",
-#ifdef TCL_TIP280
- "frame",
-#endif
- "functions",
- "globals", "hostname", "level", "library", "loaded",
- "locals", "nameofexecutable", "patchlevel", "procs",
- "script", "sharedlibextension", "tclversion", "vars",
- (char *) NULL};
- enum ISubCmdIdx {
- IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
- ICompleteIdx, IDefaultIdx, IExistsIdx,
-#ifdef TCL_TIP280
- IFrameIdx,
-#endif
- IFunctionsIdx,
- IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
- ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
- IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
- };
- int index, result;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
- return TCL_ERROR;
- }
-
- result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
- (int *) &index);
- if (result != TCL_OK) {
- return result;
- }
-
- switch (index) {
- case IArgsIdx:
- result = InfoArgsCmd(clientData, interp, objc, objv);
- break;
- case IBodyIdx:
- result = InfoBodyCmd(clientData, interp, objc, objv);
- break;
- case ICmdCountIdx:
- result = InfoCmdCountCmd(clientData, interp, objc, objv);
- break;
- case ICommandsIdx:
- result = InfoCommandsCmd(clientData, interp, objc, objv);
- break;
- case ICompleteIdx:
- result = InfoCompleteCmd(clientData, interp, objc, objv);
- break;
- case IDefaultIdx:
- result = InfoDefaultCmd(clientData, interp, objc, objv);
- break;
- case IExistsIdx:
- result = InfoExistsCmd(clientData, interp, objc, objv);
- break;
-#ifdef TCL_TIP280
- case IFrameIdx:
- /* TIP #280 - New method 'frame' */
- result = InfoFrameCmd(clientData, interp, objc, objv);
- break;
-#endif
- case IFunctionsIdx:
- result = InfoFunctionsCmd(clientData, interp, objc, objv);
- break;
- case IGlobalsIdx:
- result = InfoGlobalsCmd(clientData, interp, objc, objv);
- break;
- case IHostnameIdx:
- result = InfoHostnameCmd(clientData, interp, objc, objv);
- break;
- case ILevelIdx:
- result = InfoLevelCmd(clientData, interp, objc, objv);
- break;
- case ILibraryIdx:
- result = InfoLibraryCmd(clientData, interp, objc, objv);
- break;
- case ILoadedIdx:
- result = InfoLoadedCmd(clientData, interp, objc, objv);
- break;
- case ILocalsIdx:
- result = InfoLocalsCmd(clientData, interp, objc, objv);
- break;
- case INameOfExecutableIdx:
- result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
- break;
- case IPatchLevelIdx:
- result = InfoPatchLevelCmd(clientData, interp, objc, objv);
- break;
- case IProcsIdx:
- result = InfoProcsCmd(clientData, interp, objc, objv);
- break;
- case IScriptIdx:
- result = InfoScriptCmd(clientData, interp, objc, objv);
- break;
- case ISharedLibExtensionIdx:
- result = InfoSharedlibCmd(clientData, interp, objc, objv);
- break;
- case ITclVersionIdx:
- result = InfoTclVersionCmd(clientData, interp, objc, objv);
- break;
- case IVarsIdx:
- result = InfoVarsCmd(clientData, interp, objc, objv);
- break;
- }
- return result;
+ return TclMakeEnsemble(interp, "info", defaultInfoMap);
}
/*
@@ -533,27 +395,27 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
*
* InfoArgsCmd --
*
- * Called to implement the "info args" command that returns the
- * argument list for a procedure. Handles the following syntax:
+ * Called to implement the "info args" command that returns the argument
+ * list for a procedure. Handles the following syntax:
*
- * info args procName
+ * info args procName
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoArgsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoArgsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
char *name;
@@ -561,30 +423,29 @@ InfoArgsCmd(dummy, interp, objc, objv)
CompiledLocal *localPtr;
Tcl_Obj *listObjPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "procname");
- return TCL_ERROR;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "procname");
+ return TCL_ERROR;
}
- name = Tcl_GetString(objv[2]);
+ name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "\"", name, "\" isn't a procedure", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ return TCL_ERROR;
}
/*
* Build a return list containing the arguments.
*/
-
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ listObjPtr = Tcl_NewListObj(0, NULL);
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
- localPtr = localPtr->nextPtr) {
- if (TclIsVarArgument(localPtr)) {
- Tcl_ListObjAppendElement(interp, listObjPtr,
+ localPtr = localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_ListObjAppendElement(interp, listObjPtr,
Tcl_NewStringObj(localPtr->name, -1));
- }
+ }
}
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
@@ -595,65 +456,65 @@ InfoArgsCmd(dummy, interp, objc, objv)
*
* InfoBodyCmd --
*
- * Called to implement the "info body" command that returns the body
- * for a procedure. Handles the following syntax:
+ * Called to implement the "info body" command that returns the body for
+ * a procedure. Handles the following syntax:
*
- * info body procName
+ * info body procName
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoBodyCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoBodyCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
char *name;
Proc *procPtr;
Tcl_Obj *bodyPtr, *resultPtr;
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "procname");
- return TCL_ERROR;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "procname");
+ return TCL_ERROR;
}
- name = Tcl_GetString(objv[2]);
+ name = TclGetString(objv[1]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "\"", name, "\" isn't a procedure", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL);
+ return TCL_ERROR;
}
- /*
+ /*
* Here we used to return procPtr->bodyPtr, except when the body was
- * bytecompiled - in that case, the return was a copy of the body's
- * string rep. In order to better isolate the implementation details
- * of the compiler/engine subsystem, we now always return a copy of
- * the string rep. It is important to return a copy so that later
- * manipulations of the object do not invalidate the internal rep.
+ * bytecompiled - in that case, the return was a copy of the body's string
+ * rep. In order to better isolate the implementation details of the
+ * compiler/engine subsystem, we now always return a copy of the string
+ * rep. It is important to return a copy so that later manipulations of
+ * the object do not invalidate the internal rep.
*/
bodyPtr = procPtr->bodyPtr;
if (bodyPtr->bytes == NULL) {
/*
- * The string rep might not be valid if the procedure has
- * never been run before. [Bug #545644]
+ * The string rep might not be valid if the procedure has never been
+ * run before. [Bug #545644]
*/
- (void) Tcl_GetString(bodyPtr);
+
+ (void) TclGetString(bodyPtr);
}
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
-
+
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
@@ -663,37 +524,37 @@ InfoBodyCmd(dummy, interp, objc, objv)
*
* InfoCmdCountCmd --
*
- * Called to implement the "info cmdcount" command that returns the
- * number of commands that have been executed. Handles the following
- * syntax:
+ * Called to implement the "info cmdcount" command that returns the
+ * number of commands that have been executed. Handles the following
+ * syntax:
*
- * info cmdcount
+ * info cmdcount
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoCmdCountCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoCmdCountCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount));
return TCL_OK;
}
@@ -702,31 +563,31 @@ InfoCmdCountCmd(dummy, interp, objc, objv)
*
* InfoCommandsCmd --
*
- * Called to implement the "info commands" command that returns the
- * list of commands in the interpreter that match an optional pattern.
- * The pattern, if any, consists of an optional sequence of namespace
- * names separated by "::" qualifiers, which is followed by a
- * glob-style pattern that restricts which commands are returned.
- * Handles the following syntax:
+ * Called to implement the "info commands" command that returns the list
+ * of commands in the interpreter that match an optional pattern. The
+ * pattern, if any, consists of an optional sequence of namespace names
+ * separated by "::" qualifiers, which is followed by a glob-style
+ * pattern that restricts which commands are returned. Handles the
+ * following syntax:
*
- * info commands ?pattern?
+ * info commands ?pattern?
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoCommandsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoCommandsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
char *cmdName, *pattern;
CONST char *simplePattern;
@@ -734,42 +595,42 @@ InfoCommandsCmd(dummy, interp, objc, objv)
Tcl_HashSearch search;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
- Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
- int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
+ int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
Tcl_Command cmd;
+ int i;
/*
- * Get the pattern and find the "effective namespace" in which to
- * list commands.
+ * Get the pattern and find the "effective namespace" in which to list
+ * commands.
*/
- if (objc == 2) {
- simplePattern = NULL;
+ if (objc == 1) {
+ simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
- } else if (objc == 3) {
+ } else if (objc == 2) {
/*
* From the pattern, get the effective namespace and the simple
- * pattern (no namespace qualifiers or ::'s) at the end. If an
- * error was found while parsing the pattern, return it. Otherwise,
- * if the namespace wasn't found, just leave nsPtr NULL: we will
- * return an empty list since no commands there can be found.
+ * pattern (no namespace qualifiers or ::'s) at the end. If an error
+ * was found while parsing the pattern, return it. Otherwise, if the
+ * namespace wasn't found, just leave nsPtr NULL: we will return an
+ * empty list since no commands there can be found.
*/
Namespace *dummy1NsPtr, *dummy2NsPtr;
-
- pattern = Tcl_GetString(objv[2]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ pattern = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
- if (nsPtr != NULL) { /* we successfully found the pattern's ns */
+ if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
}
/*
@@ -781,20 +642,20 @@ InfoCommandsCmd(dummy, interp, objc, objv)
}
/*
- * Scan through the effective namespace's command table and create a
- * list with all commands that match the pattern. If a specific
- * namespace was requested in the pattern, qualify the command names
- * with the namespace name.
+ * Scan through the effective namespace's command table and create a list
+ * with all commands that match the pattern. If a specific namespace was
+ * requested in the pattern, qualify the command names with the namespace
+ * name.
*/
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ listPtr = Tcl_NewListObj(0, NULL);
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
/*
- * Special case for when the pattern doesn't include any of
- * glob's special characters. This lets us avoid scans of any
- * hash tables.
+ * Special case for when the pattern doesn't include any of glob's
+ * special characters. This lets us avoid scans of any hash tables.
*/
+
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
@@ -806,21 +667,48 @@ InfoCommandsCmd(dummy, interp, objc, objv)
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
- } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
- simplePattern);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ }
+ if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ Tcl_HashTable *tablePtr = NULL; /* Quell warning. */
+
+ for (i=0 ; i<nsPtr->commandPathLength ; i++) {
+ Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr;
+
+ if (pathNsPtr == NULL) {
+ continue;
+ }
+ tablePtr = &pathNsPtr->cmdTable;
+ entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
+ if (entryPtr != NULL) {
+ break;
+ }
+ }
+ if (entryPtr == NULL) {
+ tablePtr = &globalNsPtr->cmdTable;
+ entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
+ }
if (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ cmdName = Tcl_GetHashKey(tablePtr, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
}
}
- } else {
+ } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
+ /*
+ * The pattern is non-trivial, but either there is no explicit path or
+ * there is an explicit namespace in the pattern. In both cases, the
+ * old matching scheme is perfect.
+ */
+
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
- || Tcl_StringMatch(cmdName, simplePattern)) {
+ || Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
@@ -835,19 +723,19 @@ InfoCommandsCmd(dummy, interp, objc, objv)
/*
* If the effective namespace isn't the global :: namespace, and a
- * specific namespace wasn't requested in the pattern, then add in
- * all global :: commands that match the simple pattern. Of course,
- * we add in only those commands that aren't hidden by a command in
- * the effective namespace.
+ * specific namespace wasn't requested in the pattern, then add in all
+ * global :: commands that match the simple pattern. Of course, we add
+ * in only those commands that aren't hidden by a command in the
+ * effective namespace.
*/
-
+
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
- || Tcl_StringMatch(cmdName, simplePattern)) {
- if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
@@ -855,8 +743,97 @@ InfoCommandsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_NextHashEntry(&search);
}
}
+ } else {
+ /*
+ * The pattern is non-trivial (can match more than one command name),
+ * there is an explicit path, and there is no explicit namespace in
+ * the pattern. This means that we have to traverse the path to
+ * discover all the commands defined.
+ */
+
+ Tcl_HashTable addedCommandsTable;
+ int isNew;
+ int foundGlobal = (nsPtr == globalNsPtr);
+
+ /*
+ * We keep a hash of the objects already added to the result list.
+ */
+
+ Tcl_InitObjHashTable(&addedCommandsTable);
+
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ (void) Tcl_CreateHashEntry(&addedCommandsTable,
+ (char *)elemObjPtr, &isNew);
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+
+ /*
+ * Search the path next.
+ */
+
+ for (i=0 ; i<nsPtr->commandPathLength ; i++) {
+ Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr;
+
+ if (pathNsPtr == NULL) {
+ continue;
+ }
+ if (pathNsPtr == globalNsPtr) {
+ foundGlobal = 1;
+ }
+ entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ (void) Tcl_CreateHashEntry(&addedCommandsTable,
+ (char *) elemObjPtr, &isNew);
+ if (isNew) {
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ } else {
+ TclDecrRefCount(elemObjPtr);
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ }
+
+ /*
+ * If the effective namespace isn't the global :: namespace, and a
+ * specific namespace wasn't requested in the pattern, then add in all
+ * global :: commands that match the simple pattern. Of course, we add
+ * in only those commands that aren't hidden by a command in the
+ * effective namespace.
+ */
+
+ if (!foundGlobal) {
+ entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ if (Tcl_FindHashEntry(&addedCommandsTable,
+ (char *) elemObjPtr) == NULL) {
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ } else {
+ TclDecrRefCount(elemObjPtr);
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ }
+
+ Tcl_DeleteHashTable(&addedCommandsTable);
}
-
+
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
@@ -866,40 +843,36 @@ InfoCommandsCmd(dummy, interp, objc, objv)
*
* InfoCompleteCmd --
*
- * Called to implement the "info complete" command that determines
- * whether a string is a complete Tcl command. Handles the following
- * syntax:
+ * Called to implement the "info complete" command that determines
+ * whether a string is a complete Tcl command. Handles the following
+ * syntax:
*
- * info complete command
+ * info complete command
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoCompleteCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoCompleteCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "command");
- return TCL_ERROR;
- }
-
- if (TclObjCommandComplete(objv[2])) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
- } else {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command");
+ return TCL_ERROR;
}
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ TclObjCommandComplete(objv[1])));
return TCL_OK;
}
@@ -908,28 +881,27 @@ InfoCompleteCmd(dummy, interp, objc, objv)
*
* InfoDefaultCmd --
*
- * Called to implement the "info default" command that returns the
- * default value for a procedure argument. Handles the following
- * syntax:
+ * Called to implement the "info default" command that returns the
+ * default value for a procedure argument. Handles the following syntax:
*
- * info default procName arg varName
+ * info default procName arg varName
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoDefaultCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoDefaultCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *procName, *argName, *varName;
@@ -937,484 +909,447 @@ InfoDefaultCmd(dummy, interp, objc, objv)
CompiledLocal *localPtr;
Tcl_Obj *valueObjPtr;
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
- return TCL_ERROR;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname");
+ return TCL_ERROR;
}
- procName = Tcl_GetString(objv[2]);
- argName = Tcl_GetString(objv[3]);
+ procName = TclGetString(objv[1]);
+ argName = TclGetString(objv[2]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "\"", procName, "\" isn't a procedure", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "\"", procName, "\" isn't a procedure",NULL);
+ return TCL_ERROR;
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
- localPtr = localPtr->nextPtr) {
- if (TclIsVarArgument(localPtr)
+ localPtr = localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)
&& (strcmp(argName, localPtr->name) == 0)) {
- if (localPtr->defValuePtr != NULL) {
- valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
+ if (localPtr->defValuePtr != NULL) {
+ valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
localPtr->defValuePtr, 0);
- if (valueObjPtr == NULL) {
- defStoreError:
- varName = Tcl_GetString(objv[4]);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "couldn't store default value in variable \"",
- varName, "\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
- } else {
- Tcl_Obj *nullObjPtr = Tcl_NewObj();
- Tcl_IncrRefCount(nullObjPtr);
- valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
+ if (valueObjPtr == NULL) {
+ goto defStoreError;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ } else {
+ Tcl_Obj *nullObjPtr = Tcl_NewObj();
+ valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
nullObjPtr, 0);
- Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
- if (valueObjPtr == NULL) {
- goto defStoreError;
- }
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
- }
- return TCL_OK;
- }
- }
-
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName, "\" doesn't have an argument \"",
- argName, "\"", (char *) NULL);
+ if (valueObjPtr == NULL) {
+ goto defStoreError;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ }
+ return TCL_OK;
+ }
+ }
+
+ Tcl_AppendResult(interp, "procedure \"", procName,
+ "\" doesn't have an argument \"", argName, "\"", NULL);
+ return TCL_ERROR;
+
+ defStoreError:
+ varName = TclGetString(objv[3]);
+ Tcl_AppendResult(interp, "couldn't store default value in variable \"",
+ varName, "\"", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * InfoExistsCmd --
+ * TclInfoExistsCmd --
*
- * Called to implement the "info exists" command that determines
- * whether a variable exists. Handles the following syntax:
+ * Called to implement the "info exists" command that determines whether
+ * a variable exists. Handles the following syntax:
*
- * info exists varName
+ * info exists varName
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
-static int
-InfoExistsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+int
+TclInfoExistsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
char *varName;
Var *varPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "varName");
- return TCL_ERROR;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "varName");
+ return TCL_ERROR;
}
- varName = Tcl_GetString(objv[2]);
+ varName = TclGetString(objv[1]);
varPtr = TclVarTraceExists(interp, varName);
- if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
- } else {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
- }
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr));
return TCL_OK;
}
-#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* InfoFrameCmd --
* TIP #280
*
- * Called to implement the "info frame" command that returns the
- * location of either the currently executing command, or its caller.
- * Handles the following syntax:
+ * Called to implement the "info frame" command that returns the location
+ * of either the currently executing command, or its caller. Handles the
+ * following syntax:
*
- * info frame ?number?
+ * info frame ?number?
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoFrameCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoFrameCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
+ int level;
+ CmdFrame *framePtr;
- if (objc == 2) {
- /* just "info frame" */
- int levels = (iPtr->cmdFramePtr == NULL
- ? 0
- : iPtr->cmdFramePtr->level);
+ if (objc == 1) {
+ /*
+ * Just "info frame".
+ */
+
+ int levels =
+ (iPtr->cmdFramePtr == NULL ? 0 : iPtr->cmdFramePtr->level);
Tcl_SetObjResult(interp, Tcl_NewIntObj (levels));
- return TCL_OK;
-
- } else if (objc == 3) {
- /* "info frame level" */
- int level;
- CmdFrame *framePtr;
-
- if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
- return TCL_ERROR;
- }
- if (level <= 0) {
- /* Relative adressing */
-
- if (iPtr->cmdFramePtr == NULL) {
- levelError:
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad level \"",
- Tcl_GetString(objv[2]),
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
- /* Convert to absolute. */
-
- level += iPtr->cmdFramePtr->level;
- }
- for (framePtr = iPtr->cmdFramePtr;
- framePtr != NULL;
- framePtr = framePtr->nextPtr) {
+ return TCL_OK;
+ } else if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?number?");
+ return TCL_ERROR;
+ }
- if (framePtr->level == level) {
- break;
- }
- }
- if (framePtr == NULL) {
- goto levelError;
- }
+ /*
+ * We've got "info frame level" and must parse the level first.
+ */
+ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level <= 0) {
/*
- * Pull the information and construct the dictionary to return, as
- * list. Regarding use of the CmdFrame fields see tclInt.h, and its
- * definition.
+ * Negative levels are adressing relative to the current frame's
+ * depth.
*/
- {
- Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */
- int lc = 0;
+ if (iPtr->cmdFramePtr == NULL) {
+ levelError:
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"",
+ TclGetString(objv[1]), "\"", NULL);
+ return TCL_ERROR;
+ }
- /* This array is indexed by the TCL_LOCATION_... values, except
- * for _LAST.
- */
+ /*
+ * Convert to absolute.
+ */
- static CONST char* typeString [TCL_LOCATION_LAST] = {
- "eval", "eval", "eval", "precompiled", "source", "proc"
- };
+ level += iPtr->cmdFramePtr->level;
+ }
- Proc* procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
+ for (framePtr = iPtr->cmdFramePtr; framePtr != NULL;
+ framePtr = framePtr->nextPtr) {
+ if (framePtr->level == level) {
+ break;
+ }
+ }
+ if (framePtr == NULL) {
+ goto levelError;
+ }
- switch (framePtr->type) {
- case TCL_LOCATION_EVAL:
- /* Evaluation, dynamic script. Type, line, cmd, the latter
- * through str. */
+ Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInfoFrame --
+ *
+ * Core of InfoFrameCmd, returns TIP280 dict for a given frame.
+ *
+ * Results:
+ * Returns TIP280 dict.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- lv [lc ++] = Tcl_NewStringObj ("type",-1);
- lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
- lv [lc ++] = Tcl_NewStringObj ("line",-1);
- lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
- lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
- lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
- framePtr->cmd.str.len);
- break;
+Tcl_Obj *
+TclInfoFrame(
+ Tcl_Interp *interp, /* Current interpreter. */
+ CmdFrame *framePtr) /* Frame to get info for. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to
+ * the dict. */
+ int lc = 0;
+ /*
+ * This array is indexed by the TCL_LOCATION_... values, except
+ * for _LAST.
+ */
+ static CONST char *typeString[TCL_LOCATION_LAST] = {
+ "eval", "eval", "eval", "precompiled", "source", "proc"
+ };
+ Tcl_Obj *tmpObj;
+ Proc *procPtr =
+ framePtr->framePtr ? framePtr->framePtr->procPtr : NULL;
- case TCL_LOCATION_EVAL_LIST:
- /* List optimized evaluation. Type, line, cmd, the latter
- * through listPtr, possibly a frame. */
+ /*
+ * Pull the information and construct the dictionary to return, as list.
+ * Regarding use of the CmdFrame fields see tclInt.h, and its definition.
+ */
- lv [lc ++] = Tcl_NewStringObj ("type",-1);
- lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
- lv [lc ++] = Tcl_NewStringObj ("line",-1);
- lv [lc ++] = Tcl_NewIntObj (1);
+#define ADD_PAIR(name, value) \
+ TclNewLiteralStringObj(tmpObj, name); \
+ lv[lc++] = tmpObj; \
+ lv[lc++] = (value)
- /* We put a duplicate of the command list obj into the result
- * to ensure that the 'pure List'-property of the command
- * itself is not destroyed. Otherwise the query here would
- * disable the list optimization path in Tcl_EvalObjEx.
- */
+ switch (framePtr->type) {
+ case TCL_LOCATION_EVAL:
+ /*
+ * Evaluation, dynamic script. Type, line, cmd, the latter through
+ * str.
+ */
- lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
- lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr);
- break;
+ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
+ ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
+ framePtr->cmd.str.len));
+ break;
- case TCL_LOCATION_PREBC:
- /* Precompiled. Result contains the type as signal, nothing
- * else */
+ case TCL_LOCATION_EVAL_LIST:
+ /*
+ * List optimized evaluation. Type, line, cmd, the latter through
+ * listPtr, possibly a frame.
+ */
- lv [lc ++] = Tcl_NewStringObj ("type",-1);
- lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
- break;
+ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
+ ADD_PAIR("line", Tcl_NewIntObj(1));
- case TCL_LOCATION_BC: {
- /* Execution of bytecode. Talk to the BC engine to fill out
- * the frame. */
+ /*
+ * We put a duplicate of the command list obj into the result to
+ * ensure that the 'pure List'-property of the command itself is not
+ * destroyed. Otherwise the query here would disable the list
+ * optimization path in Tcl_EvalObjEx.
+ */
- CmdFrame f = *framePtr;
+ ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr));
+ break;
- /* Note: Type BC => f.data.eval.path is not used.
- * f.data.tebc.codePtr is used instead.
- */
+ case TCL_LOCATION_PREBC:
+ /*
+ * Precompiled. Result contains the type as signal, nothing else.
+ */
- TclGetSrcInfoForPc (&f);
- /* Now filled: cmd.str.(cmd,len), line */
- /* Possibly modified: type, path! */
+ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
+ break;
- lv [lc ++] = Tcl_NewStringObj ("type",-1);
- lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1);
- lv [lc ++] = Tcl_NewStringObj ("line",-1);
- lv [lc ++] = Tcl_NewIntObj (f.line[0]);
+ case TCL_LOCATION_BC: {
+ /*
+ * Execution of bytecode. Talk to the BC engine to fill out the frame.
+ */
- if (f.type == TCL_LOCATION_SOURCE) {
- lv [lc ++] = Tcl_NewStringObj ("file",-1);
- lv [lc ++] = f.data.eval.path;
- /* Death of reference by TclGetSrcInfoForPc */
- Tcl_DecrRefCount (f.data.eval.path);
- }
+ CmdFrame *fPtr;
- lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
- lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len);
- break;
- }
+ fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ *fPtr = *framePtr;
- case TCL_LOCATION_SOURCE:
- /* Evaluation of a script file */
-
- lv [lc ++] = Tcl_NewStringObj ("type",-1);
- lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
- lv [lc ++] = Tcl_NewStringObj ("line",-1);
- lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
- lv [lc ++] = Tcl_NewStringObj ("file",-1);
- lv [lc ++] = framePtr->data.eval.path;
- /* Refcount framePtr->data.eval.path goes up when lv
- * is converted into the result list object.
- */
- lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
- lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
- framePtr->cmd.str.len);
- break;
+ /*
+ * Note:
+ * Type BC => f.data.eval.path is not used.
+ * f.data.tebc.codePtr is used instead.
+ */
- case TCL_LOCATION_PROC:
- Tcl_Panic ("TCL_LOCATION_PROC found in standard frame");
- break;
- }
+ TclGetSrcInfoForPc(fPtr);
+
+ /*
+ * Now filled: cmd.str.(cmd,len), line
+ * Possibly modified: type, path!
+ */
+
+ ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
+ if (fPtr->line) {
+ ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0]));
+ }
+
+ if (fPtr->type == TCL_LOCATION_SOURCE) {
+ ADD_PAIR("file", fPtr->data.eval.path);
/*
- * 'proc'. Common to all frame types. Conditional on having an
- * associated Procedure CallFrame.
+ * Death of reference by TclGetSrcInfoForPc.
*/
- if (procPtr != NULL) {
- Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr;
- /*
- * ITcl seems to provide us with weird, maybe bogus Command
- * structures (methods?) which may have no HashEntry pointing
- * to the name information, or a HashEntry without owning
- * HashTable. Therefore check again that our data is valid.
- */
- if (namePtr && namePtr->tablePtr) {
- char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr);
- char* nsName = procPtr->cmdPtr->nsPtr->fullName;
+ Tcl_DecrRefCount(fPtr->data.eval.path);
+ }
- lv [lc ++] = Tcl_NewStringObj ("proc",-1);
- lv [lc ++] = Tcl_NewStringObj (nsName,-1);
+ ADD_PAIR("cmd",
+ Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len));
+ TclStackFree(interp, fPtr);
+ break;
+ }
- if (strcmp (nsName, "::") != 0) {
- Tcl_AppendToObj (lv [lc-1], "::", -1);
- }
- Tcl_AppendToObj (lv [lc-1], procName, -1);
- }
- }
+ case TCL_LOCATION_SOURCE:
+ /*
+ * Evaluation of a script file.
+ */
- /* 'level'. Common to all frame types. Conditional on having an
- * associated _visible_ CallFrame */
+ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
+ ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("file", framePtr->data.eval.path);
- if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
- CallFrame* current = framePtr->framePtr;
- CallFrame* top = iPtr->varFramePtr;
- CallFrame* idx;
+ /*
+ * Refcount framePtr->data.eval.path goes up when lv is converted into
+ * the result list object.
+ */
- for (idx = top;
- idx != NULL;
- idx = idx->callerVarPtr) {
- if (idx == current) {
- int c = framePtr->framePtr->level;
- int t = iPtr->varFramePtr->level;
+ ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
+ framePtr->cmd.str.len));
+ break;
- lv [lc ++] = Tcl_NewStringObj ("level",-1);
- lv [lc ++] = Tcl_NewIntObj (t - c);
- break;
- }
- }
+ case TCL_LOCATION_PROC:
+ Tcl_Panic("TCL_LOCATION_PROC found in standard frame");
+ break;
+ }
+
+ /*
+ * 'proc'. Common to all frame types. Conditional on having an associated
+ * Procedure CallFrame.
+ */
+
+ if (procPtr != NULL) {
+ Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr;
+
+ if (namePtr) {
+ /*
+ * This is a regular command.
+ */
+
+ char *procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr);
+ char *nsName = procPtr->cmdPtr->nsPtr->fullName;
+
+ ADD_PAIR("proc", Tcl_NewStringObj(nsName, -1));
+
+ if (strcmp(nsName, "::") != 0) {
+ Tcl_AppendToObj(lv[lc-1], "::", -1);
}
+ Tcl_AppendToObj(lv[lc-1], procName, -1);
+ } else if (procPtr->cmdPtr->clientData) {
+ ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData;
+ int i;
- Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv));
- return TCL_OK;
+ /*
+ * This is a non-standard command. Luckily, it's told us how to
+ * render extra information about its frame.
+ */
+
+ for (i=0 ; i<efiPtr->length ; i++) {
+ lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1);
+ if (efiPtr->fields[i].proc) {
+ lv[lc++] =
+ efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
+ } else {
+ lv[lc++] = efiPtr->fields[i].clientData;
+ }
+ }
}
}
- Tcl_WrongNumArgs(interp, 2, objv, "?number?");
+ /*
+ * 'level'. Common to all frame types. Conditional on having an associated
+ * _visible_ CallFrame.
+ */
- return TCL_ERROR;
-}
-#endif
-
-/*
- *----------------------------------------------------------------------
- *
- * InfoFunctionsCmd --
- *
- * Called to implement the "info functions" command that returns the
- * list of math functions matching an optional pattern. Handles the
- * following syntax:
- *
- * info functions ?pattern?
- *
- * Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
- *
- * Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
- *
- *----------------------------------------------------------------------
- */
+ if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
+ CallFrame *current = framePtr->framePtr;
+ CallFrame *top = iPtr->varFramePtr;
+ CallFrame *idx;
-static int
-InfoFunctionsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- char *pattern;
- Tcl_Obj *listPtr;
+ for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) {
+ if (idx == current) {
+ int c = framePtr->framePtr->level;
+ int t = iPtr->varFramePtr->level;
- if (objc == 2) {
- pattern = NULL;
- } else if (objc == 3) {
- pattern = Tcl_GetString(objv[2]);
- } else {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
+ ADD_PAIR("level", Tcl_NewIntObj(t - c));
+ break;
+ }
+ }
}
- listPtr = Tcl_ListMathFuncs(interp, pattern);
- if (listPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
+ return Tcl_NewListObj(lc, lv);
}
/*
*----------------------------------------------------------------------
*
- * InfoGlobalsCmd --
+ * InfoFunctionsCmd --
*
- * Called to implement the "info globals" command that returns the list
- * of global variables matching an optional pattern. Handles the
- * following syntax:
+ * Called to implement the "info functions" command that returns the list
+ * of math functions matching an optional pattern. Handles the following
+ * syntax:
*
- * info globals ?pattern?
+ * info functions ?pattern?
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoGlobalsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoFunctionsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- char *varName, *pattern;
- Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
- register Tcl_HashEntry *entryPtr;
- Tcl_HashSearch search;
- Var *varPtr;
- Tcl_Obj *listPtr;
+ char *pattern;
- if (objc == 2) {
- pattern = NULL;
- } else if (objc == 3) {
- pattern = Tcl_GetString(objv[2]);
- /*
- * Strip leading global-namespace qualifiers. [Bug 1057461]
- */
- if (pattern[0] == ':' && pattern[1] == ':') {
- while (*pattern == ':') {
- pattern++;
- }
- }
+ if (objc == 1) {
+ pattern = NULL;
+ } else if (objc == 2) {
+ pattern = TclGetString(objv[1]);
} else {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
}
- /*
- * Scan through the global :: namespace's variable table and create a
- * list of all global variables that match the pattern.
- */
-
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- if (pattern != NULL && TclMatchIsTrivial(pattern)) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(pattern, -1));
- }
- }
- } else {
- for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (TclIsVarUndefined(varPtr)) {
- continue;
- }
- varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
- if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- }
- Tcl_SetObjResult(interp, listPtr);
+ Tcl_SetObjResult(interp, Tcl_ListMathFuncs(interp, pattern));
return TCL_OK;
}
@@ -1423,43 +1358,42 @@ InfoGlobalsCmd(dummy, interp, objc, objv)
*
* InfoHostnameCmd --
*
- * Called to implement the "info hostname" command that returns the
- * host name. Handles the following syntax:
+ * Called to implement the "info hostname" command that returns the host
+ * name. Handles the following syntax:
*
- * info hostname
+ * info hostname
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoHostnameCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoHostnameCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
CONST char *name;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
name = Tcl_GetHostName();
if (name) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
return TCL_OK;
- } else {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "unable to determine name of host", -1);
- return TCL_ERROR;
}
+ Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC);
+ return TCL_ERROR;
}
/*
@@ -1467,71 +1401,69 @@ InfoHostnameCmd(dummy, interp, objc, objv)
*
* InfoLevelCmd --
*
- * Called to implement the "info level" command that returns
- * information about the call stack. Handles the following syntax:
+ * Called to implement the "info level" command that returns information
+ * about the call stack. Handles the following syntax:
*
- * info level ?number?
+ * info level ?number?
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoLevelCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoLevelCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int level;
- CallFrame *framePtr;
- Tcl_Obj *listPtr;
- if (objc == 2) { /* just "info level" */
- if (iPtr->varFramePtr == NULL) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
- } else {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
- }
- return TCL_OK;
- } else if (objc == 3) {
- if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
- return TCL_ERROR;
- }
- if (level <= 0) {
- if (iPtr->varFramePtr == NULL) {
- levelError:
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad level \"",
- Tcl_GetString(objv[2]),
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
- level += iPtr->varFramePtr->level;
- }
- for (framePtr = iPtr->varFramePtr; framePtr != NULL;
- framePtr = framePtr->callerVarPtr) {
- if (framePtr->level == level) {
- break;
- }
- }
- if (framePtr == NULL) {
- goto levelError;
- }
-
- listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
- }
-
- Tcl_WrongNumArgs(interp, 2, objv, "?number?");
+ if (objc == 1) { /* Just "info level" */
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level));
+ return TCL_OK;
+ }
+
+ if (objc == 2) {
+ int level;
+ CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr;
+
+ if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level <= 0) {
+ if (iPtr->varFramePtr == rootFramePtr) {
+ goto levelError;
+ }
+ level += iPtr->varFramePtr->level;
+ }
+ for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr;
+ framePtr=framePtr->callerVarPtr) {
+ if (framePtr->level == level) {
+ break;
+ }
+ }
+ if (framePtr == rootFramePtr) {
+ goto levelError;
+ }
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewListObj(framePtr->objc, framePtr->objv));
+ return TCL_OK;
+ }
+
+ Tcl_WrongNumArgs(interp, 1, objv, "?number?");
+ return TCL_ERROR;
+
+ levelError:
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"",
+ NULL);
return TCL_ERROR;
}
@@ -1540,43 +1472,42 @@ InfoLevelCmd(dummy, interp, objc, objv)
*
* InfoLibraryCmd --
*
- * Called to implement the "info library" command that returns the
- * library directory for the Tcl installation. Handles the following
- * syntax:
+ * Called to implement the "info library" command that returns the
+ * library directory for the Tcl installation. Handles the following
+ * syntax:
*
- * info library
+ * info library
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoLibraryCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoLibraryCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
CONST char *libDirName;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
- return TCL_OK;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
+ return TCL_OK;
}
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "no library has been specified for Tcl", -1);
+ Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC);
return TCL_ERROR;
}
@@ -1585,174 +1516,42 @@ InfoLibraryCmd(dummy, interp, objc, objv)
*
* InfoLoadedCmd --
*
- * Called to implement the "info loaded" command that returns the
- * packages that have been loaded into an interpreter. Handles the
- * following syntax:
+ * Called to implement the "info loaded" command that returns the
+ * packages that have been loaded into an interpreter. Handles the
+ * following syntax:
*
- * info loaded ?interp?
+ * info loaded ?interp?
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoLoadedCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoLoadedCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
char *interpName;
- int result;
- if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
- return TCL_ERROR;
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ return TCL_ERROR;
}
- if (objc == 2) { /* get loaded pkgs in all interpreters */
+ if (objc == 1) { /* Get loaded pkgs in all interpreters. */
interpName = NULL;
- } else { /* get pkgs just in specified interp */
- interpName = Tcl_GetString(objv[2]);
- }
- result = TclGetLoadedPackages(interp, interpName);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InfoLocalsCmd --
- *
- * Called to implement the "info locals" command to return a list of
- * local variables that match an optional pattern. Handles the
- * following syntax:
- *
- * info locals ?pattern?
- *
- * Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
- *
- * Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InfoLocalsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Interp *iPtr = (Interp *) interp;
- char *pattern;
- Tcl_Obj *listPtr;
-
- if (objc == 2) {
- pattern = NULL;
- } else if (objc == 3) {
- pattern = Tcl_GetString(objv[2]);
- } else {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
- }
-
- if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
- return TCL_OK;
- }
-
- /*
- * Return a list containing names of first the compiled locals (i.e. the
- * ones stored in the call frame), then the variables in the local hash
- * table (if one exists).
- */
-
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- AppendLocals(interp, listPtr, pattern, 0);
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AppendLocals --
- *
- * Append the local variables for the current frame to the
- * specified list object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AppendLocals(interp, listPtr, pattern, includeLinks)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Obj *listPtr; /* List object to append names to. */
- CONST char *pattern; /* Pattern to match against. */
- int includeLinks; /* 1 if upvars should be included, else 0. */
-{
- Interp *iPtr = (Interp *) interp;
- CompiledLocal *localPtr;
- Var *varPtr;
- int i, localVarCt;
- char *varName;
- Tcl_HashTable *localVarTablePtr;
- register Tcl_HashEntry *entryPtr;
- Tcl_HashSearch search;
-
- localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
- localVarCt = iPtr->varFramePtr->numCompiledLocals;
- varPtr = iPtr->varFramePtr->compiledLocals;
- localVarTablePtr = iPtr->varFramePtr->varTablePtr;
-
- for (i = 0; i < localVarCt; i++) {
- /*
- * Skip nameless (temporary) variables and undefined variables
- */
-
- if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
- && (includeLinks || !TclIsVarLink(varPtr))) {
- varName = varPtr->name;
- if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- varPtr++;
- localPtr = localPtr->nextPtr;
- }
-
- if (localVarTablePtr != NULL) {
- for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- && (includeLinks || !TclIsVarLink(varPtr))) {
- varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
- if ((pattern == NULL)
- || Tcl_StringMatch(varName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- }
+ } else { /* Get pkgs just in specified interp. */
+ interpName = TclGetString(objv[1]);
}
+ return TclGetLoadedPackages(interp, interpName);
}
/*
@@ -1760,41 +1559,34 @@ AppendLocals(interp, listPtr, pattern, includeLinks)
*
* InfoNameOfExecutableCmd --
*
- * Called to implement the "info nameofexecutable" command that returns
- * the name of the binary file running this application. Handles the
- * following syntax:
+ * Called to implement the "info nameofexecutable" command that returns
+ * the name of the binary file running this application. Handles the
+ * following syntax:
*
- * info nameofexecutable
+ * info nameofexecutable
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoNameOfExecutableCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoNameOfExecutableCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- CONST char *nameOfExecutable;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
-
- nameOfExecutable = Tcl_GetNameOfExecutable();
-
- if (nameOfExecutable != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
+ Tcl_SetObjResult(interp, TclGetObjNameOfExecutable());
return TCL_OK;
}
@@ -1803,41 +1595,41 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv)
*
* InfoPatchLevelCmd --
*
- * Called to implement the "info patchlevel" command that returns the
- * default value for an argument to a procedure. Handles the following
- * syntax:
+ * Called to implement the "info patchlevel" command that returns the
+ * default value for an argument to a procedure. Handles the following
+ * syntax:
*
- * info patchlevel
+ * info patchlevel
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoPatchLevelCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoPatchLevelCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
CONST char *patchlevel;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
- (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+ (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
- return TCL_OK;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
+ return TCL_OK;
}
return TCL_ERROR;
}
@@ -1847,31 +1639,31 @@ InfoPatchLevelCmd(dummy, interp, objc, objv)
*
* InfoProcsCmd --
*
- * Called to implement the "info procs" command that returns the
- * list of procedures in the interpreter that match an optional pattern.
- * The pattern, if any, consists of an optional sequence of namespace
- * names separated by "::" qualifiers, which is followed by a
- * glob-style pattern that restricts which commands are returned.
- * Handles the following syntax:
+ * Called to implement the "info procs" command that returns the list of
+ * procedures in the interpreter that match an optional pattern. The
+ * pattern, if any, consists of an optional sequence of namespace names
+ * separated by "::" qualifiers, which is followed by a glob-style
+ * pattern that restricts which commands are returned. Handles the
+ * following syntax:
*
- * info procs ?pattern?
+ * info procs ?pattern?
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoProcsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoProcsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
char *cmdName, *pattern;
CONST char *simplePattern;
@@ -1879,44 +1671,44 @@ InfoProcsCmd(dummy, interp, objc, objv)
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
#endif
- Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
- int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
+ int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
/*
- * Get the pattern and find the "effective namespace" in which to
- * list procs.
+ * Get the pattern and find the "effective namespace" in which to list
+ * procs.
*/
- if (objc == 2) {
+ if (objc == 1) {
simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
- } else if (objc == 3) {
+ } else if (objc == 2) {
/*
* From the pattern, get the effective namespace and the simple
- * pattern (no namespace qualifiers or ::'s) at the end. If an
- * error was found while parsing the pattern, return it. Otherwise,
- * if the namespace wasn't found, just leave nsPtr NULL: we will
- * return an empty list since no commands there can be found.
+ * pattern (no namespace qualifiers or ::'s) at the end. If an error
+ * was found while parsing the pattern, return it. Otherwise, if the
+ * namespace wasn't found, just leave nsPtr NULL: we will return an
+ * empty list since no commands there can be found.
*/
Namespace *dummy1NsPtr, *dummy2NsPtr;
- pattern = Tcl_GetString(objv[2]);
+ pattern = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
&simplePattern);
- if (nsPtr != NULL) { /* we successfully found the pattern's ns */
+ if (nsPtr != NULL) { /* We successfully found the pattern's ns. */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
+ Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
+ return TCL_ERROR;
}
if (nsPtr == NULL) {
@@ -1924,13 +1716,13 @@ InfoProcsCmd(dummy, interp, objc, objv)
}
/*
- * Scan through the effective namespace's command table and create a
- * list with all procs that match the pattern. If a specific
- * namespace was requested in the pattern, qualify the command names
- * with the namespace name.
+ * Scan through the effective namespace's command table and create a list
+ * with all procs that match the pattern. If a specific namespace was
+ * requested in the pattern, qualify the command names with the namespace
+ * name.
*/
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ listPtr = Tcl_NewListObj(0, NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
@@ -1944,7 +1736,7 @@ InfoProcsCmd(dummy, interp, objc, objv)
goto simpleProcOK;
}
} else {
- simpleProcOK:
+ simpleProcOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
@@ -1962,7 +1754,7 @@ InfoProcsCmd(dummy, interp, objc, objv)
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
- || Tcl_StringMatch(cmdName, simplePattern)) {
+ || Tcl_StringMatch(cmdName, simplePattern)) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
@@ -1972,7 +1764,7 @@ InfoProcsCmd(dummy, interp, objc, objv)
goto procOK;
}
} else {
- procOK:
+ procOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
@@ -1988,35 +1780,36 @@ InfoProcsCmd(dummy, interp, objc, objv)
/*
* If the effective namespace isn't the global :: namespace, and a
- * specific namespace wasn't requested in the pattern, then add in
- * all global :: procs that match the simple pattern. Of course,
- * we add in only those procs that aren't hidden by a proc in
- * the effective namespace.
+ * specific namespace wasn't requested in the pattern, then add in all
+ * global :: procs that match the simple pattern. Of course, we add in
+ * only those procs that aren't hidden by a proc in the effective
+ * namespace.
*/
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
/*
- * If "info procs" worked like "info commands", returning the
- * commands also seen in the global namespace, then you would
- * include this code. As this could break backwards compatibilty
- * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
- * behavior slightly different.
+ * If "info procs" worked like "info commands", returning the commands
+ * also seen in the global namespace, then you would include this
+ * code. As this could break backwards compatibilty with 8.0-8.2, we
+ * decided not to "fix" it in 8.3, leaving the behavior slightly
+ * different.
*/
+
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
- || Tcl_StringMatch(cmdName, simplePattern)) {
- if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
- (Tcl_Command) cmdPtr);
+ (Tcl_Command) cmdPtr);
if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
&& TclIsProc(realCmdPtr))) {
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(cmdName, -1));
+ Tcl_NewStringObj(cmdName, -1));
}
}
}
@@ -2035,47 +1828,46 @@ InfoProcsCmd(dummy, interp, objc, objv)
*
* InfoScriptCmd --
*
- * Called to implement the "info script" command that returns the
- * script file that is currently being evaluated. Handles the
- * following syntax:
+ * Called to implement the "info script" command that returns the script
+ * file that is currently being evaluated. Handles the following syntax:
*
- * info script ?newName?
+ * info script ?newName?
*
* If newName is specified, it will set that as the internal name.
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message. It may change the
- * internal script filename.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message. It may change the internal
+ * script filename.
*
*----------------------------------------------------------------------
*/
static int
-InfoScriptCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoScriptCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?filename?");
- return TCL_ERROR;
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?filename?");
+ return TCL_ERROR;
}
- if (objc == 3) {
+ if (objc == 2) {
if (iPtr->scriptFile != NULL) {
Tcl_DecrRefCount(iPtr->scriptFile);
}
- iPtr->scriptFile = objv[2];
+ iPtr->scriptFile = objv[1];
Tcl_IncrRefCount(iPtr->scriptFile);
}
if (iPtr->scriptFile != NULL) {
- Tcl_SetObjResult(interp, iPtr->scriptFile);
+ Tcl_SetObjResult(interp, iPtr->scriptFile);
}
return TCL_OK;
}
@@ -2085,36 +1877,36 @@ InfoScriptCmd(dummy, interp, objc, objv)
*
* InfoSharedlibCmd --
*
- * Called to implement the "info sharedlibextension" command that
- * returns the file extension used for shared libraries. Handles the
- * following syntax:
+ * Called to implement the "info sharedlibextension" command that returns
+ * the file extension used for shared libraries. Handles the following
+ * syntax:
*
- * info sharedlibextension
+ * info sharedlibextension
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoSharedlibCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoSharedlibCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
-
+
#ifdef TCL_SHLIB_EXT
- Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(TCL_SHLIB_EXT, -1));
#endif
return TCL_OK;
}
@@ -2124,40 +1916,40 @@ InfoSharedlibCmd(dummy, interp, objc, objv)
*
* InfoTclVersionCmd --
*
- * Called to implement the "info tclversion" command that returns the
- * version number for this Tcl library. Handles the following syntax:
+ * Called to implement the "info tclversion" command that returns the
+ * version number for this Tcl library. Handles the following syntax:
*
- * info tclversion
+ * info tclversion
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * Returns a result in the interpreter's result object. If there is an
+ * error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
-InfoTclVersionCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+InfoTclVersionCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- CONST char *version;
+ Tcl_Obj *version;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
}
- version = Tcl_GetVar(interp, "tcl_version",
- (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+ version = Tcl_GetVar2Ex(interp, "tcl_version", NULL,
+ (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (version != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
- return TCL_OK;
+ Tcl_SetObjResult(interp, version);
+ return TCL_OK;
}
return TCL_ERROR;
}
@@ -2165,204 +1957,67 @@ InfoTclVersionCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * InfoVarsCmd --
- *
- * Called to implement the "info vars" command that returns the
- * list of variables in the interpreter that match an optional pattern.
- * The pattern, if any, consists of an optional sequence of namespace
- * names separated by "::" qualifiers, which is followed by a
- * glob-style pattern that restricts which variables are returned.
- * Handles the following syntax:
+ * Tcl_JoinObjCmd --
*
- * info vars ?pattern?
+ * This procedure is invoked to process the "join" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
- * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ * A standard Tcl object result.
*
* Side effects:
- * Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
-static int
-InfoVarsCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+int
+Tcl_JoinObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* The argument objects. */
{
- Interp *iPtr = (Interp *) interp;
- char *varName, *pattern;
- CONST char *simplePattern;
- register Tcl_HashEntry *entryPtr;
- Tcl_HashSearch search;
- Var *varPtr;
- Namespace *nsPtr;
- Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
- Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
- Tcl_Obj *listPtr, *elemObjPtr;
- int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
-
- /*
- * Get the pattern and find the "effective namespace" in which to
- * list variables. We only use this effective namespace if there's
- * no active Tcl procedure frame.
- */
-
- if (objc == 2) {
- simplePattern = NULL;
- nsPtr = currNsPtr;
- specificNsInPattern = 0;
- } else if (objc == 3) {
- /*
- * From the pattern, get the effective namespace and the simple
- * pattern (no namespace qualifiers or ::'s) at the end. If an
- * error was found while parsing the pattern, return it. Otherwise,
- * if the namespace wasn't found, just leave nsPtr NULL: we will
- * return an empty list since no variables there can be found.
- */
+ int listLen, i;
+ Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
- Namespace *dummy1NsPtr, *dummy2NsPtr;
-
- pattern = Tcl_GetString(objv[2]);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
- &simplePattern);
-
- if (nsPtr != NULL) { /* we successfully found the pattern's ns */
- specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
- }
- } else {
- Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
- return TCL_ERROR;
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
+ return TCL_ERROR;
}
/*
- * If the namespace specified in the pattern wasn't found, just return.
+ * Make sure the list argument is a list object and get its length and a
+ * pointer to its array of element pointers.
*/
- if (nsPtr == NULL) {
- return TCL_OK;
+ if (TclListObjGetElements(interp, objv[1], &listLen,
+ &elemPtrs) != TCL_OK) {
+ return TCL_ERROR;
}
-
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
-
- if ((iPtr->varFramePtr == NULL)
- || !iPtr->varFramePtr->isProcCallFrame
- || specificNsInPattern) {
- /*
- * There is no frame pointer, the frame pointer was pushed only
- * to activate a namespace, or we are in a procedure call frame
- * but a specific namespace was specified. Create a list containing
- * only the variables in the effective namespace's variable table.
- */
-
- if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
- /*
- * If we can just do hash lookups, that simplifies things
- * a lot.
- */
- entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || (varPtr->flags & VAR_NAMESPACE_VAR)) {
- if (specificNsInPattern) {
- elemObjPtr = Tcl_NewObj();
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
- elemObjPtr);
- } else {
- elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
- }
- Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
- }
- } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
- simplePattern);
- if (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || (varPtr->flags & VAR_NAMESPACE_VAR)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(simplePattern, -1));
- }
- }
- }
- } else {
- /*
- * Have to scan the tables of variables.
- */
+ joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
+ Tcl_IncrRefCount(joinObjPtr);
- entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
- while (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || (varPtr->flags & VAR_NAMESPACE_VAR)) {
- varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
- if ((simplePattern == NULL)
- || Tcl_StringMatch(varName, simplePattern)) {
- if (specificNsInPattern) {
- elemObjPtr = Tcl_NewObj();
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
- elemObjPtr);
- } else {
- elemObjPtr = Tcl_NewStringObj(varName, -1);
- }
- Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
- }
- }
- entryPtr = Tcl_NextHashEntry(&search);
- }
-
- /*
- * If the effective namespace isn't the global ::
- * namespace, and a specific namespace wasn't requested in
- * the pattern (i.e., the pattern only specifies variable
- * names), then add in all global :: variables that match
- * the simple pattern. Of course, add in only those
- * variables that aren't hidden by a variable in the
- * effective namespace.
- */
-
- if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
- while (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || (varPtr->flags & VAR_NAMESPACE_VAR)) {
- varName = Tcl_GetHashKey(&globalNsPtr->varTable,
- entryPtr);
- if ((simplePattern == NULL)
- || Tcl_StringMatch(varName, simplePattern)) {
- if (Tcl_FindHashEntry(&nsPtr->varTable,
- varName) == NULL) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
- }
- }
- }
- entryPtr = Tcl_NextHashEntry(&search);
- }
- }
+ resObjPtr = Tcl_NewObj();
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
}
- } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
- AppendLocals(interp, listPtr, simplePattern, 1);
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
-
- Tcl_SetObjResult(interp, listPtr);
+ Tcl_DecrRefCount(joinObjPtr);
+ Tcl_SetObjResult(interp, resObjPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_JoinObjCmd --
+ * Tcl_LassignObjCmd --
*
- * This procedure is invoked to process the "join" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "lassign" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
@@ -2373,54 +2028,59 @@ InfoVarsCmd(dummy, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_JoinObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
+Tcl_LassignObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- char *joinString, *bytes;
- int joinLength, listLen, length, i, result;
- Tcl_Obj **elemPtrs;
- Tcl_Obj *resObjPtr;
+ Tcl_Obj *listCopyPtr;
+ Tcl_Obj **listObjv; /* The contents of the list. */
+ int listObjc; /* The length of the list. */
+ int code = TCL_OK;
- if (objc == 2) {
- joinString = " ";
- joinLength = 1;
- } else if (objc == 3) {
- joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list varName ?varName ...?");
return TCL_ERROR;
}
- /*
- * Make sure the list argument is a list object and get its length and
- * a pointer to its array of element pointers.
- */
-
- result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
+ listCopyPtr = TclListObjCopy(interp, objv[1]);
+ if (listCopyPtr == NULL) {
+ return TCL_ERROR;
}
- /*
- * Now concatenate strings to form the "joined" result. We append
- * directly into the interpreter's result object.
- */
+ TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv);
- resObjPtr = Tcl_GetObjResult(interp);
+ objc -= 2;
+ objv += 2;
+ while (code == TCL_OK && objc > 0 && listObjc > 0) {
+ if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL,
+ *listObjv++, TCL_LEAVE_ERR_MSG)) {
+ code = TCL_ERROR;
+ }
+ objc--; listObjc--;
+ }
- for (i = 0; i < listLen; i++) {
- bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
- if (i > 0) {
- Tcl_AppendToObj(resObjPtr, joinString, joinLength);
+ if (code == TCL_OK && objc > 0) {
+ Tcl_Obj *emptyObj;
+ TclNewObj(emptyObj);
+ Tcl_IncrRefCount(emptyObj);
+ while (code == TCL_OK && objc-- > 0) {
+ if (NULL == Tcl_ObjSetVar2(interp, *objv++, NULL,
+ emptyObj, TCL_LEAVE_ERR_MSG)) {
+ code = TCL_ERROR;
+ }
}
- Tcl_AppendToObj(resObjPtr, bytes, length);
+ Tcl_DecrRefCount(emptyObj);
}
- return TCL_OK;
+
+ if (code == TCL_OK && listObjc > 0) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv));
+ }
+
+ Tcl_DecrRefCount(listCopyPtr);
+ return code;
}
/*
@@ -2440,16 +2100,15 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LindexObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_LindexObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
- Tcl_Obj *elemPtr; /* Pointer to the element being extracted */
+ Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
@@ -2457,31 +2116,27 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv)
}
/*
- * If objc == 3, then objv[ 2 ] may be either a single index or
- * a list of indices: go to TclLindexList to determine which.
- * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
- * single indices and processed as such in TclLindexFlat.
+ * If objc==3, then objv[2] may be either a single index or a list of
+ * indices: go to TclLindexList to determine which. If objc>=4, or
+ * objc==2, then objv[2 .. objc-2] are all single indices and processed as
+ * such in TclLindexFlat.
*/
- if ( objc == 3 ) {
-
- elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );
-
+ if (objc == 3) {
+ elemPtr = TclLindexList(interp, objv[1], objv[2]);
} else {
-
- elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );
-
+ elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2);
}
-
+
/*
- * Set the interpreter's object result to the last element extracted
+ * Set the interpreter's object result to the last element extracted.
*/
- if ( elemPtr == NULL ) {
+ if (elemPtr == NULL) {
return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, elemPtr);
- Tcl_DecrRefCount( elemPtr );
+ Tcl_DecrRefCount(elemPtr);
return TCL_OK;
}
}
@@ -2489,306 +2144,14 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * TclLindexList --
- *
- * This procedure handles the 'lindex' command when objc==3.
- *
- * Results:
- * Returns a pointer to the object extracted, or NULL if an
- * error occurred.
- *
- * Side effects:
- * None.
- *
- * If objv[1] can be parsed as a list, TclLindexList handles extraction
- * of the desired element locally. Otherwise, it invokes
- * TclLindexFlat to treat objv[1] as a scalar.
- *
- * The reference count of the returned object includes one reference
- * corresponding to the pointer returned. Thus, the calling code will
- * usually do something like:
- * Tcl_SetObjResult( interp, result );
- * Tcl_DecrRefCount( result );
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclLindexList( interp, listPtr, argPtr )
- Tcl_Interp* interp; /* Tcl interpreter */
- Tcl_Obj* listPtr; /* List being unpacked */
- Tcl_Obj* argPtr; /* Index or index list */
-{
-
- Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */
- int listLen; /* Length of the list being manipulated. */
- int index; /* Index into the list */
- int result; /* Result returned from a Tcl library call */
- int i; /* Current index number */
- Tcl_Obj** indices; /* Array of list indices */
- int indexCount; /* Size of the array of list indices */
- Tcl_Obj* oldListPtr; /* Temp location to preserve the list
- * pointer when replacing it with a sublist */
-
- /*
- * Determine whether argPtr designates a list or a single index.
- * We have to be careful about the order of the checks to avoid
- * repeated shimmering; see TIP#22 and TIP#33 for the details.
- */
-
- if ( argPtr->typePtr != &tclListType
- && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {
-
- /*
- * argPtr designates a single index.
- */
-
- return TclLindexFlat( interp, listPtr, 1, &argPtr );
-
- } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
- != TCL_OK ) {
-
- /*
- * argPtr designates something that is neither an index nor a
- * well-formed list. Report the error via TclLindexFlat.
- */
-
- return TclLindexFlat( interp, listPtr, 1, &argPtr );
- }
-
- /*
- * Record the reference to the list that we are maintaining in
- * the activation record.
- */
-
- Tcl_IncrRefCount( listPtr );
-
- /*
- * argPtr designates a list, and the 'else if' above has parsed it
- * into indexCount and indices.
- */
-
- for ( i = 0; i < indexCount; ++i ) {
-
- /*
- * Convert the current listPtr to a list if necessary.
- */
-
- result = Tcl_ListObjGetElements( interp, listPtr,
- &listLen, &elemPtrs);
- if (result != TCL_OK) {
- Tcl_DecrRefCount( listPtr );
- return NULL;
- }
-
- /*
- * Get the index from indices[ i ]
- */
-
- result = TclGetIntForIndex( interp, indices[ i ],
- /*endValue*/ (listLen - 1),
- &index );
- if ( result != TCL_OK ) {
- /*
- * Index could not be parsed
- */
-
- Tcl_DecrRefCount( listPtr );
- return NULL;
-
- } else if ( index < 0
- || index >= listLen ) {
- /*
- * Index is out of range
- */
- Tcl_DecrRefCount( listPtr );
- listPtr = Tcl_NewObj();
- Tcl_IncrRefCount( listPtr );
- return listPtr;
- }
-
- /*
- * Make sure listPtr still refers to a list object.
- * If it shared a Tcl_Obj structure with the arguments, then
- * it might have just been converted to something else.
- */
-
- if (listPtr->typePtr != &tclListType) {
- result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
- &elemPtrs);
- if (result != TCL_OK) {
- Tcl_DecrRefCount( listPtr );
- return NULL;
- }
- }
-
- /*
- * Extract the pointer to the appropriate element
- */
-
- oldListPtr = listPtr;
- listPtr = elemPtrs[ index ];
- Tcl_IncrRefCount( listPtr );
- Tcl_DecrRefCount( oldListPtr );
-
- /*
- * The work we did above may have caused the internal rep
- * of *argPtr to change to something else. Get it back.
- */
-
- result = Tcl_ListObjGetElements( interp, argPtr,
- &indexCount, &indices );
- if ( result != TCL_OK ) {
- /*
- * This can't happen unless some extension corrupted a Tcl_Obj.
- */
- Tcl_DecrRefCount( listPtr );
- return NULL;
- }
-
- } /* end for */
-
- /*
- * Return the last object extracted. Its reference count will include
- * the reference being returned.
- */
-
- return listPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclLindexFlat --
- *
- * This procedure handles the 'lindex' command, given that the
- * arguments to the command are known to be a flat list.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- * This procedure is called from either tclExecute.c or
- * Tcl_LindexObjCmd whenever either is presented with
- * objc == 2 or objc >= 4. It is also called from TclLindexList
- * for the objc==3 case once it is determined that objv[2] cannot
- * be parsed as a list.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclLindexFlat( interp, listPtr, indexCount, indexArray )
- Tcl_Interp* interp; /* Tcl interpreter */
- Tcl_Obj* listPtr; /* Tcl object representing the list */
- int indexCount; /* Count of indices */
- Tcl_Obj* CONST indexArray[];
- /* Array of pointers to Tcl objects
- * representing the indices in the
- * list */
-{
-
- int i; /* Current list index */
- int result; /* Result of Tcl library calls */
- int listLen; /* Length of the current list being
- * processed */
- Tcl_Obj** elemPtrs; /* Array of pointers to the elements
- * of the current list */
- int index; /* Parsed version of the current element
- * of indexArray */
- Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that
- * its ref count can be decremented. */
-
- /*
- * Record the reference to the 'listPtr' object that we are
- * maintaining in the C activation record.
- */
-
- Tcl_IncrRefCount( listPtr );
-
- for ( i = 0; i < indexCount; ++i ) {
-
- /*
- * Convert the current listPtr to a list if necessary.
- */
-
- result = Tcl_ListObjGetElements(interp, listPtr,
- &listLen, &elemPtrs);
- if (result != TCL_OK) {
- Tcl_DecrRefCount( listPtr );
- return NULL;
- }
-
- /*
- * Get the index from objv[i]
- */
-
- result = TclGetIntForIndex( interp, indexArray[ i ],
- /*endValue*/ (listLen - 1),
- &index );
- if ( result != TCL_OK ) {
-
- /* Index could not be parsed */
-
- Tcl_DecrRefCount( listPtr );
- return NULL;
-
- } else if ( index < 0
- || index >= listLen ) {
-
- /*
- * Index is out of range
- */
-
- Tcl_DecrRefCount( listPtr );
- listPtr = Tcl_NewObj();
- Tcl_IncrRefCount( listPtr );
- return listPtr;
- }
-
- /*
- * Make sure listPtr still refers to a list object.
- * It might have been converted to something else above
- * if objv[1] overlaps with one of the other parameters.
- */
-
- if (listPtr->typePtr != &tclListType) {
- result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
- &elemPtrs);
- if (result != TCL_OK) {
- Tcl_DecrRefCount( listPtr );
- return NULL;
- }
- }
-
- /*
- * Extract the pointer to the appropriate element
- */
-
- oldListPtr = listPtr;
- listPtr = elemPtrs[ index ];
- Tcl_IncrRefCount( listPtr );
- Tcl_DecrRefCount( oldListPtr );
-
- }
-
- return listPtr;
-
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_LinsertObjCmd --
*
* This object-based procedure is invoked to process the "linsert" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
- * A new Tcl list object formed by inserting zero or more elements
- * into a list.
+ * A new Tcl list object formed by inserting zero or more elements into a
+ * list.
*
* Side effects:
* See the user documentation.
@@ -2796,34 +2159,33 @@ TclLindexFlat( interp, listPtr, indexCount, indexArray )
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LinsertObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- register int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_LinsertObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ register int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
- int index, isDuplicate, len, result;
+ int index, len, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &len);
+ result = TclListObjLength(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
/*
- * Get the index. "end" is interpreted to be the index after the last
+ * Get the index. "end" is interpreted to be the index after the last
* element, such that using it will cause any inserted elements to be
* appended to the list.
*/
- result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
@@ -2832,33 +2194,25 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
}
/*
- * If the list object is unshared we can modify it directly. Otherwise
- * we create a copy to modify: this is "copy on write".
+ * If the list object is unshared we can modify it directly. Otherwise we
+ * create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
- isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
- listPtr = Tcl_DuplicateObj(listPtr);
- isDuplicate = 1;
+ listPtr = TclListObjCopy(NULL, listPtr);
}
if ((objc == 4) && (index == len)) {
/*
* Special case: insert one element at the end of the list.
*/
- result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
- } else if (objc > 3) {
- result = Tcl_ListObjReplace(interp, listPtr, index, 0,
- (objc-3), &(objv[3]));
- }
- if (result != TCL_OK) {
- if (isDuplicate) {
- Tcl_DecrRefCount(listPtr); /* free unneeded obj */
- }
- return result;
+
+ Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
+ } else {
+ Tcl_ListObjReplace(NULL, listPtr, index, 0, (objc-3), &(objv[3]));
}
-
+
/*
* Set the interpreter's object result.
*/
@@ -2872,8 +2226,8 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
*
* Tcl_ListObjCmd --
*
- * This procedure is invoked to process the "list" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "list" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
@@ -2884,21 +2238,21 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_ListObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- register int objc; /* Number of arguments. */
- register Tcl_Obj *CONST objv[]; /* The argument objects. */
+Tcl_ListObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ register int objc, /* Number of arguments. */
+ register Tcl_Obj *CONST objv[])
+ /* The argument objects. */
{
/*
* If there are no list elements, the result is an empty object.
- * Otherwise modify the interpreter's result object to be a list object.
+ * Otherwise set the interpreter's result object to be a list object.
*/
-
+
if (objc > 1) {
- Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
+ Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1])));
}
return TCL_OK;
}
@@ -2909,7 +2263,7 @@ Tcl_ListObjCmd(dummy, interp, objc, objv)
* Tcl_LlengthObjCmd --
*
* This object-based procedure is invoked to process the "llength" Tcl
- * command. See the user documentation for details on what it does.
+ * command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
@@ -2920,13 +2274,13 @@ Tcl_ListObjCmd(dummy, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LlengthObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- register Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_LlengthObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ register Tcl_Obj *CONST objv[])
+ /* Argument objects. */
{
int listLen, result;
@@ -2935,17 +2289,17 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
* Set the interpreter's object result to an integer object holding the
- * length.
+ * length.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen));
return TCL_OK;
}
@@ -2954,8 +2308,8 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv)
*
* Tcl_LrangeObjCmd --
*
- * This procedure is invoked to process the "lrange" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "lrange" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
@@ -2966,17 +2320,16 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
- ClientData notUsed; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- register Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_LrangeObjCmd(
+ ClientData notUsed, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ register Tcl_Obj *CONST objv[])
+ /* Argument objects. */
{
- Tcl_Obj *listPtr;
- Tcl_Obj **elemPtrs;
- int listLen, first, last, numElems, result;
+ Tcl_Obj *listPtr, **elemPtrs;
+ int listLen, first, result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
@@ -2984,62 +2337,143 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
}
/*
- * Make sure the list argument is a list object and get its length and
- * a pointer to its array of element pointers.
+ * Make sure the list argument is a list object and get its length and a
+ * pointer to its array of element pointers.
*/
- listPtr = objv[1];
- result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
+ listPtr = TclListObjCopy(interp, objv[1]);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
}
+ TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);
- /*
- * Get the first and last indexes.
- */
-
- result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
+ result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
- if (result != TCL_OK) {
- return result;
- }
- if (first < 0) {
- first = 0;
+ if (result == TCL_OK) {
+ int last;
+
+ if (first < 0) {
+ first = 0;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
+ &last);
+ if (result == TCL_OK) {
+ if (last >= listLen) {
+ last = (listLen - 1);
+ }
+
+ if (first <= last) {
+ int numElems = (last - first + 1);
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewListObj(numElems, &(elemPtrs[first])));
+ }
+ }
}
- result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
- &last);
- if (result != TCL_OK) {
- return result;
+ Tcl_DecrRefCount(listPtr);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LrepeatObjCmd --
+ *
+ * This procedure is invoked to process the "lrepeat" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LrepeatObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ register int objc, /* Number of arguments. */
+ register Tcl_Obj *CONST objv[])
+ /* The argument objects. */
+{
+ int elementCount, i, totalElems;
+ Tcl_Obj *listPtr, **dataArray;
+ List *listRepPtr;
+
+ /*
+ * Check arguments for legality:
+ * lrepeat posInt value ?value ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?");
+ return TCL_ERROR;
}
- if (last >= listLen) {
- last = (listLen - 1);
+ if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) {
+ return TCL_ERROR;
}
-
- if (first > last) {
- return TCL_OK; /* the result is an empty object */
+ if (elementCount < 1) {
+ Tcl_AppendResult(interp, "must have a count of at least 1", NULL);
+ return TCL_ERROR;
}
/*
- * Make sure listPtr still refers to a list object. It might have been
- * converted to an int above if the argument objects were shared.
- */
+ * Skip forward to the interesting arguments now we've finished parsing.
+ */
+
+ objc -= 2;
+ objv += 2;
- if (listPtr->typePtr != &tclListType) {
- result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
- &elemPtrs);
- if (result != TCL_OK) {
- return result;
- }
+ /* Final sanity check. Do not exceed limits on max list length. */
+
+ if (objc > LIST_MAX/elementCount) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max length of a Tcl list (%d elements) exceeded", LIST_MAX));
+ return TCL_ERROR;
}
+ totalElems = objc * elementCount;
/*
- * Extract a range of fields. We modify the interpreter's result object
- * to be a list object containing the specified elements.
+ * Get an empty list object that is allocated large enough to hold each
+ * init value elementCount times.
*/
- numElems = (last - first + 1);
- Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
+ listPtr = Tcl_NewListObj(totalElems, NULL);
+ listRepPtr = ListRepPtr(listPtr);
+ listRepPtr->elemCount = elementCount*objc;
+ dataArray = &listRepPtr->elements;
+
+ /*
+ * Set the elements. Note that we handle the common degenerate case of a
+ * single value being repeated separately to permit the compiler as much
+ * room as possible to optimize a loop that might be run a very large
+ * number of times.
+ */
+
+ if (objc == 1) {
+ register Tcl_Obj *tmpPtr = objv[0];
+
+ tmpPtr->refCount += elementCount;
+ for (i=0 ; i<elementCount ; i++) {
+ dataArray[i] = tmpPtr;
+ }
+ } else {
+ int j, k = 0;
+
+ for (i=0 ; i<elementCount ; i++) {
+ for (j=0 ; j<objc ; j++) {
+ Tcl_IncrRefCount(objv[j]);
+ dataArray[k++] = objv[j];
+ }
+ }
+ }
+
+ Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
@@ -3048,12 +2482,12 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
*
* Tcl_LreplaceObjCmd --
*
- * This object-based procedure is invoked to process the "lreplace"
- * Tcl command. See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "lreplace" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A new Tcl list object formed by replacing zero or more elements of
- * a list.
+ * A new Tcl list object formed by replacing zero or more elements of a
+ * list.
*
* Side effects:
* See the user documentation.
@@ -3061,16 +2495,15 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_LreplaceObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Tcl_Obj *listPtr;
- int isDuplicate, first, last, listLen, numToDelete, result;
+ int first, last, listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -3078,42 +2511,41 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
/*
- * Get the first and last indexes. "end" is interpreted to be the index
- * for the last element, such that using it will cause that element to
- * be included for deletion.
+ * Get the first and last indexes. "end" is interpreted to be the index
+ * for the last element, such that using it will cause that element to be
+ * included for deletion.
*/
- result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first);
if (result != TCL_OK) {
return result;
}
- result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
+ result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
if (result != TCL_OK) {
return result;
}
- if (first < 0) {
+ if (first < 0) {
first = 0;
}
/*
* Complain if the user asked for a start element that is greater than the
- * list length. This won't ever trigger for the "end*" case as that will
+ * list length. This won't ever trigger for the "end-*" case as that will
* be properly constrained by TclGetIntForIndex because we use listLen-1
* (to allow for replacing the last elem).
*/
if ((first >= listLen) && (listLen > 0)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "list doesn't contain element ",
- Tcl_GetString(objv[2]), (int *) NULL);
+ Tcl_AppendResult(interp, "list doesn't contain element ",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
if (last >= listLen) {
@@ -3126,35 +2558,109 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
}
/*
- * If the list object is unshared we can modify it directly, otherwise
- * we create a copy to modify: this is "copy on write".
+ * If the list object is unshared we can modify it directly, otherwise we
+ * create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
- isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
- listPtr = Tcl_DuplicateObj(listPtr);
- isDuplicate = 1;
+ listPtr = TclListObjCopy(NULL, listPtr);
}
- if (objc > 4) {
- result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
- (objc-4), &(objv[4]));
- } else {
- result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
- 0, NULL);
+
+ /*
+ * Note that we call Tcl_ListObjReplace even when numToDelete == 0 and
+ * objc == 4. In this case, the list value of listPtr is not changed (no
+ * elements are removed or added), but by making the call we are assured
+ * we end up with a list in canonical form. Resist any temptation to
+ * optimize this case away.
+ */
+
+ Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, &(objv[4]));
+
+ /*
+ * Set the interpreter's object result.
+ */
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LreverseObjCmd --
+ *
+ * This procedure is invoked to process the "lreverse" Tcl command. See
+ * the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LreverseObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
+{
+ Tcl_Obj **elemv;
+ int elemc, i, j;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list");
+ return TCL_ERROR;
}
- if (result != TCL_OK) {
- if (isDuplicate) {
- Tcl_DecrRefCount(listPtr); /* free unneeded obj */
- }
- return result;
+ if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) {
+ return TCL_ERROR;
}
/*
- * Set the interpreter's object result.
+ * If the list is empty, just return it [Bug 1876793]
*/
- Tcl_SetObjResult(interp, listPtr);
+ if (!elemc) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
+
+ if (Tcl_IsShared(objv[1])
+ || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */
+ Tcl_Obj *resultObj, **dataArray;
+ List *listRepPtr;
+
+ resultObj = Tcl_NewListObj(elemc, NULL);
+ listRepPtr = ListRepPtr(resultObj);
+ listRepPtr->elemCount = elemc;
+ dataArray = &listRepPtr->elements;
+
+ for (i=0,j=elemc-1 ; i<elemc ; i++,j--) {
+ dataArray[j] = elemv[i];
+ Tcl_IncrRefCount(elemv[i]);
+ }
+
+ Tcl_SetObjResult(interp, resultObj);
+ } else {
+
+ /*
+ * Not shared, so swap "in place". This relies on Tcl_LOGE above
+ * returning a pointer to the live array of Tcl_Obj values.
+ */
+
+ for (i=0,j=elemc-1 ; i<j ; i++,j--) {
+ Tcl_Obj *tmp = elemv[i];
+
+ elemv[i] = elemv[j];
+ elemv[j] = tmp;
+ }
+ TclInvalidateStringRep(objv[1]);
+ Tcl_SetObjResult(interp, objv[1]);
+ }
return TCL_OK;
}
@@ -3163,8 +2669,8 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
*
* Tcl_LsearchObjCmd --
*
- * This procedure is invoked to process the "lsearch" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "lsearch" Tcl command. See
+ * the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -3176,30 +2682,34 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
*/
int
-Tcl_LsearchObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument values. */
+Tcl_LsearchObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
{
char *bytes, *patternBytes;
int i, match, mode, index, result, listc, length, elemLen;
- int dataType, isIncreasing, lower, upper, patInt, objInt;
- int offset, allMatches, inlineReturn, negatedMatch;
+ int dataType, isIncreasing, lower, upper, patInt, objInt, offset;
+ int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
- Tcl_Obj *patObj, **listv, *listPtr, *startPtr;
+ SortInfo sortInfo;
+ Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
+ SortStrCmpFn_t strCmpFn = strcmp;
Tcl_RegExp regexp = NULL;
static CONST char *options[] = {
- "-all", "-ascii", "-decreasing", "-dictionary",
- "-exact", "-glob", "-increasing", "-inline",
- "-integer", "-not", "-real", "-regexp",
- "-sorted", "-start", NULL
+ "-all", "-ascii", "-decreasing", "-dictionary",
+ "-exact", "-glob", "-increasing", "-index",
+ "-inline", "-integer", "-nocase", "-not",
+ "-real", "-regexp", "-sorted", "-start",
+ "-subindices", NULL
};
enum options {
LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
- LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE,
- LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP,
- LSEARCH_SORTED, LSEARCH_START
+ LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX,
+ LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT,
+ LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START,
+ LSEARCH_SUBINDICES
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -3213,10 +2723,19 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
isIncreasing = 1;
allMatches = 0;
inlineReturn = 0;
+ returnSubindices = 0;
negatedMatch = 0;
listPtr = NULL;
startPtr = NULL;
offset = 0;
+ noCase = 0;
+ sortInfo.compareCmdPtr = NULL;
+ sortInfo.isIncreasing = 1;
+ sortInfo.sortMode = 0;
+ sortInfo.interp = interp;
+ sortInfo.resultCode = TCL_OK;
+ sortInfo.indexv = NULL;
+ sortInfo.indexc = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
@@ -3226,9 +2745,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
- if (startPtr) {
+ if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return TCL_ERROR;
}
switch ((enum options) index) {
@@ -3240,6 +2762,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
break;
case LSEARCH_DECREASING: /* -decreasing */
isIncreasing = 0;
+ sortInfo.isIncreasing = 0;
break;
case LSEARCH_DICTIONARY: /* -dictionary */
dataType = DICTIONARY;
@@ -3252,6 +2775,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
break;
case LSEARCH_INCREASING: /* -increasing */
isIncreasing = 1;
+ sortInfo.isIncreasing = 1;
break;
case LSEARCH_INLINE: /* -inline */
inlineReturn = 1;
@@ -3259,6 +2783,10 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
case LSEARCH_INTEGER: /* -integer */
dataType = INTEGER;
break;
+ case LSEARCH_NOCASE: /* -nocase */
+ strCmpFn = strcasecmp;
+ noCase = 1;
+ break;
case LSEARCH_NOT: /* -not */
negatedMatch = 1;
break;
@@ -3271,88 +2799,183 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
case LSEARCH_SORTED: /* -sorted */
mode = SORTED;
break;
+ case LSEARCH_SUBINDICES: /* -subindices */
+ returnSubindices = 1;
+ break;
case LSEARCH_START: /* -start */
/*
- * If there was a previous -start option, release its saved
- * index because it will either be replaced or there will be
- * an error.
+ * If there was a previous -start option, release its saved index
+ * because it will either be replaced or there will be an error.
*/
- if (startPtr) {
+
+ if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
if (i > objc-4) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
Tcl_AppendResult(interp, "missing starting index", NULL);
return TCL_ERROR;
}
i++;
if (objv[i] == objv[objc - 2]) {
/*
- * Take copy to prevent shimmering problems. Note
- * that it does not matter if the index obj is also a
- * component of the list being searched. We only need
- * to copy where the list and the index are
- * one-and-the-same.
+ * Take copy to prevent shimmering problems. Note that it does
+ * not matter if the index obj is also a component of the list
+ * being searched. We only need to copy where the list and the
+ * index are one-and-the-same.
*/
+
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
Tcl_IncrRefCount(startPtr);
}
+ break;
+ case LSEARCH_INDEX: { /* -index */
+ Tcl_Obj **indices;
+ int j;
+
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ if (i > objc-4) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ Tcl_AppendResult(interp,
+ "\"-index\" option must be followed by list index",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Store the extracted indices for processing by sublist
+ * extraction. Note that we don't do this using objects because
+ * that has shimmering problems.
+ */
+
+ i++;
+ if (TclListObjGetElements(interp, objv[i],
+ &sortInfo.indexc, &indices) != TCL_OK) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ return TCL_ERROR;
+ }
+ switch (sortInfo.indexc) {
+ case 0:
+ sortInfo.indexv = NULL;
+ break;
+ case 1:
+ sortInfo.indexv = &sortInfo.singleIndex;
+ break;
+ default:
+ sortInfo.indexv = (int *)
+ ckalloc(sizeof(int) * sortInfo.indexc);
+ }
+
+ /*
+ * Fill the array by parsing each index. We don't know whether
+ * their scale is sensible yet, but we at least perform the
+ * syntactic check here.
+ */
+
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
+ &sortInfo.indexv[j]) != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (-index option item number %d)", j));
+ return TCL_ERROR;
+ }
+ }
+ break;
+ }
+ }
+ }
+
+ /*
+ * Subindices only make sense if asked for with -index option set.
+ */
+
+ if (returnSubindices && sortInfo.indexc==0) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
}
+ Tcl_AppendResult(interp,
+ "-subindices cannot be used without -index option", NULL);
+ return TCL_ERROR;
}
if ((enum modes) mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
* regexp rep before the list rep. First time round, omit the interp
- * and hope that the compilation will succeed. If it fails, we'll
- * recompile in "expensive" mode with a place to put error messages.
+ * and hope that the compilation will succeed. If it fails, we'll
+ * recompile in "expensive" mode with a place to put error messages.
*/
regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1],
- TCL_REG_ADVANCED | TCL_REG_NOSUB);
+ TCL_REG_ADVANCED | TCL_REG_NOSUB |
+ (noCase ? TCL_REG_NOCASE : 0));
if (regexp == NULL) {
- /*
- * Failed to compile the RE. Try again without the TCL_REG_NOSUB
- * flag in case the RE had sub-expressions in it [Bug 1366683].
- * If this fails, an error message will be left in the
- * interpreter.
- */
-
- regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
- TCL_REG_ADVANCED);
+ /*
+ * Failed to compile the RE. Try again without the TCL_REG_NOSUB
+ * flag in case the RE had sub-expressions in it [Bug 1366683]. If
+ * this fails, an error message will be left in the interpreter.
+ */
+
+ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
+ TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0));
}
if (regexp == NULL) {
- if (startPtr) {
+ if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return TCL_ERROR;
}
}
/*
- * Make sure the list argument is a list object and get its length and
- * a pointer to its array of element pointers.
+ * Make sure the list argument is a list object and get its length and a
+ * pointer to its array of element pointers.
*/
- result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
+ result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
- if (startPtr) {
+ if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
/*
* Get the user-specified start offset.
*/
+
if (startPtr) {
- result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
+ result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
+ if (offset < 0) {
+ offset = 0;
+ }
/*
* If the search started past the end of the list, we just return a
@@ -3360,6 +2983,9 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
*/
if (offset > listc-1) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
@@ -3367,9 +2993,6 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
}
return TCL_OK;
}
- if (offset < 0) {
- offset = 0;
- }
}
patObj = objv[objc - 1];
@@ -3378,59 +3001,91 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
switch ((enum datatypes) dataType) {
case ASCII:
case DICTIONARY:
- patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ patternBytes = TclGetStringFromObj(patObj, &length);
break;
case INTEGER:
- result = Tcl_GetIntFromObj(interp, patObj, &patInt);
+ result = TclGetIntFromObj(interp, patObj, &patInt);
if (result != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
- Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+
+ /*
+ * List representation might have been shimmered; restore it. [Bug
+ * 1844789]
+ */
+
+ TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
- Tcl_ListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+
+ /*
+ * List representation might have been shimmered; restore it. [Bug
+ * 1844789]
+ */
+
+ TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
- patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ patternBytes = TclGetStringFromObj(patObj, &length);
}
/*
- * Set default index value to -1, indicating failure; if we find the
- * item in the course of our search, index will be set to the correct
- * value.
+ * Set default index value to -1, indicating failure; if we find the item
+ * in the course of our search, index will be set to the correct value.
*/
+
index = -1;
match = 0;
if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
/*
- * If the data is sorted, we can do a more intelligent search.
- * Note that there is no point in being smart when -all was
- * specified; in that case, we have to look at all items anyway,
- * and there is no sense in doing this when the match sense is
- * inverted.
+ * If the data is sorted, we can do a more intelligent search. Note
+ * that there is no point in being smart when -all was specified; in
+ * that case, we have to look at all items anyway, and there is no
+ * sense in doing this when the match sense is inverted.
*/
+
lower = offset - 1;
upper = listc;
- while (lower + 1 != upper) {
+ while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
+ if (sortInfo.indexc != 0) {
+ itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ if (sortInfo.resultCode != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ return sortInfo.resultCode;
+ }
+ } else {
+ itemPtr = listv[i];
+ }
switch ((enum datatypes) dataType) {
case ASCII:
- bytes = Tcl_GetString(listv[i]);
- match = strcmp(patternBytes, bytes);
+ bytes = TclGetString(itemPtr);
+ match = strCmpFn(patternBytes, bytes);
break;
case DICTIONARY:
- bytes = Tcl_GetString(listv[i]);
+ bytes = TclGetString(itemPtr);
match = DictionaryCompare(patternBytes, bytes);
break;
case INTEGER:
- result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
+ result = TclGetIntFromObj(interp, itemPtr, &objInt);
if (result != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
if (patInt == objInt) {
@@ -3442,8 +3097,11 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
}
break;
case REAL:
- result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble);
+ result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble);
if (result != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
if (patDouble == objDouble) {
@@ -3457,17 +3115,19 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
}
if (match == 0) {
/*
- * Normally, binary search is written to stop when it
- * finds a match. If there are duplicates of an element in
- * the list, our first match might not be the first occurance.
- * Consider: 0 0 0 1 1 1 2 2 2
- * To maintain consistancy with standard lsearch semantics,
- * we must find the leftmost occurance of the pattern in the
- * list. Thus we don't just stop searching here. This
+ * Normally, binary search is written to stop when it finds a
+ * match. If there are duplicates of an element in the list,
+ * our first match might not be the first occurance.
+ * Consider: 0 0 0 1 1 1 2 2 2
+ *
+ * To maintain consistancy with standard lsearch semantics, we
+ * must find the leftmost occurance of the pattern in the
+ * list. Thus we don't just stop searching here. This
* variation means that a search always makes log n
- * comparisons (normal binary search might "get lucky" with
- * an early comparison).
+ * comparisons (normal binary search might "get lucky" with an
+ * early comparison).
*/
+
index = i;
upper = i;
} else if (match > 0) {
@@ -3492,83 +3152,138 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
* - our matching sense is negated
* - we're building a list of all matched items
*/
+
if (allMatches) {
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ listPtr = Tcl_NewListObj(0, NULL);
}
for (i = offset; i < listc; i++) {
match = 0;
+ if (sortInfo.indexc != 0) {
+ itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ if (sortInfo.resultCode != TCL_OK) {
+ if (listPtr != NULL) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ return sortInfo.resultCode;
+ }
+ } else {
+ itemPtr = listv[i];
+ }
+
switch ((enum modes) mode) {
case SORTED:
case EXACT:
switch ((enum datatypes) dataType) {
case ASCII:
- bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
+ bytes = TclGetStringFromObj(itemPtr, &elemLen);
if (length == elemLen) {
- match = (memcmp(bytes, patternBytes,
- (size_t) length) == 0);
+ /*
+ * This split allows for more optimal compilation of
+ * memcmp/strcasecmp.
+ */
+
+ if (noCase) {
+ match = (strcasecmp(bytes, patternBytes) == 0);
+ } else {
+ match = (memcmp(bytes, patternBytes,
+ (size_t) length) == 0);
+ }
}
break;
+
case DICTIONARY:
- bytes = Tcl_GetString(listv[i]);
+ bytes = TclGetString(itemPtr);
match = (DictionaryCompare(bytes, patternBytes) == 0);
break;
+
case INTEGER:
- result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
+ result = TclGetIntFromObj(interp, itemPtr, &objInt);
if (result != TCL_OK) {
- if (listPtr) {
+ if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
match = (objInt == patInt);
break;
+
case REAL:
- result = Tcl_GetDoubleFromObj(interp, listv[i],
- &objDouble);
+ result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble);
if (result != TCL_OK) {
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return result;
}
match = (objDouble == patDouble);
break;
}
break;
+
case GLOB:
- match = Tcl_StringMatch(Tcl_GetString(listv[i]),
- patternBytes);
+ match = Tcl_StringCaseMatch(TclGetString(itemPtr),
+ patternBytes, noCase);
break;
+
case REGEXP:
- match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0);
+ match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0);
if (match < 0) {
Tcl_DecrRefCount(patObj);
- if (listPtr) {
+ if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return TCL_ERROR;
}
break;
}
+
/*
- * Invert match condition for -not
+ * Invert match condition for -not.
*/
+
if (negatedMatch) {
match = !match;
}
- if (match != 0) {
- if (!allMatches) {
- index = i;
- break;
- } else if (inlineReturn) {
- /*
- * Note that these appends are not expected to fail.
- */
- Tcl_ListObjAppendElement(interp, listPtr, listv[i]);
+ if (!match) {
+ continue;
+ }
+ if (!allMatches) {
+ index = i;
+ break;
+ } else if (inlineReturn) {
+ /*
+ * Note that these appends are not expected to fail.
+ */
+
+ if (returnSubindices && (sortInfo.indexc != 0)) {
+ itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
} else {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewIntObj(i));
+ itemPtr = listv[i];
+ }
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ } else if (returnSubindices) {
+ int j;
+
+ itemPtr = Tcl_NewIntObj(i);
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ Tcl_ListObjAppendElement(interp, itemPtr,
+ Tcl_NewIntObj(sortInfo.indexv[j]));
}
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ } else {
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i));
}
}
}
@@ -3576,19 +3291,40 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
/*
* Return everything or a single value.
*/
+
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+ if (returnSubindices) {
+ int j;
+
+ itemPtr = Tcl_NewIntObj(index);
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ Tcl_ListObjAppendElement(interp, itemPtr,
+ Tcl_NewIntObj(sortInfo.indexv[j]));
+ }
+ Tcl_SetObjResult(interp, itemPtr);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
+ }
} else if (index < 0) {
/*
- * Is this superfluous? The result should be a blank object
- * by default...
+ * Is this superfluous? The result should be a blank object by
+ * default...
*/
+
Tcl_SetObjResult(interp, Tcl_NewObj());
} else {
Tcl_SetObjResult(interp, listv[index]);
}
+
+ /*
+ * Cleanup the index list array.
+ */
+
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return TCL_OK;
}
@@ -3597,8 +3333,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
*
* Tcl_LsetObjCmd --
*
- * This procedure is invoked to process the "lset" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "lset" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -3610,66 +3346,71 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
*/
int
-Tcl_LsetObjCmd( clientData, interp, objc, objv )
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument values. */
+Tcl_LsetObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
{
+ Tcl_Obj *listPtr; /* Pointer to the list being altered. */
+ Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
- Tcl_Obj* listPtr; /* Pointer to the list being altered. */
- Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */
-
- /* Check parameter count */
+ /*
+ * Check parameter count.
+ */
- if ( objc < 3 ) {
- Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "listVar ?index? ?index...? value");
return TCL_ERROR;
}
- /* Look up the list variable's value */
+ /*
+ * Look up the list variable's value.
+ */
- listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
- TCL_LEAVE_ERR_MSG );
- if ( listPtr == NULL ) {
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
return TCL_ERROR;
}
- /*
- * Substitute the value in the value. Return either the value or
- * else an unshared copy of it.
+ /*
+ * Substitute the value in the value. Return either the value or else an
+ * unshared copy of it.
*/
- if ( objc == 4 ) {
- finalValuePtr = TclLsetList( interp, listPtr,
- objv[ 2 ], objv[ 3 ] );
+ if (objc == 4) {
+ finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);
} else {
- finalValuePtr = TclLsetFlat( interp, listPtr,
- objc-3, objv+2, objv[ objc-1 ] );
+ finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2,
+ objv[objc-1]);
}
/*
* If substitution has failed, bail out.
*/
- if ( finalValuePtr == NULL ) {
+ if (finalValuePtr == NULL) {
return TCL_ERROR;
}
- /* Finally, update the variable so that traces fire. */
+ /*
+ * Finally, update the variable so that traces fire.
+ */
- listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
- TCL_LEAVE_ERR_MSG );
- Tcl_DecrRefCount( finalValuePtr );
- if ( listPtr == NULL ) {
+ listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr,
+ TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(finalValuePtr);
+ if (listPtr == NULL) {
return TCL_ERROR;
}
- /* Return the new value of the variable as the interpreter result. */
+ /*
+ * Return the new value of the variable as the interpreter result.
+ */
- Tcl_SetObjResult( interp, listPtr );
+ Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
-
}
/*
@@ -3677,8 +3418,8 @@ Tcl_LsetObjCmd( clientData, interp, objc, objv )
*
* Tcl_LsortObjCmd --
*
- * This procedure is invoked to process the "lsort" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "lsort" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -3690,27 +3431,34 @@ Tcl_LsetObjCmd( clientData, interp, objc, objv )
*/
int
-Tcl_LsortObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument values. */
+Tcl_LsortObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
{
- int i, index, unique;
- Tcl_Obj *resultPtr;
- int length;
- Tcl_Obj *cmdPtr, **listObjPtrs;
- SortElement *elementArray;
- SortElement *elementPtr;
- SortInfo sortInfo; /* Information about this sort that
- * needs to be passed to the
- * comparison function */
+ int i, j, index, indices, length, nocase = 0, sortMode, indexc;
+ Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
+ SortElement *elementArray, *elementPtr;
+ SortInfo sortInfo; /* Information about this sort that needs to
+ * be passed to the comparison function. */
static CONST char *switches[] = {
"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
- "-index", "-integer", "-real", "-unique", (char *) NULL
+ "-index", "-indices", "-integer", "-nocase", "-real", "-unique", NULL
+ };
+ enum Lsort_Switches {
+ LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY,
+ LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER,
+ LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE
};
- resultPtr = Tcl_GetObjResult(interp);
+ /*
+ * The subList array below holds pointers to temporary lists built during
+ * the merge sort. Element i of the array holds a list of length 2**i.
+ */
+# define NUM_LISTS 30
+ SortElement *subList[NUM_LISTS+1];
+
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
return TCL_ERROR;
@@ -3722,199 +3470,312 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
sortInfo.isIncreasing = 1;
sortInfo.sortMode = SORTMODE_ASCII;
- sortInfo.index = SORTIDX_NONE;
+ sortInfo.indexv = NULL;
+ sortInfo.indexc = 0;
+ sortInfo.unique = 0;
sortInfo.interp = interp;
- sortInfo.resultCode = TCL_OK;
+ sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
- unique = 0;
+ indices = 0;
for (i = 1; i < objc-1; i++) {
- if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
- != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0,
+ &index) != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return TCL_ERROR;
}
- switch (index) {
- case 0: /* -ascii */
- sortInfo.sortMode = SORTMODE_ASCII;
- break;
- case 1: /* -command */
- if (i == (objc-2)) {
- Tcl_AppendToObj(resultPtr,
- "\"-command\" option must be followed by comparison command",
- -1);
- return TCL_ERROR;
+ switch ((enum Lsort_Switches) index) {
+ case LSORT_ASCII:
+ sortInfo.sortMode = SORTMODE_ASCII;
+ break;
+ case LSORT_COMMAND:
+ if (i == (objc-2)) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
}
- sortInfo.sortMode = SORTMODE_COMMAND;
- cmdPtr = objv[i+1];
- i++;
- break;
- case 2: /* -decreasing */
- sortInfo.isIncreasing = 0;
- break;
- case 3: /* -dictionary */
- sortInfo.sortMode = SORTMODE_DICTIONARY;
+ Tcl_AppendResult(interp,
+ "\"-command\" option must be followed "
+ "by comparison command", NULL);
+ return TCL_ERROR;
+ }
+ sortInfo.sortMode = SORTMODE_COMMAND;
+ cmdPtr = objv[i+1];
+ i++;
+ break;
+ case LSORT_DECREASING:
+ sortInfo.isIncreasing = 0;
+ break;
+ case LSORT_DICTIONARY:
+ sortInfo.sortMode = SORTMODE_DICTIONARY;
+ break;
+ case LSORT_INCREASING:
+ sortInfo.isIncreasing = 1;
+ break;
+ case LSORT_INDEX: {
+ Tcl_Obj **indices;
+
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ if (i == (objc-2)) {
+ Tcl_AppendResult(interp, "\"-index\" option must be "
+ "followed by list index", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Take copy to prevent shimmering problems.
+ */
+
+ if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc,
+ &indices) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (sortInfo.indexc) {
+ case 0:
+ sortInfo.indexv = NULL;
break;
- case 4: /* -increasing */
- sortInfo.isIncreasing = 1;
+ case 1:
+ sortInfo.indexv = &sortInfo.singleIndex;
break;
- case 5: /* -index */
- if (i == (objc-2)) {
- Tcl_AppendToObj(resultPtr,
- "\"-index\" option must be followed by list index",
- -1);
- return TCL_ERROR;
- }
- if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END,
- &sortInfo.index) != TCL_OK) {
+ default:
+ sortInfo.indexv = (int *)
+ ckalloc(sizeof(int) * sortInfo.indexc);
+ }
+
+ /*
+ * Fill the array by parsing each index. We don't know whether
+ * their scale is sensible yet, but we at least perform the
+ * syntactic check here.
+ */
+
+ for (j=0 ; j<sortInfo.indexc ; j++) {
+ if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
+ &sortInfo.indexv[j]) != TCL_OK) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (-index option item number %d)", j));
return TCL_ERROR;
}
- i++;
- break;
- case 6: /* -integer */
- sortInfo.sortMode = SORTMODE_INTEGER;
- break;
- case 7: /* -real */
- sortInfo.sortMode = SORTMODE_REAL;
- break;
- case 8: /* -unique */
- unique = 1;
- break;
+ }
+ i++;
+ break;
}
+ case LSORT_INTEGER:
+ sortInfo.sortMode = SORTMODE_INTEGER;
+ break;
+ case LSORT_NOCASE:
+ nocase = 1;
+ break;
+ case LSORT_REAL:
+ sortInfo.sortMode = SORTMODE_REAL;
+ break;
+ case LSORT_UNIQUE:
+ sortInfo.unique = 1;
+ break;
+ case LSORT_INDICES:
+ indices = 1;
+ break;
+ }
+ }
+ if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) {
+ sortInfo.sortMode = SORTMODE_ASCII_NC;
}
+
+ listObj = objv[objc-1];
+
if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ Tcl_Obj *newCommandPtr, *newObjPtr;
+
/*
- * The existing command is a list. We want to flatten it, append
- * two dummy arguments on the end, and replace these arguments
- * later.
+ * When sorting using a command, we are reentrant and therefore might
+ * have the representation of the list being sorted shimmered out from
+ * underneath our feet. Take a copy (cheap) to prevent this. [Bug
+ * 1675116]
*/
- Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
- Tcl_Obj *newObjPtr = Tcl_NewObj();
+ listObj = TclListObjCopy(interp, listObj);
+ if (listObj == NULL) {
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * The existing command is a list. We want to flatten it, append two
+ * dummy arguments on the end, and replace these arguments later.
+ */
+ newCommandPtr = Tcl_DuplicateObj(cmdPtr);
+ TclNewObj(newObjPtr);
Tcl_IncrRefCount(newCommandPtr);
if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)
!= TCL_OK) {
- Tcl_DecrRefCount(newCommandPtr);
+ TclDecrRefCount(newCommandPtr);
+ TclDecrRefCount(listObj);
Tcl_IncrRefCount(newObjPtr);
- Tcl_DecrRefCount(newObjPtr);
+ TclDecrRefCount(newObjPtr);
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
+ }
return TCL_ERROR;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
- sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
+ sortInfo.resultCode = TclListObjGetElements(interp, listObj,
&length, &listObjPtrs);
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
- elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
- for (i=0; i < length; i++){
- elementArray[i].objPtr = listObjPtrs[i];
- elementArray[i].count = 0;
- elementArray[i].nextPtr = &elementArray[i+1];
-
+ sortInfo.numElements = length;
+
+ indexc = sortInfo.indexc;
+ sortMode = sortInfo.sortMode;
+ if ((sortMode == SORTMODE_ASCII_NC)
+ || (sortMode == SORTMODE_DICTIONARY)) {
/*
- * When sorting using a command, we are reentrant and therefore might
- * have the representation of the list being sorted shimmered out from
- * underneath our feet. Increment the reference counts of the elements
- * to sort to prevent this. [Bug 1675116]
+ * For this function's purpose all string-based modes are equivalent
*/
+
+ sortMode = SORTMODE_ASCII;
+ }
- Tcl_IncrRefCount(elementArray[i].objPtr);
+ /*
+ * Initialize the sublists. After the following loop, subList[i] will
+ * contain a sorted sublist of length 2**i. Use one extra subList at the
+ * end, always at NULL, to indicate the end of the lists.
+ */
+
+ for (j=0 ; j<=NUM_LISTS ; j++) {
+ subList[j] = NULL;
}
- elementArray[length-1].nextPtr = NULL;
- elementPtr = MergeSort(elementArray, &sortInfo);
- if (sortInfo.resultCode == TCL_OK) {
- /*
- * Note: must clear the interpreter's result object: it could
- * have been set by the -command script.
- */
- Tcl_ResetResult(interp);
- resultPtr = Tcl_GetObjResult(interp);
- if (unique) {
- for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
- if (elementPtr->count == 0) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- elementPtr->objPtr);
- }
+ /*
+ * The following loop creates a SortElement for each list element and
+ * begins sorting it into the sublists as it appears.
+ */
+
+ elementArray = (SortElement *) ckalloc( length * sizeof(SortElement));
+
+ for (i=0; i < length; i++){
+ if (indexc) {
+ /*
+ * If this is an indexed sort, retrieve the corresponding element
+ */
+ indexPtr = SelectObjFromSublist(listObjPtrs[i], &sortInfo);
+ if (sortInfo.resultCode != TCL_OK) {
+ goto done1;
}
} else {
- for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
- Tcl_ListObjAppendElement(interp, resultPtr,
- elementPtr->objPtr);
+ indexPtr = listObjPtrs[i];
+ }
+
+ /*
+ * Determine the "value" of this object for sorting purposes
+ */
+
+ if (sortMode == SORTMODE_ASCII) {
+ elementArray[i].index.strValuePtr = TclGetString(indexPtr);
+ } else if (sortMode == SORTMODE_INTEGER) {
+ long a;
+ if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
+ sortInfo.resultCode = TCL_ERROR;
+ goto done1;
+ }
+ elementArray[i].index.intValue = a;
+ } else if (sortInfo.sortMode == SORTMODE_REAL) {
+ double a;
+ if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) {
+ sortInfo.resultCode = TCL_ERROR;
+ goto done1;
}
+ elementArray[i].index.doubleValue = a;
+ } else {
+ elementArray[i].index.objValuePtr = indexPtr;
}
- }
- for (i=0; i<length; i++) {
- Tcl_DecrRefCount(elementArray[i].objPtr);
- }
- ckfree((char*) elementArray);
- done:
- if (sortInfo.sortMode == SORTMODE_COMMAND) {
- Tcl_DecrRefCount(sortInfo.compareCmdPtr);
- sortInfo.compareCmdPtr = NULL;
+ /*
+ * Determine the representation of this element in the result: either
+ * the objPtr itself, or its index in the original list.
+ */
+
+ elementArray[i].objPtr = (indices ? INT2PTR(i) : listObjPtrs[i]);
+
+ /*
+ * Merge this element in the pre-existing sublists (and merge together
+ * sublists when we have two of the same size).
+ */
+
+ elementArray[i].nextPtr = NULL;
+ elementPtr = &elementArray[i];
+ for (j=0 ; subList[j] ; j++) {
+ elementPtr = MergeLists(subList[j], elementPtr, &sortInfo);
+ subList[j] = NULL;
+ }
+ if (j >= NUM_LISTS) {
+ j = NUM_LISTS-1;
+ }
+ subList[j] = elementPtr;
}
- return sortInfo.resultCode;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MergeSort -
- *
- * This procedure sorts a linked list of SortElement structures
- * use the merge-sort algorithm.
- *
- * Results:
- * A pointer to the head of the list after sorting is returned.
- *
- * Side effects:
- * None, unless a user-defined comparison command does something
- * weird.
- *
- *----------------------------------------------------------------------
- */
-static SortElement *
-MergeSort(headPtr, infoPtr)
- SortElement *headPtr; /* First element on the list */
- SortInfo *infoPtr; /* Information needed by the
- * comparison operator */
-{
/*
- * The subList array below holds pointers to temporary lists built
- * during the merge sort. Element i of the array holds a list of
- * length 2**i.
+ * Merge all sublists
*/
+
+ elementPtr = subList[0];
+ for (j=1 ; j<NUM_LISTS ; j++) {
+ elementPtr = MergeLists(subList[j], elementPtr, &sortInfo);
+ }
-# define NUM_LISTS 30
- SortElement *subList[NUM_LISTS];
- SortElement *elementPtr;
- int i;
- for(i = 0; i < NUM_LISTS; i++){
- subList[i] = NULL;
- }
- while (headPtr != NULL) {
- elementPtr = headPtr;
- headPtr = headPtr->nextPtr;
- elementPtr->nextPtr = 0;
- for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
- elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
- subList[i] = NULL;
- }
- if (i >= NUM_LISTS) {
- i = NUM_LISTS-1;
+ /*
+ * Now store the sorted elements in the result list.
+ */
+
+ if (sortInfo.resultCode == TCL_OK) {
+ List *listRepPtr;
+ Tcl_Obj **newArray, *objPtr;
+ int i;
+
+ resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL);
+ listRepPtr = ListRepPtr(resultPtr);
+ newArray = &listRepPtr->elements;
+ if (indices) {
+ for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){
+ objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr));
+ newArray[i++] = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ }
+ } else {
+ for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){
+ objPtr = elementPtr->objPtr;
+ newArray[i++] = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ }
}
- subList[i] = elementPtr;
+ listRepPtr->elemCount = i;
+ Tcl_SetObjResult(interp, resultPtr);
}
- elementPtr = NULL;
- for (i = 0; i < NUM_LISTS; i++){
- elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
+
+ done1:
+ ckfree((char *)elementArray);
+
+ done:
+ if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ TclDecrRefCount(sortInfo.compareCmdPtr);
+ TclDecrRefCount(listObj);
+ sortInfo.compareCmdPtr = NULL;
+ }
+ if (sortInfo.indexc > 1) {
+ ckfree((char *) sortInfo.indexv);
}
- return elementPtr;
+ return sortInfo.resultCode;
}
/*
@@ -3926,65 +3787,91 @@ MergeSort(headPtr, infoPtr)
* into a single sorted list.
*
* Results:
- * The unified list of SortElement structures.
+ * The unified list of SortElement structures.
*
* Side effects:
- * None, unless a user-defined comparison command does something
- * weird.
- *
+ * If infoPtr->unique is set then infoPtr->numElements may be updated.
+ * Possibly others, if a user-defined comparison command does something
+ * weird.
+ *
+ * Note:
+ * If infoPtr->unique is set, the merge assumes that there are no
+ * "repeated" elements in each of the left and right lists. In that case,
+ * if any element of the left list is equivalent to one in the right list
+ * it is omitted from the merged list.
+ * This simplified mechanism works because of the special way
+ * our MergeSort creates the sublists to be merged and will fail to
+ * eliminate all repeats in the general case where they are already
+ * present in either the left or right list. A general code would need to
+ * skip adjacent initial repeats in the left and right lists before
+ * comparing their initial elements, at each step.
*----------------------------------------------------------------------
*/
static SortElement *
-MergeLists(leftPtr, rightPtr, infoPtr)
- SortElement *leftPtr; /* First list to be merged; may be
- * NULL. */
- SortElement *rightPtr; /* Second list to be merged; may be
- * NULL. */
- SortInfo *infoPtr; /* Information needed by the
- * comparison operator. */
+MergeLists(
+ SortElement *leftPtr, /* First list to be merged; may be NULL. */
+ SortElement *rightPtr, /* Second list to be merged; may be NULL. */
+ SortInfo *infoPtr) /* Information needed by the comparison
+ * operator. */
{
- SortElement *headPtr;
- SortElement *tailPtr;
+ SortElement *headPtr, *tailPtr;
int cmp;
if (leftPtr == NULL) {
- return rightPtr;
+ return rightPtr;
}
if (rightPtr == NULL) {
- return leftPtr;
+ return leftPtr;
}
- cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
- if (cmp > 0) {
+ cmp = SortCompare(leftPtr, rightPtr, infoPtr);
+ if (cmp > 0 || (cmp == 0 && infoPtr->unique)) {
+ if (cmp == 0) {
+ infoPtr->numElements--;
+ leftPtr = leftPtr->nextPtr;
+ }
tailPtr = rightPtr;
rightPtr = rightPtr->nextPtr;
} else {
- if (cmp == 0) {
- leftPtr->count++;
- }
tailPtr = leftPtr;
leftPtr = leftPtr->nextPtr;
}
headPtr = tailPtr;
- while ((leftPtr != NULL) && (rightPtr != NULL)) {
- cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
- if (cmp > 0) {
- tailPtr->nextPtr = rightPtr;
- tailPtr = rightPtr;
- rightPtr = rightPtr->nextPtr;
- } else {
- if (cmp == 0) {
- leftPtr->count++;
+ if (!infoPtr->unique) {
+ while ((leftPtr != NULL) && (rightPtr != NULL)) {
+ cmp = SortCompare(leftPtr, rightPtr, infoPtr);
+ if (cmp > 0) {
+ tailPtr->nextPtr = rightPtr;
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr->nextPtr = leftPtr;
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
+ }
+ }
+ } else {
+ while ((leftPtr != NULL) && (rightPtr != NULL)) {
+ cmp = SortCompare(leftPtr, rightPtr, infoPtr);
+ if (cmp >= 0) {
+ if (cmp == 0) {
+ infoPtr->numElements--;
+ leftPtr = leftPtr->nextPtr;
+ }
+ tailPtr->nextPtr = rightPtr;
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr->nextPtr = leftPtr;
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
}
- tailPtr->nextPtr = leftPtr;
- tailPtr = leftPtr;
- leftPtr = leftPtr->nextPtr;
}
}
if (leftPtr != NULL) {
- tailPtr->nextPtr = leftPtr;
+ tailPtr->nextPtr = leftPtr;
} else {
- tailPtr->nextPtr = rightPtr;
+ tailPtr->nextPtr = rightPtr;
}
return headPtr;
}
@@ -3998,163 +3885,98 @@ MergeLists(leftPtr, rightPtr, infoPtr)
* ordering between two elements.
*
* Results:
- * A negative results means the the first element comes before the
- * second, and a positive results means that the second element
- * should come first. A result of zero means the two elements
- * are equal and it doesn't matter which comes first.
+ * A negative results means the the first element comes before the
+ * second, and a positive results means that the second element should
+ * come first. A result of zero means the two elements are equal and it
+ * doesn't matter which comes first.
*
* Side effects:
- * None, unless a user-defined comparison command does something
- * weird.
+ * None, unless a user-defined comparison command does something weird.
*
*----------------------------------------------------------------------
*/
static int
-SortCompare(objPtr1, objPtr2, infoPtr)
- Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
- SortInfo *infoPtr; /* Information passed from the
- * top-level "lsort" command */
+SortCompare(
+ SortElement *elemPtr1, SortElement *elemPtr2,
+ /* Values to be compared. */
+ SortInfo *infoPtr) /* Information passed from the top-level
+ * "lsort" command. */
{
- int order, listLen, index;
- Tcl_Obj *objPtr;
- char buffer[TCL_INTEGER_SPACE];
-
- order = 0;
- if (infoPtr->resultCode != TCL_OK) {
- /*
- * Once an error has occurred, skip any future comparisons
- * so as to preserve the error message in sortInterp->result.
- */
-
- return order;
- }
- if (infoPtr->index != SORTIDX_NONE) {
- /*
- * The "-index" option was specified. Treat each object as a
- * list, extract the requested element from each list, and
- * compare the elements, not the lists. "end"-relative indices
- * are signaled here with large negative values.
- */
-
- if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- if (infoPtr->index < SORTIDX_NONE) {
- index = listLen + infoPtr->index + 1;
- } else {
- index = infoPtr->index;
- }
+ int order = 0;
- if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
- != TCL_OK) {
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- if (objPtr == NULL) {
- objPtr = objPtr1;
- missingElement:
- TclFormatInt(buffer, infoPtr->index);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
- "element ", buffer, " missing from sublist \"",
- Tcl_GetString(objPtr), "\"", (char *) NULL);
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- objPtr1 = objPtr;
-
- if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- if (infoPtr->index < SORTIDX_NONE) {
- index = listLen + infoPtr->index + 1;
- } else {
- index = infoPtr->index;
- }
-
- if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
- != TCL_OK) {
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- if (objPtr == NULL) {
- objPtr = objPtr2;
- goto missingElement;
- }
- objPtr2 = objPtr;
- }
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
+ order = strcmp(elemPtr1->index.strValuePtr,
+ elemPtr2->index.strValuePtr);
+ } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
+ order = strcasecmp(elemPtr1->index.strValuePtr,
+ elemPtr2->index.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
- order = DictionaryCompare(
- Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
+ order = DictionaryCompare(elemPtr1->index.strValuePtr,
+ elemPtr2->index.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
long a, b;
- if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
- || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
- != TCL_OK)) {
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- if (a > b) {
- order = 1;
- } else if (b > a) {
- order = -1;
- }
+ a = elemPtr1->index.intValue;
+ b = elemPtr2->index.intValue;
+ order = ((a >= b) - (a <= b));
} else if (infoPtr->sortMode == SORTMODE_REAL) {
double a, b;
- if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
- || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
- != TCL_OK)) {
- infoPtr->resultCode = TCL_ERROR;
- return order;
- }
- if (a > b) {
- order = 1;
- } else if (b > a) {
- order = -1;
- }
+ a = elemPtr1->index.doubleValue;
+ b = elemPtr2->index.doubleValue;
+ order = ((a >= b) - (a <= b));
} else {
Tcl_Obj **objv, *paramObjv[2];
int objc;
+ Tcl_Obj *objPtr1, *objPtr2;
+
+ if (infoPtr->resultCode != TCL_OK) {
+ /*
+ * Once an error has occurred, skip any future comparisons so as
+ * to preserve the error message in sortInterp->result.
+ */
+
+ return 0;
+ }
+
+ objPtr1 = elemPtr1->index.objValuePtr;
+ objPtr2 = elemPtr2->index.objValuePtr;
+
paramObjv[0] = objPtr1;
paramObjv[1] = objPtr2;
- /*
- * We made space in the command list for the two things to
- * compare. Replace them and evaluate the result.
+ /*
+ * We made space in the command list for the two things to compare.
+ * Replace them and evaluate the result.
*/
- Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
+ TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
- Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
+ TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
-
- if (infoPtr->resultCode != TCL_OK) {
+
+ if (infoPtr->resultCode != TCL_OK) {
Tcl_AddErrorInfo(infoPtr->interp,
"\n (-compare command)");
- return order;
+ return 0;
}
/*
* Parse the result of the command.
*/
- if (Tcl_GetIntFromObj(infoPtr->interp,
+ if (TclGetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_ResetResult(infoPtr->interp);
- Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
- "-compare command returned non-integer result", -1);
+ Tcl_AppendResult(infoPtr->interp,
+ "-compare command returned non-integer result", NULL);
infoPtr->resultCode = TCL_ERROR;
- return order;
+ return 0;
}
}
if (!infoPtr->isIncreasing) {
@@ -4168,18 +3990,18 @@ SortCompare(objPtr1, objPtr2, infoPtr)
*
* DictionaryCompare
*
- * This function compares two strings as if they were being used in
- * an index or card catalog. The case of alphabetic characters is
- * ignored, except to break ties. Thus "B" comes before "b" but
- * after "a". Also, integers embedded in the strings compare in
- * numerical order. In other words, "x10y" comes after "x9y", not
- * before it as it would when using strcmp().
+ * This function compares two strings as if they were being used in an
+ * index or card catalog. The case of alphabetic characters is ignored,
+ * except to break ties. Thus "B" comes before "b" but after "a". Also,
+ * integers embedded in the strings compare in numerical order. In other
+ * words, "x10y" comes after "x9y", not * before it as it would when
+ * using strcmp().
*
* Results:
- * A negative result means that the first element comes before the
- * second, and a positive result means that the second element
- * should come first. A result of zero means the two elements
- * are equal and it doesn't matter which comes first.
+ * A negative result means that the first element comes before the
+ * second, and a positive result means that the second element should
+ * come first. A result of zero means the two elements are equal and it
+ * doesn't matter which comes first.
*
* Side effects:
* None.
@@ -4188,22 +4010,21 @@ SortCompare(objPtr1, objPtr2, infoPtr)
*/
static int
-DictionaryCompare(left, right)
- char *left, *right; /* The strings to compare */
+DictionaryCompare(
+ char *left, char *right) /* The strings to compare. */
{
Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
- if (isdigit(UCHAR(*right)) /* INTL: digit */
- && isdigit(UCHAR(*left))) { /* INTL: digit */
+ if (isdigit(UCHAR(*right)) /* INTL: digit */
+ && isdigit(UCHAR(*left))) { /* INTL: digit */
/*
- * There are decimal numbers embedded in the two
- * strings. Compare them as numbers, rather than
- * strings. If one number has more leading zeros than
- * the other, the number with more leading zeros sorts
- * later, but only as a secondary choice.
+ * There are decimal numbers embedded in the two strings. Compare
+ * them as numbers, rather than strings. If one number has more
+ * leading zeros than the other, the number with more leading
+ * zeros sorts later, but only as a secondary choice.
*/
zeros = 0;
@@ -4220,10 +4041,10 @@ DictionaryCompare(left, right)
}
/*
- * The code below compares the numbers in the two
- * strings without ever converting them to integers. It
- * does this by first comparing the lengths of the
- * numbers and then comparing the digit values.
+ * The code below compares the numbers in the two strings without
+ * ever converting them to integers. It does this by first
+ * comparing the lengths of the numbers and then comparing the
+ * digit values.
*/
diff = 0;
@@ -4233,13 +4054,13 @@ DictionaryCompare(left, right)
}
right++;
left++;
- if (!isdigit(UCHAR(*right))) { /* INTL: digit */
- if (isdigit(UCHAR(*left))) { /* INTL: digit */
+ if (!isdigit(UCHAR(*right))) { /* INTL: digit */
+ if (isdigit(UCHAR(*left))) { /* INTL: digit */
return 1;
} else {
/*
- * The two numbers have the same length. See
- * if their values are different.
+ * The two numbers have the same length. See if their
+ * values are different.
*/
if (diff != 0) {
@@ -4247,7 +4068,7 @@ DictionaryCompare(left, right)
}
break;
}
- } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */
+ } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */
return -1;
}
}
@@ -4255,7 +4076,7 @@ DictionaryCompare(left, right)
}
/*
- * Convert character to Unicode for comparison purposes. If either
+ * Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
@@ -4263,12 +4084,14 @@ DictionaryCompare(left, right)
if ((*left != '\0') && (*right != '\0')) {
left += Tcl_UtfToUniChar(left, &uniLeft);
right += Tcl_UtfToUniChar(right, &uniRight);
+
/*
* Convert both chars to lower for the comparison, because
- * dictionary sorts are case insensitve. Covert to lower, not
+ * dictionary sorts are case insensitve. Covert to lower, not
* upper, so chars between Z and a will sort before A (where most
- * other interesting punctuations occur)
+ * other interesting punctuations occur).
*/
+
uniLeftLower = Tcl_UniCharToLower(uniLeft);
uniRightLower = Tcl_UniCharToLower(uniRight);
} else {
@@ -4276,18 +4099,18 @@ DictionaryCompare(left, right)
break;
}
- diff = uniLeftLower - uniRightLower;
- if (diff) {
+ diff = uniLeftLower - uniRightLower;
+ if (diff) {
return diff;
- } else if (secondaryDiff == 0) {
- if (Tcl_UniCharIsUpper(uniLeft) &&
- Tcl_UniCharIsLower(uniRight)) {
+ }
+ if (secondaryDiff == 0) {
+ if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) {
secondaryDiff = -1;
} else if (Tcl_UniCharIsUpper(uniRight)
&& Tcl_UniCharIsLower(uniLeft)) {
secondaryDiff = 1;
}
- }
+ }
}
if (diff == 0) {
diff = secondaryDiff;
@@ -4296,10 +4119,90 @@ DictionaryCompare(left, right)
}
/*
+ *----------------------------------------------------------------------
+ *
+ * SelectObjFromSublist --
+ *
+ * This procedure is invoked from lsearch and SortCompare. It is used for
+ * implementing the -index option, for the lsort and lsearch commands.
+ *
+ * Results:
+ * Returns NULL if a failure occurs, and sets the result in the infoPtr.
+ * Otherwise returns the Tcl_Obj* to the item.
+ *
+ * Side effects:
+ * None.
+ *
+ * Note:
+ * No reference counting is done, as the result is only used internally
+ * and never passed directly to user code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+SelectObjFromSublist(
+ Tcl_Obj *objPtr, /* Obj to select sublist from. */
+ SortInfo *infoPtr) /* Information passed from the top-level
+ * "lsearch" or "lsort" command. */
+{
+ int i;
+
+ /*
+ * Quick check for case when no "-index" option is there.
+ */
+
+ if (infoPtr->indexc == 0) {
+ return objPtr;
+ }
+
+ /*
+ * Iterate over the indices, traversing through the nested sublists as we
+ * go.
+ */
+
+ for (i=0 ; i<infoPtr->indexc ; i++) {
+ int listLen, index;
+ Tcl_Obj *currentObj;
+
+ if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
+ infoPtr->resultCode = TCL_ERROR;
+ return NULL;
+ }
+ index = infoPtr->indexv[i];
+
+ /*
+ * Adjust for end-based indexing.
+ */
+
+ if (index < SORTIDX_NONE) {
+ index += listLen + 1;
+ }
+
+ if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
+ &currentObj) != TCL_OK) {
+ infoPtr->resultCode = TCL_ERROR;
+ return NULL;
+ }
+ if (currentObj == NULL) {
+ char buffer[TCL_INTEGER_SPACE];
+
+ TclFormatInt(buffer, index);
+ Tcl_AppendResult(infoPtr->interp, "element ", buffer,
+ " missing from sublist \"", TclGetString(objPtr), "\"",
+ NULL);
+ infoPtr->resultCode = TCL_ERROR;
+ return NULL;
+ }
+ objPtr = currentObj;
+ }
+ return objPtr;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
-