os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdIL.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdIL.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,4292 @@
1.4 +/*
1.5 + * tclCmdIL.c --
1.6 + *
1.7 + * This file contains the top-level command routines for most of
1.8 + * the Tcl built-in commands whose names begin with the letters
1.9 + * I through L. It contains only commands in the generic core
1.10 + * (i.e. those that don't depend much upon UNIX facilities).
1.11 + *
1.12 + * Copyright (c) 1987-1993 The Regents of the University of California.
1.13 + * Copyright (c) 1993-1997 Lucent Technologies.
1.14 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.15 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.16 + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
1.17 + *
1.18 + * See the file "license.terms" for information on usage and redistribution
1.19 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.20 + *
1.21 + * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.11 2007/03/10 14:57:38 dkf Exp $
1.22 + */
1.23 +
1.24 +#include "tclInt.h"
1.25 +#include "tclPort.h"
1.26 +#include "tclRegexp.h"
1.27 +
1.28 +/*
1.29 + * During execution of the "lsort" command, structures of the following
1.30 + * type are used to arrange the objects being sorted into a collection
1.31 + * of linked lists.
1.32 + */
1.33 +
1.34 +typedef struct SortElement {
1.35 + Tcl_Obj *objPtr; /* Object being sorted. */
1.36 + int count; /* number of same elements in list */
1.37 + struct SortElement *nextPtr; /* Next element in the list, or
1.38 + * NULL for end of list. */
1.39 +} SortElement;
1.40 +
1.41 +/*
1.42 + * The "lsort" command needs to pass certain information down to the
1.43 + * function that compares two list elements, and the comparison function
1.44 + * needs to pass success or failure information back up to the top-level
1.45 + * "lsort" command. The following structure is used to pass this
1.46 + * information.
1.47 + */
1.48 +
1.49 +typedef struct SortInfo {
1.50 + int isIncreasing; /* Nonzero means sort in increasing order. */
1.51 + int sortMode; /* The sort mode. One of SORTMODE_*
1.52 + * values defined below */
1.53 + Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode
1.54 + * is SORTMODE_COMMAND. Pre-initialized to
1.55 + * hold base of command.*/
1.56 + int index; /* If the -index option was specified, this
1.57 + * holds the index of the list element
1.58 + * to extract for comparison. If -index
1.59 + * wasn't specified, this is -1. */
1.60 + Tcl_Interp *interp; /* The interpreter in which the sortis
1.61 + * being done. */
1.62 + int resultCode; /* Completion code for the lsort command.
1.63 + * If an error occurs during the sort this
1.64 + * is changed from TCL_OK to TCL_ERROR. */
1.65 +} SortInfo;
1.66 +
1.67 +/*
1.68 + * The "sortMode" field of the SortInfo structure can take on any of the
1.69 + * following values.
1.70 + */
1.71 +
1.72 +#define SORTMODE_ASCII 0
1.73 +#define SORTMODE_INTEGER 1
1.74 +#define SORTMODE_REAL 2
1.75 +#define SORTMODE_COMMAND 3
1.76 +#define SORTMODE_DICTIONARY 4
1.77 +
1.78 +/*
1.79 + * Magic values for the index field of the SortInfo structure.
1.80 + * Note that the index "end-1" will be translated to SORTIDX_END-1, etc.
1.81 + */
1.82 +#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
1.83 +#define SORTIDX_END -2 /* Indexed from end. */
1.84 +
1.85 +/*
1.86 + * Forward declarations for procedures defined in this file:
1.87 + */
1.88 +
1.89 +static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
1.90 + Tcl_Obj *listPtr, CONST char *pattern,
1.91 + int includeLinks));
1.92 +static int DictionaryCompare _ANSI_ARGS_((char *left,
1.93 + char *right));
1.94 +static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
1.95 + Tcl_Interp *interp, int objc,
1.96 + Tcl_Obj *CONST objv[]));
1.97 +static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
1.98 + Tcl_Interp *interp, int objc,
1.99 + Tcl_Obj *CONST objv[]));
1.100 +static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
1.101 + Tcl_Interp *interp, int objc,
1.102 + Tcl_Obj *CONST objv[]));
1.103 +static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
1.104 + Tcl_Interp *interp, int objc,
1.105 + Tcl_Obj *CONST objv[]));
1.106 +static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
1.107 + Tcl_Interp *interp, int objc,
1.108 + Tcl_Obj *CONST objv[]));
1.109 +static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
1.110 + Tcl_Interp *interp, int objc,
1.111 + Tcl_Obj *CONST objv[]));
1.112 +static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
1.113 + Tcl_Interp *interp, int objc,
1.114 + Tcl_Obj *CONST objv[]));
1.115 +#ifdef TCL_TIP280
1.116 +/* TIP #280 - New 'info' subcommand 'frame' */
1.117 +static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy,
1.118 + Tcl_Interp *interp, int objc,
1.119 + Tcl_Obj *CONST objv[]));
1.120 +#endif
1.121 +static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
1.122 + Tcl_Interp *interp, int objc,
1.123 + Tcl_Obj *CONST objv[]));
1.124 +static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
1.125 + Tcl_Interp *interp, int objc,
1.126 + Tcl_Obj *CONST objv[]));
1.127 +static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
1.128 + Tcl_Interp *interp, int objc,
1.129 + Tcl_Obj *CONST objv[]));
1.130 +static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
1.131 + Tcl_Interp *interp, int objc,
1.132 + Tcl_Obj *CONST objv[]));
1.133 +static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
1.134 + Tcl_Interp *interp, int objc,
1.135 + Tcl_Obj *CONST objv[]));
1.136 +static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
1.137 + Tcl_Interp *interp, int objc,
1.138 + Tcl_Obj *CONST objv[]));
1.139 +static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
1.140 + Tcl_Interp *interp, int objc,
1.141 + Tcl_Obj *CONST objv[]));
1.142 +static int InfoNameOfExecutableCmd _ANSI_ARGS_((
1.143 + ClientData dummy, Tcl_Interp *interp, int objc,
1.144 + Tcl_Obj *CONST objv[]));
1.145 +static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
1.146 + Tcl_Interp *interp, int objc,
1.147 + Tcl_Obj *CONST objv[]));
1.148 +static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
1.149 + Tcl_Interp *interp, int objc,
1.150 + Tcl_Obj *CONST objv[]));
1.151 +static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
1.152 + Tcl_Interp *interp, int objc,
1.153 + Tcl_Obj *CONST objv[]));
1.154 +static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
1.155 + Tcl_Interp *interp, int objc,
1.156 + Tcl_Obj *CONST objv[]));
1.157 +static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
1.158 + Tcl_Interp *interp, int objc,
1.159 + Tcl_Obj *CONST objv[]));
1.160 +static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
1.161 + Tcl_Interp *interp, int objc,
1.162 + Tcl_Obj *CONST objv[]));
1.163 +static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
1.164 + SortInfo *infoPtr));
1.165 +static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
1.166 + SortElement *rightPtr, SortInfo *infoPtr));
1.167 +static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
1.168 + Tcl_Obj *second, SortInfo *infoPtr));
1.169 +
1.170 +/*
1.171 + *----------------------------------------------------------------------
1.172 + *
1.173 + * Tcl_IfObjCmd --
1.174 + *
1.175 + * This procedure is invoked to process the "if" Tcl command.
1.176 + * See the user documentation for details on what it does.
1.177 + *
1.178 + * With the bytecode compiler, this procedure is only called when
1.179 + * a command name is computed at runtime, and is "if" or the name
1.180 + * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
1.181 + *
1.182 + * Results:
1.183 + * A standard Tcl result.
1.184 + *
1.185 + * Side effects:
1.186 + * See the user documentation.
1.187 + *
1.188 + *----------------------------------------------------------------------
1.189 + */
1.190 +
1.191 + /* ARGSUSED */
1.192 +int
1.193 +Tcl_IfObjCmd(dummy, interp, objc, objv)
1.194 + ClientData dummy; /* Not used. */
1.195 + Tcl_Interp *interp; /* Current interpreter. */
1.196 + int objc; /* Number of arguments. */
1.197 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.198 +{
1.199 + int thenScriptIndex = 0; /* then script to be evaled after syntax check */
1.200 +#ifdef TCL_TIP280
1.201 + Interp* iPtr = (Interp*) interp;
1.202 +#endif
1.203 + int i, result, value;
1.204 + char *clause;
1.205 + i = 1;
1.206 + while (1) {
1.207 + /*
1.208 + * At this point in the loop, objv and objc refer to an expression
1.209 + * to test, either for the main expression or an expression
1.210 + * following an "elseif". The arguments after the expression must
1.211 + * be "then" (optional) and a script to execute if the expression is
1.212 + * true.
1.213 + */
1.214 +
1.215 + if (i >= objc) {
1.216 + clause = Tcl_GetString(objv[i-1]);
1.217 + Tcl_AppendResult(interp, "wrong # args: no expression after \"",
1.218 + clause, "\" argument", (char *) NULL);
1.219 + return TCL_ERROR;
1.220 + }
1.221 + if (!thenScriptIndex) {
1.222 + result = Tcl_ExprBooleanObj(interp, objv[i], &value);
1.223 + if (result != TCL_OK) {
1.224 + return result;
1.225 + }
1.226 + }
1.227 + i++;
1.228 + if (i >= objc) {
1.229 + missingScript:
1.230 + clause = Tcl_GetString(objv[i-1]);
1.231 + Tcl_AppendResult(interp, "wrong # args: no script following \"",
1.232 + clause, "\" argument", (char *) NULL);
1.233 + return TCL_ERROR;
1.234 + }
1.235 + clause = Tcl_GetString(objv[i]);
1.236 + if ((i < objc) && (strcmp(clause, "then") == 0)) {
1.237 + i++;
1.238 + }
1.239 + if (i >= objc) {
1.240 + goto missingScript;
1.241 + }
1.242 + if (value) {
1.243 + thenScriptIndex = i;
1.244 + value = 0;
1.245 + }
1.246 +
1.247 + /*
1.248 + * The expression evaluated to false. Skip the command, then
1.249 + * see if there is an "else" or "elseif" clause.
1.250 + */
1.251 +
1.252 + i++;
1.253 + if (i >= objc) {
1.254 + if (thenScriptIndex) {
1.255 +#ifndef TCL_TIP280
1.256 + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
1.257 +#else
1.258 + /* TIP #280. Make invoking context available to branch */
1.259 + return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
1.260 + iPtr->cmdFramePtr,thenScriptIndex);
1.261 +#endif
1.262 + }
1.263 + return TCL_OK;
1.264 + }
1.265 + clause = Tcl_GetString(objv[i]);
1.266 + if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
1.267 + i++;
1.268 + continue;
1.269 + }
1.270 + break;
1.271 + }
1.272 +
1.273 + /*
1.274 + * Couldn't find a "then" or "elseif" clause to execute. Check now
1.275 + * for an "else" clause. We know that there's at least one more
1.276 + * argument when we get here.
1.277 + */
1.278 +
1.279 + if (strcmp(clause, "else") == 0) {
1.280 + i++;
1.281 + if (i >= objc) {
1.282 + Tcl_AppendResult(interp,
1.283 + "wrong # args: no script following \"else\" argument",
1.284 + (char *) NULL);
1.285 + return TCL_ERROR;
1.286 + }
1.287 + }
1.288 + if (i < objc - 1) {
1.289 + Tcl_AppendResult(interp,
1.290 + "wrong # args: extra words after \"else\" clause in \"if\" command",
1.291 + (char *) NULL);
1.292 + return TCL_ERROR;
1.293 + }
1.294 + if (thenScriptIndex) {
1.295 +#ifndef TCL_TIP280
1.296 + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
1.297 +#else
1.298 + /* TIP #280. Make invoking context available to branch/else */
1.299 + return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
1.300 + iPtr->cmdFramePtr,thenScriptIndex);
1.301 +#endif
1.302 + }
1.303 +#ifndef TCL_TIP280
1.304 + return Tcl_EvalObjEx(interp, objv[i], 0);
1.305 +#else
1.306 + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
1.307 +#endif
1.308 +}
1.309 +
1.310 +/*
1.311 + *----------------------------------------------------------------------
1.312 + *
1.313 + * Tcl_IncrObjCmd --
1.314 + *
1.315 + * This procedure is invoked to process the "incr" Tcl command.
1.316 + * See the user documentation for details on what it does.
1.317 + *
1.318 + * With the bytecode compiler, this procedure is only called when
1.319 + * a command name is computed at runtime, and is "incr" or the name
1.320 + * to which "incr" was renamed: e.g., "set z incr; $z i -1"
1.321 + *
1.322 + * Results:
1.323 + * A standard Tcl result.
1.324 + *
1.325 + * Side effects:
1.326 + * See the user documentation.
1.327 + *
1.328 + *----------------------------------------------------------------------
1.329 + */
1.330 +
1.331 + /* ARGSUSED */
1.332 +int
1.333 +Tcl_IncrObjCmd(dummy, interp, objc, objv)
1.334 + ClientData dummy; /* Not used. */
1.335 + Tcl_Interp *interp; /* Current interpreter. */
1.336 + int objc; /* Number of arguments. */
1.337 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.338 +{
1.339 + long incrAmount;
1.340 + Tcl_Obj *newValuePtr;
1.341 +
1.342 + if ((objc != 2) && (objc != 3)) {
1.343 + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
1.344 + return TCL_ERROR;
1.345 + }
1.346 +
1.347 + /*
1.348 + * Calculate the amount to increment by.
1.349 + */
1.350 +
1.351 + if (objc == 2) {
1.352 + incrAmount = 1;
1.353 + } else {
1.354 + if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
1.355 + Tcl_AddErrorInfo(interp, "\n (reading increment)");
1.356 + return TCL_ERROR;
1.357 + }
1.358 + /*
1.359 + * Need to be a bit cautious to ensure that [expr]-like rules
1.360 + * are enforced for interpretation of wide integers, despite
1.361 + * the fact that the underlying API itself is a 'long' only one.
1.362 + */
1.363 + if (objv[2]->typePtr == &tclIntType) {
1.364 + incrAmount = objv[2]->internalRep.longValue;
1.365 + } else if (objv[2]->typePtr == &tclWideIntType) {
1.366 + TclGetLongFromWide(incrAmount,objv[2]);
1.367 + } else {
1.368 + Tcl_WideInt wide;
1.369 +
1.370 + if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) {
1.371 + Tcl_AddErrorInfo(interp, "\n (reading increment)");
1.372 + return TCL_ERROR;
1.373 + }
1.374 + incrAmount = Tcl_WideAsLong(wide);
1.375 + if ((wide <= Tcl_LongAsWide(LONG_MAX))
1.376 + && (wide >= Tcl_LongAsWide(LONG_MIN))) {
1.377 + objv[2]->typePtr = &tclIntType;
1.378 + objv[2]->internalRep.longValue = incrAmount;
1.379 + }
1.380 + }
1.381 + }
1.382 +
1.383 + /*
1.384 + * Increment the variable's value.
1.385 + */
1.386 +
1.387 + newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
1.388 + TCL_LEAVE_ERR_MSG);
1.389 + if (newValuePtr == NULL) {
1.390 + return TCL_ERROR;
1.391 + }
1.392 +
1.393 + /*
1.394 + * Set the interpreter's object result to refer to the variable's new
1.395 + * value object.
1.396 + */
1.397 +
1.398 + Tcl_SetObjResult(interp, newValuePtr);
1.399 + return TCL_OK;
1.400 +}
1.401 +
1.402 +/*
1.403 + *----------------------------------------------------------------------
1.404 + *
1.405 + * Tcl_InfoObjCmd --
1.406 + *
1.407 + * This procedure is invoked to process the "info" Tcl command.
1.408 + * See the user documentation for details on what it does.
1.409 + *
1.410 + * Results:
1.411 + * A standard Tcl result.
1.412 + *
1.413 + * Side effects:
1.414 + * See the user documentation.
1.415 + *
1.416 + *----------------------------------------------------------------------
1.417 + */
1.418 +
1.419 + /* ARGSUSED */
1.420 +int
1.421 +Tcl_InfoObjCmd(clientData, interp, objc, objv)
1.422 + ClientData clientData; /* Arbitrary value passed to the command. */
1.423 + Tcl_Interp *interp; /* Current interpreter. */
1.424 + int objc; /* Number of arguments. */
1.425 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.426 +{
1.427 + static CONST char *subCmds[] = {
1.428 + "args", "body", "cmdcount", "commands",
1.429 + "complete", "default", "exists",
1.430 +#ifdef TCL_TIP280
1.431 + "frame",
1.432 +#endif
1.433 + "functions",
1.434 + "globals", "hostname", "level", "library", "loaded",
1.435 + "locals", "nameofexecutable", "patchlevel", "procs",
1.436 + "script", "sharedlibextension", "tclversion", "vars",
1.437 + (char *) NULL};
1.438 + enum ISubCmdIdx {
1.439 + IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
1.440 + ICompleteIdx, IDefaultIdx, IExistsIdx,
1.441 +#ifdef TCL_TIP280
1.442 + IFrameIdx,
1.443 +#endif
1.444 + IFunctionsIdx,
1.445 + IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
1.446 + ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
1.447 + IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
1.448 + };
1.449 + int index, result;
1.450 +
1.451 + if (objc < 2) {
1.452 + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
1.453 + return TCL_ERROR;
1.454 + }
1.455 +
1.456 + result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
1.457 + (int *) &index);
1.458 + if (result != TCL_OK) {
1.459 + return result;
1.460 + }
1.461 +
1.462 + switch (index) {
1.463 + case IArgsIdx:
1.464 + result = InfoArgsCmd(clientData, interp, objc, objv);
1.465 + break;
1.466 + case IBodyIdx:
1.467 + result = InfoBodyCmd(clientData, interp, objc, objv);
1.468 + break;
1.469 + case ICmdCountIdx:
1.470 + result = InfoCmdCountCmd(clientData, interp, objc, objv);
1.471 + break;
1.472 + case ICommandsIdx:
1.473 + result = InfoCommandsCmd(clientData, interp, objc, objv);
1.474 + break;
1.475 + case ICompleteIdx:
1.476 + result = InfoCompleteCmd(clientData, interp, objc, objv);
1.477 + break;
1.478 + case IDefaultIdx:
1.479 + result = InfoDefaultCmd(clientData, interp, objc, objv);
1.480 + break;
1.481 + case IExistsIdx:
1.482 + result = InfoExistsCmd(clientData, interp, objc, objv);
1.483 + break;
1.484 +#ifdef TCL_TIP280
1.485 + case IFrameIdx:
1.486 + /* TIP #280 - New method 'frame' */
1.487 + result = InfoFrameCmd(clientData, interp, objc, objv);
1.488 + break;
1.489 +#endif
1.490 + case IFunctionsIdx:
1.491 + result = InfoFunctionsCmd(clientData, interp, objc, objv);
1.492 + break;
1.493 + case IGlobalsIdx:
1.494 + result = InfoGlobalsCmd(clientData, interp, objc, objv);
1.495 + break;
1.496 + case IHostnameIdx:
1.497 + result = InfoHostnameCmd(clientData, interp, objc, objv);
1.498 + break;
1.499 + case ILevelIdx:
1.500 + result = InfoLevelCmd(clientData, interp, objc, objv);
1.501 + break;
1.502 + case ILibraryIdx:
1.503 + result = InfoLibraryCmd(clientData, interp, objc, objv);
1.504 + break;
1.505 + case ILoadedIdx:
1.506 + result = InfoLoadedCmd(clientData, interp, objc, objv);
1.507 + break;
1.508 + case ILocalsIdx:
1.509 + result = InfoLocalsCmd(clientData, interp, objc, objv);
1.510 + break;
1.511 + case INameOfExecutableIdx:
1.512 + result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
1.513 + break;
1.514 + case IPatchLevelIdx:
1.515 + result = InfoPatchLevelCmd(clientData, interp, objc, objv);
1.516 + break;
1.517 + case IProcsIdx:
1.518 + result = InfoProcsCmd(clientData, interp, objc, objv);
1.519 + break;
1.520 + case IScriptIdx:
1.521 + result = InfoScriptCmd(clientData, interp, objc, objv);
1.522 + break;
1.523 + case ISharedLibExtensionIdx:
1.524 + result = InfoSharedlibCmd(clientData, interp, objc, objv);
1.525 + break;
1.526 + case ITclVersionIdx:
1.527 + result = InfoTclVersionCmd(clientData, interp, objc, objv);
1.528 + break;
1.529 + case IVarsIdx:
1.530 + result = InfoVarsCmd(clientData, interp, objc, objv);
1.531 + break;
1.532 + }
1.533 + return result;
1.534 +}
1.535 +
1.536 +/*
1.537 + *----------------------------------------------------------------------
1.538 + *
1.539 + * InfoArgsCmd --
1.540 + *
1.541 + * Called to implement the "info args" command that returns the
1.542 + * argument list for a procedure. Handles the following syntax:
1.543 + *
1.544 + * info args procName
1.545 + *
1.546 + * Results:
1.547 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.548 + *
1.549 + * Side effects:
1.550 + * Returns a result in the interpreter's result object. If there is
1.551 + * an error, the result is an error message.
1.552 + *
1.553 + *----------------------------------------------------------------------
1.554 + */
1.555 +
1.556 +static int
1.557 +InfoArgsCmd(dummy, interp, objc, objv)
1.558 + ClientData dummy; /* Not used. */
1.559 + Tcl_Interp *interp; /* Current interpreter. */
1.560 + int objc; /* Number of arguments. */
1.561 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.562 +{
1.563 + register Interp *iPtr = (Interp *) interp;
1.564 + char *name;
1.565 + Proc *procPtr;
1.566 + CompiledLocal *localPtr;
1.567 + Tcl_Obj *listObjPtr;
1.568 +
1.569 + if (objc != 3) {
1.570 + Tcl_WrongNumArgs(interp, 2, objv, "procname");
1.571 + return TCL_ERROR;
1.572 + }
1.573 +
1.574 + name = Tcl_GetString(objv[2]);
1.575 + procPtr = TclFindProc(iPtr, name);
1.576 + if (procPtr == NULL) {
1.577 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.578 + "\"", name, "\" isn't a procedure", (char *) NULL);
1.579 + return TCL_ERROR;
1.580 + }
1.581 +
1.582 + /*
1.583 + * Build a return list containing the arguments.
1.584 + */
1.585 +
1.586 + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.587 + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
1.588 + localPtr = localPtr->nextPtr) {
1.589 + if (TclIsVarArgument(localPtr)) {
1.590 + Tcl_ListObjAppendElement(interp, listObjPtr,
1.591 + Tcl_NewStringObj(localPtr->name, -1));
1.592 + }
1.593 + }
1.594 + Tcl_SetObjResult(interp, listObjPtr);
1.595 + return TCL_OK;
1.596 +}
1.597 +
1.598 +/*
1.599 + *----------------------------------------------------------------------
1.600 + *
1.601 + * InfoBodyCmd --
1.602 + *
1.603 + * Called to implement the "info body" command that returns the body
1.604 + * for a procedure. Handles the following syntax:
1.605 + *
1.606 + * info body procName
1.607 + *
1.608 + * Results:
1.609 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.610 + *
1.611 + * Side effects:
1.612 + * Returns a result in the interpreter's result object. If there is
1.613 + * an error, the result is an error message.
1.614 + *
1.615 + *----------------------------------------------------------------------
1.616 + */
1.617 +
1.618 +static int
1.619 +InfoBodyCmd(dummy, interp, objc, objv)
1.620 + ClientData dummy; /* Not used. */
1.621 + Tcl_Interp *interp; /* Current interpreter. */
1.622 + int objc; /* Number of arguments. */
1.623 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.624 +{
1.625 + register Interp *iPtr = (Interp *) interp;
1.626 + char *name;
1.627 + Proc *procPtr;
1.628 + Tcl_Obj *bodyPtr, *resultPtr;
1.629 +
1.630 + if (objc != 3) {
1.631 + Tcl_WrongNumArgs(interp, 2, objv, "procname");
1.632 + return TCL_ERROR;
1.633 + }
1.634 +
1.635 + name = Tcl_GetString(objv[2]);
1.636 + procPtr = TclFindProc(iPtr, name);
1.637 + if (procPtr == NULL) {
1.638 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.639 + "\"", name, "\" isn't a procedure", (char *) NULL);
1.640 + return TCL_ERROR;
1.641 + }
1.642 +
1.643 + /*
1.644 + * Here we used to return procPtr->bodyPtr, except when the body was
1.645 + * bytecompiled - in that case, the return was a copy of the body's
1.646 + * string rep. In order to better isolate the implementation details
1.647 + * of the compiler/engine subsystem, we now always return a copy of
1.648 + * the string rep. It is important to return a copy so that later
1.649 + * manipulations of the object do not invalidate the internal rep.
1.650 + */
1.651 +
1.652 + bodyPtr = procPtr->bodyPtr;
1.653 + if (bodyPtr->bytes == NULL) {
1.654 + /*
1.655 + * The string rep might not be valid if the procedure has
1.656 + * never been run before. [Bug #545644]
1.657 + */
1.658 + (void) Tcl_GetString(bodyPtr);
1.659 + }
1.660 + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
1.661 +
1.662 + Tcl_SetObjResult(interp, resultPtr);
1.663 + return TCL_OK;
1.664 +}
1.665 +
1.666 +/*
1.667 + *----------------------------------------------------------------------
1.668 + *
1.669 + * InfoCmdCountCmd --
1.670 + *
1.671 + * Called to implement the "info cmdcount" command that returns the
1.672 + * number of commands that have been executed. Handles the following
1.673 + * syntax:
1.674 + *
1.675 + * info cmdcount
1.676 + *
1.677 + * Results:
1.678 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.679 + *
1.680 + * Side effects:
1.681 + * Returns a result in the interpreter's result object. If there is
1.682 + * an error, the result is an error message.
1.683 + *
1.684 + *----------------------------------------------------------------------
1.685 + */
1.686 +
1.687 +static int
1.688 +InfoCmdCountCmd(dummy, interp, objc, objv)
1.689 + ClientData dummy; /* Not used. */
1.690 + Tcl_Interp *interp; /* Current interpreter. */
1.691 + int objc; /* Number of arguments. */
1.692 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.693 +{
1.694 + Interp *iPtr = (Interp *) interp;
1.695 +
1.696 + if (objc != 2) {
1.697 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.698 + return TCL_ERROR;
1.699 + }
1.700 +
1.701 + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
1.702 + return TCL_OK;
1.703 +}
1.704 +
1.705 +/*
1.706 + *----------------------------------------------------------------------
1.707 + *
1.708 + * InfoCommandsCmd --
1.709 + *
1.710 + * Called to implement the "info commands" command that returns the
1.711 + * list of commands in the interpreter that match an optional pattern.
1.712 + * The pattern, if any, consists of an optional sequence of namespace
1.713 + * names separated by "::" qualifiers, which is followed by a
1.714 + * glob-style pattern that restricts which commands are returned.
1.715 + * Handles the following syntax:
1.716 + *
1.717 + * info commands ?pattern?
1.718 + *
1.719 + * Results:
1.720 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.721 + *
1.722 + * Side effects:
1.723 + * Returns a result in the interpreter's result object. If there is
1.724 + * an error, the result is an error message.
1.725 + *
1.726 + *----------------------------------------------------------------------
1.727 + */
1.728 +
1.729 +static int
1.730 +InfoCommandsCmd(dummy, interp, objc, objv)
1.731 + ClientData dummy; /* Not used. */
1.732 + Tcl_Interp *interp; /* Current interpreter. */
1.733 + int objc; /* Number of arguments. */
1.734 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.735 +{
1.736 + char *cmdName, *pattern;
1.737 + CONST char *simplePattern;
1.738 + register Tcl_HashEntry *entryPtr;
1.739 + Tcl_HashSearch search;
1.740 + Namespace *nsPtr;
1.741 + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.742 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.743 + Tcl_Obj *listPtr, *elemObjPtr;
1.744 + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
1.745 + Tcl_Command cmd;
1.746 +
1.747 + /*
1.748 + * Get the pattern and find the "effective namespace" in which to
1.749 + * list commands.
1.750 + */
1.751 +
1.752 + if (objc == 2) {
1.753 + simplePattern = NULL;
1.754 + nsPtr = currNsPtr;
1.755 + specificNsInPattern = 0;
1.756 + } else if (objc == 3) {
1.757 + /*
1.758 + * From the pattern, get the effective namespace and the simple
1.759 + * pattern (no namespace qualifiers or ::'s) at the end. If an
1.760 + * error was found while parsing the pattern, return it. Otherwise,
1.761 + * if the namespace wasn't found, just leave nsPtr NULL: we will
1.762 + * return an empty list since no commands there can be found.
1.763 + */
1.764 +
1.765 + Namespace *dummy1NsPtr, *dummy2NsPtr;
1.766 +
1.767 +
1.768 + pattern = Tcl_GetString(objv[2]);
1.769 + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
1.770 + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
1.771 +
1.772 + if (nsPtr != NULL) { /* we successfully found the pattern's ns */
1.773 + specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
1.774 + }
1.775 + } else {
1.776 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.777 + return TCL_ERROR;
1.778 + }
1.779 +
1.780 + /*
1.781 + * Exit as quickly as possible if we couldn't find the namespace.
1.782 + */
1.783 +
1.784 + if (nsPtr == NULL) {
1.785 + return TCL_OK;
1.786 + }
1.787 +
1.788 + /*
1.789 + * Scan through the effective namespace's command table and create a
1.790 + * list with all commands that match the pattern. If a specific
1.791 + * namespace was requested in the pattern, qualify the command names
1.792 + * with the namespace name.
1.793 + */
1.794 +
1.795 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.796 +
1.797 + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
1.798 + /*
1.799 + * Special case for when the pattern doesn't include any of
1.800 + * glob's special characters. This lets us avoid scans of any
1.801 + * hash tables.
1.802 + */
1.803 + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
1.804 + if (entryPtr != NULL) {
1.805 + if (specificNsInPattern) {
1.806 + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
1.807 + elemObjPtr = Tcl_NewObj();
1.808 + Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
1.809 + } else {
1.810 + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
1.811 + elemObjPtr = Tcl_NewStringObj(cmdName, -1);
1.812 + }
1.813 + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1.814 + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1.815 + entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
1.816 + simplePattern);
1.817 + if (entryPtr != NULL) {
1.818 + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
1.819 + Tcl_ListObjAppendElement(interp, listPtr,
1.820 + Tcl_NewStringObj(cmdName, -1));
1.821 + }
1.822 + }
1.823 + } else {
1.824 + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1.825 + while (entryPtr != NULL) {
1.826 + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
1.827 + if ((simplePattern == NULL)
1.828 + || Tcl_StringMatch(cmdName, simplePattern)) {
1.829 + if (specificNsInPattern) {
1.830 + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
1.831 + elemObjPtr = Tcl_NewObj();
1.832 + Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
1.833 + } else {
1.834 + elemObjPtr = Tcl_NewStringObj(cmdName, -1);
1.835 + }
1.836 + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1.837 + }
1.838 + entryPtr = Tcl_NextHashEntry(&search);
1.839 + }
1.840 +
1.841 + /*
1.842 + * If the effective namespace isn't the global :: namespace, and a
1.843 + * specific namespace wasn't requested in the pattern, then add in
1.844 + * all global :: commands that match the simple pattern. Of course,
1.845 + * we add in only those commands that aren't hidden by a command in
1.846 + * the effective namespace.
1.847 + */
1.848 +
1.849 + if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1.850 + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
1.851 + while (entryPtr != NULL) {
1.852 + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
1.853 + if ((simplePattern == NULL)
1.854 + || Tcl_StringMatch(cmdName, simplePattern)) {
1.855 + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
1.856 + Tcl_ListObjAppendElement(interp, listPtr,
1.857 + Tcl_NewStringObj(cmdName, -1));
1.858 + }
1.859 + }
1.860 + entryPtr = Tcl_NextHashEntry(&search);
1.861 + }
1.862 + }
1.863 + }
1.864 +
1.865 + Tcl_SetObjResult(interp, listPtr);
1.866 + return TCL_OK;
1.867 +}
1.868 +
1.869 +/*
1.870 + *----------------------------------------------------------------------
1.871 + *
1.872 + * InfoCompleteCmd --
1.873 + *
1.874 + * Called to implement the "info complete" command that determines
1.875 + * whether a string is a complete Tcl command. Handles the following
1.876 + * syntax:
1.877 + *
1.878 + * info complete command
1.879 + *
1.880 + * Results:
1.881 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.882 + *
1.883 + * Side effects:
1.884 + * Returns a result in the interpreter's result object. If there is
1.885 + * an error, the result is an error message.
1.886 + *
1.887 + *----------------------------------------------------------------------
1.888 + */
1.889 +
1.890 +static int
1.891 +InfoCompleteCmd(dummy, interp, objc, objv)
1.892 + ClientData dummy; /* Not used. */
1.893 + Tcl_Interp *interp; /* Current interpreter. */
1.894 + int objc; /* Number of arguments. */
1.895 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.896 +{
1.897 + if (objc != 3) {
1.898 + Tcl_WrongNumArgs(interp, 2, objv, "command");
1.899 + return TCL_ERROR;
1.900 + }
1.901 +
1.902 + if (TclObjCommandComplete(objv[2])) {
1.903 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
1.904 + } else {
1.905 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1.906 + }
1.907 +
1.908 + return TCL_OK;
1.909 +}
1.910 +
1.911 +/*
1.912 + *----------------------------------------------------------------------
1.913 + *
1.914 + * InfoDefaultCmd --
1.915 + *
1.916 + * Called to implement the "info default" command that returns the
1.917 + * default value for a procedure argument. Handles the following
1.918 + * syntax:
1.919 + *
1.920 + * info default procName arg varName
1.921 + *
1.922 + * Results:
1.923 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.924 + *
1.925 + * Side effects:
1.926 + * Returns a result in the interpreter's result object. If there is
1.927 + * an error, the result is an error message.
1.928 + *
1.929 + *----------------------------------------------------------------------
1.930 + */
1.931 +
1.932 +static int
1.933 +InfoDefaultCmd(dummy, interp, objc, objv)
1.934 + ClientData dummy; /* Not used. */
1.935 + Tcl_Interp *interp; /* Current interpreter. */
1.936 + int objc; /* Number of arguments. */
1.937 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.938 +{
1.939 + Interp *iPtr = (Interp *) interp;
1.940 + char *procName, *argName, *varName;
1.941 + Proc *procPtr;
1.942 + CompiledLocal *localPtr;
1.943 + Tcl_Obj *valueObjPtr;
1.944 +
1.945 + if (objc != 5) {
1.946 + Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
1.947 + return TCL_ERROR;
1.948 + }
1.949 +
1.950 + procName = Tcl_GetString(objv[2]);
1.951 + argName = Tcl_GetString(objv[3]);
1.952 +
1.953 + procPtr = TclFindProc(iPtr, procName);
1.954 + if (procPtr == NULL) {
1.955 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.956 + "\"", procName, "\" isn't a procedure", (char *) NULL);
1.957 + return TCL_ERROR;
1.958 + }
1.959 +
1.960 + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
1.961 + localPtr = localPtr->nextPtr) {
1.962 + if (TclIsVarArgument(localPtr)
1.963 + && (strcmp(argName, localPtr->name) == 0)) {
1.964 + if (localPtr->defValuePtr != NULL) {
1.965 + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
1.966 + localPtr->defValuePtr, 0);
1.967 + if (valueObjPtr == NULL) {
1.968 + defStoreError:
1.969 + varName = Tcl_GetString(objv[4]);
1.970 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.971 + "couldn't store default value in variable \"",
1.972 + varName, "\"", (char *) NULL);
1.973 + return TCL_ERROR;
1.974 + }
1.975 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
1.976 + } else {
1.977 + Tcl_Obj *nullObjPtr = Tcl_NewObj();
1.978 + Tcl_IncrRefCount(nullObjPtr);
1.979 + valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
1.980 + nullObjPtr, 0);
1.981 + Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
1.982 + if (valueObjPtr == NULL) {
1.983 + goto defStoreError;
1.984 + }
1.985 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1.986 + }
1.987 + return TCL_OK;
1.988 + }
1.989 + }
1.990 +
1.991 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.992 + "procedure \"", procName, "\" doesn't have an argument \"",
1.993 + argName, "\"", (char *) NULL);
1.994 + return TCL_ERROR;
1.995 +}
1.996 +
1.997 +/*
1.998 + *----------------------------------------------------------------------
1.999 + *
1.1000 + * InfoExistsCmd --
1.1001 + *
1.1002 + * Called to implement the "info exists" command that determines
1.1003 + * whether a variable exists. Handles the following syntax:
1.1004 + *
1.1005 + * info exists varName
1.1006 + *
1.1007 + * Results:
1.1008 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1009 + *
1.1010 + * Side effects:
1.1011 + * Returns a result in the interpreter's result object. If there is
1.1012 + * an error, the result is an error message.
1.1013 + *
1.1014 + *----------------------------------------------------------------------
1.1015 + */
1.1016 +
1.1017 +static int
1.1018 +InfoExistsCmd(dummy, interp, objc, objv)
1.1019 + ClientData dummy; /* Not used. */
1.1020 + Tcl_Interp *interp; /* Current interpreter. */
1.1021 + int objc; /* Number of arguments. */
1.1022 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1023 +{
1.1024 + char *varName;
1.1025 + Var *varPtr;
1.1026 +
1.1027 + if (objc != 3) {
1.1028 + Tcl_WrongNumArgs(interp, 2, objv, "varName");
1.1029 + return TCL_ERROR;
1.1030 + }
1.1031 +
1.1032 + varName = Tcl_GetString(objv[2]);
1.1033 + varPtr = TclVarTraceExists(interp, varName);
1.1034 + if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
1.1035 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
1.1036 + } else {
1.1037 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1.1038 + }
1.1039 + return TCL_OK;
1.1040 +}
1.1041 +
1.1042 +#ifdef TCL_TIP280
1.1043 +/*
1.1044 + *----------------------------------------------------------------------
1.1045 + *
1.1046 + * InfoFrameCmd --
1.1047 + * TIP #280
1.1048 + *
1.1049 + * Called to implement the "info frame" command that returns the
1.1050 + * location of either the currently executing command, or its caller.
1.1051 + * Handles the following syntax:
1.1052 + *
1.1053 + * info frame ?number?
1.1054 + *
1.1055 + * Results:
1.1056 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1057 + *
1.1058 + * Side effects:
1.1059 + * Returns a result in the interpreter's result object. If there is
1.1060 + * an error, the result is an error message.
1.1061 + *
1.1062 + *----------------------------------------------------------------------
1.1063 + */
1.1064 +
1.1065 +static int
1.1066 +InfoFrameCmd(dummy, interp, objc, objv)
1.1067 + ClientData dummy; /* Not used. */
1.1068 + Tcl_Interp *interp; /* Current interpreter. */
1.1069 + int objc; /* Number of arguments. */
1.1070 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1071 +{
1.1072 + Interp *iPtr = (Interp *) interp;
1.1073 +
1.1074 + if (objc == 2) {
1.1075 + /* just "info frame" */
1.1076 + int levels = (iPtr->cmdFramePtr == NULL
1.1077 + ? 0
1.1078 + : iPtr->cmdFramePtr->level);
1.1079 +
1.1080 + Tcl_SetIntObj(Tcl_GetObjResult(interp), levels);
1.1081 + return TCL_OK;
1.1082 +
1.1083 + } else if (objc == 3) {
1.1084 + /* "info frame level" */
1.1085 + int level;
1.1086 + CmdFrame *framePtr;
1.1087 +
1.1088 + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
1.1089 + return TCL_ERROR;
1.1090 + }
1.1091 + if (level <= 0) {
1.1092 + /* Relative adressing */
1.1093 +
1.1094 + if (iPtr->cmdFramePtr == NULL) {
1.1095 + levelError:
1.1096 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1097 + "bad level \"",
1.1098 + Tcl_GetString(objv[2]),
1.1099 + "\"", (char *) NULL);
1.1100 + return TCL_ERROR;
1.1101 + }
1.1102 + /* Convert to absolute. */
1.1103 +
1.1104 + level += iPtr->cmdFramePtr->level;
1.1105 + }
1.1106 + for (framePtr = iPtr->cmdFramePtr;
1.1107 + framePtr != NULL;
1.1108 + framePtr = framePtr->nextPtr) {
1.1109 +
1.1110 + if (framePtr->level == level) {
1.1111 + break;
1.1112 + }
1.1113 + }
1.1114 + if (framePtr == NULL) {
1.1115 + goto levelError;
1.1116 + }
1.1117 +
1.1118 + /*
1.1119 + * Pull the information and construct the dictionary to return, as
1.1120 + * list. Regarding use of the CmdFrame fields see tclInt.h, and its
1.1121 + * definition.
1.1122 + */
1.1123 +
1.1124 + {
1.1125 + Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */
1.1126 + int lc = 0;
1.1127 +
1.1128 + /* This array is indexed by the TCL_LOCATION_... values, except
1.1129 + * for _LAST.
1.1130 + */
1.1131 +
1.1132 + static CONST char* typeString [TCL_LOCATION_LAST] = {
1.1133 + "eval", "eval", "eval", "precompiled", "source", "proc"
1.1134 + };
1.1135 +
1.1136 + switch (framePtr->type) {
1.1137 + case TCL_LOCATION_EVAL:
1.1138 + /* Evaluation, dynamic script. Type, line, cmd, the latter
1.1139 + * through str. */
1.1140 +
1.1141 + lv [lc ++] = Tcl_NewStringObj ("type",-1);
1.1142 + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
1.1143 + lv [lc ++] = Tcl_NewStringObj ("line",-1);
1.1144 + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
1.1145 + lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
1.1146 + lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
1.1147 + framePtr->cmd.str.len);
1.1148 + break;
1.1149 +
1.1150 + case TCL_LOCATION_EVAL_LIST:
1.1151 + /* List optimized evaluation. Type, line, cmd, the latter
1.1152 + * through listPtr, possibly a frame. */
1.1153 +
1.1154 + lv [lc ++] = Tcl_NewStringObj ("type",-1);
1.1155 + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
1.1156 + lv [lc ++] = Tcl_NewStringObj ("line",-1);
1.1157 + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
1.1158 +
1.1159 + /* We put a duplicate of the command list obj into the result
1.1160 + * to ensure that the 'pure List'-property of the command
1.1161 + * itself is not destroyed. Otherwise the query here would
1.1162 + * disable the list optimization path in Tcl_EvalObjEx.
1.1163 + */
1.1164 +
1.1165 + lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
1.1166 + lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr);
1.1167 + break;
1.1168 +
1.1169 + case TCL_LOCATION_PREBC:
1.1170 + /* Precompiled. Result contains the type as signal, nothing
1.1171 + * else */
1.1172 +
1.1173 + lv [lc ++] = Tcl_NewStringObj ("type",-1);
1.1174 + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
1.1175 + break;
1.1176 +
1.1177 + case TCL_LOCATION_BC: {
1.1178 + /* Execution of bytecode. Talk to the BC engine to fill out
1.1179 + * the frame. */
1.1180 +
1.1181 + CmdFrame f = *framePtr;
1.1182 + Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL;
1.1183 +
1.1184 + /* Note: Type BC => f.data.eval.path is not used.
1.1185 + * f.data.tebc.codePtr is used instead.
1.1186 + */
1.1187 +
1.1188 + TclGetSrcInfoForPc (&f);
1.1189 + /* Now filled: cmd.str.(cmd,len), line */
1.1190 + /* Possibly modified: type, path! */
1.1191 +
1.1192 + lv [lc ++] = Tcl_NewStringObj ("type",-1);
1.1193 + lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1);
1.1194 + lv [lc ++] = Tcl_NewStringObj ("line",-1);
1.1195 + lv [lc ++] = Tcl_NewIntObj (f.line[0]);
1.1196 +
1.1197 + if (f.type == TCL_LOCATION_SOURCE) {
1.1198 + lv [lc ++] = Tcl_NewStringObj ("file",-1);
1.1199 + lv [lc ++] = f.data.eval.path;
1.1200 + /* Death of reference by TclGetSrcInfoForPc */
1.1201 + Tcl_DecrRefCount (f.data.eval.path);
1.1202 + }
1.1203 +
1.1204 + lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
1.1205 + lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len);
1.1206 +
1.1207 + if (procPtr != NULL) {
1.1208 + Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr;
1.1209 + char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr);
1.1210 + char* nsName = procPtr->cmdPtr->nsPtr->fullName;
1.1211 +
1.1212 + lv [lc ++] = Tcl_NewStringObj ("proc",-1);
1.1213 + lv [lc ++] = Tcl_NewStringObj (nsName,-1);
1.1214 +
1.1215 + if (strcmp (nsName, "::") != 0) {
1.1216 + Tcl_AppendToObj (lv [lc-1], "::", -1);
1.1217 + }
1.1218 + Tcl_AppendToObj (lv [lc-1], procName, -1);
1.1219 + }
1.1220 + break;
1.1221 + }
1.1222 +
1.1223 + case TCL_LOCATION_SOURCE:
1.1224 + /* Evaluation of a script file */
1.1225 +
1.1226 + lv [lc ++] = Tcl_NewStringObj ("type",-1);
1.1227 + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
1.1228 + lv [lc ++] = Tcl_NewStringObj ("line",-1);
1.1229 + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
1.1230 + lv [lc ++] = Tcl_NewStringObj ("file",-1);
1.1231 + lv [lc ++] = framePtr->data.eval.path;
1.1232 + /* Refcount framePtr->data.eval.path goes up when lv
1.1233 + * is converted into the result list object.
1.1234 + */
1.1235 + lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
1.1236 + lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
1.1237 + framePtr->cmd.str.len);
1.1238 + break;
1.1239 +
1.1240 + case TCL_LOCATION_PROC:
1.1241 + Tcl_Panic ("TCL_LOCATION_PROC found in standard frame");
1.1242 + break;
1.1243 + }
1.1244 +
1.1245 +
1.1246 + /* 'level'. Common to all frame types. Conditional on having an
1.1247 + * associated _visible_ CallFrame */
1.1248 +
1.1249 + if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
1.1250 + CallFrame* current = framePtr->framePtr;
1.1251 + CallFrame* top = iPtr->varFramePtr;
1.1252 + CallFrame* idx;
1.1253 +
1.1254 + for (idx = top;
1.1255 + idx != NULL;
1.1256 + idx = idx->callerVarPtr) {
1.1257 + if (idx == current) {
1.1258 + int c = framePtr->framePtr->level;
1.1259 + int t = iPtr->varFramePtr->level;
1.1260 +
1.1261 + lv [lc ++] = Tcl_NewStringObj ("level",-1);
1.1262 + lv [lc ++] = Tcl_NewIntObj (t - c);
1.1263 + break;
1.1264 + }
1.1265 + }
1.1266 + }
1.1267 +
1.1268 + Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv));
1.1269 + return TCL_OK;
1.1270 + }
1.1271 + }
1.1272 +
1.1273 + Tcl_WrongNumArgs(interp, 2, objv, "?number?");
1.1274 +
1.1275 + return TCL_ERROR;
1.1276 +}
1.1277 +#endif
1.1278 +
1.1279 +/*
1.1280 + *----------------------------------------------------------------------
1.1281 + *
1.1282 + * InfoFunctionsCmd --
1.1283 + *
1.1284 + * Called to implement the "info functions" command that returns the
1.1285 + * list of math functions matching an optional pattern. Handles the
1.1286 + * following syntax:
1.1287 + *
1.1288 + * info functions ?pattern?
1.1289 + *
1.1290 + * Results:
1.1291 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1292 + *
1.1293 + * Side effects:
1.1294 + * Returns a result in the interpreter's result object. If there is
1.1295 + * an error, the result is an error message.
1.1296 + *
1.1297 + *----------------------------------------------------------------------
1.1298 + */
1.1299 +
1.1300 +static int
1.1301 +InfoFunctionsCmd(dummy, interp, objc, objv)
1.1302 + ClientData dummy; /* Not used. */
1.1303 + Tcl_Interp *interp; /* Current interpreter. */
1.1304 + int objc; /* Number of arguments. */
1.1305 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1306 +{
1.1307 + char *pattern;
1.1308 + Tcl_Obj *listPtr;
1.1309 +
1.1310 + if (objc == 2) {
1.1311 + pattern = NULL;
1.1312 + } else if (objc == 3) {
1.1313 + pattern = Tcl_GetString(objv[2]);
1.1314 + } else {
1.1315 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.1316 + return TCL_ERROR;
1.1317 + }
1.1318 +
1.1319 + listPtr = Tcl_ListMathFuncs(interp, pattern);
1.1320 + if (listPtr == NULL) {
1.1321 + return TCL_ERROR;
1.1322 + }
1.1323 + Tcl_SetObjResult(interp, listPtr);
1.1324 + return TCL_OK;
1.1325 +}
1.1326 +
1.1327 +/*
1.1328 + *----------------------------------------------------------------------
1.1329 + *
1.1330 + * InfoGlobalsCmd --
1.1331 + *
1.1332 + * Called to implement the "info globals" command that returns the list
1.1333 + * of global variables matching an optional pattern. Handles the
1.1334 + * following syntax:
1.1335 + *
1.1336 + * info globals ?pattern?
1.1337 + *
1.1338 + * Results:
1.1339 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1340 + *
1.1341 + * Side effects:
1.1342 + * Returns a result in the interpreter's result object. If there is
1.1343 + * an error, the result is an error message.
1.1344 + *
1.1345 + *----------------------------------------------------------------------
1.1346 + */
1.1347 +
1.1348 +static int
1.1349 +InfoGlobalsCmd(dummy, interp, objc, objv)
1.1350 + ClientData dummy; /* Not used. */
1.1351 + Tcl_Interp *interp; /* Current interpreter. */
1.1352 + int objc; /* Number of arguments. */
1.1353 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1354 +{
1.1355 + char *varName, *pattern;
1.1356 + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.1357 + register Tcl_HashEntry *entryPtr;
1.1358 + Tcl_HashSearch search;
1.1359 + Var *varPtr;
1.1360 + Tcl_Obj *listPtr;
1.1361 +
1.1362 + if (objc == 2) {
1.1363 + pattern = NULL;
1.1364 + } else if (objc == 3) {
1.1365 + pattern = Tcl_GetString(objv[2]);
1.1366 + /*
1.1367 + * Strip leading global-namespace qualifiers. [Bug 1057461]
1.1368 + */
1.1369 + if (pattern[0] == ':' && pattern[1] == ':') {
1.1370 + while (*pattern == ':') {
1.1371 + pattern++;
1.1372 + }
1.1373 + }
1.1374 + } else {
1.1375 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.1376 + return TCL_ERROR;
1.1377 + }
1.1378 +
1.1379 + /*
1.1380 + * Scan through the global :: namespace's variable table and create a
1.1381 + * list of all global variables that match the pattern.
1.1382 + */
1.1383 +
1.1384 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.1385 + if (pattern != NULL && TclMatchIsTrivial(pattern)) {
1.1386 + entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
1.1387 + if (entryPtr != NULL) {
1.1388 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.1389 + if (!TclIsVarUndefined(varPtr)) {
1.1390 + Tcl_ListObjAppendElement(interp, listPtr,
1.1391 + Tcl_NewStringObj(pattern, -1));
1.1392 + }
1.1393 + }
1.1394 + } else {
1.1395 + for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
1.1396 + entryPtr != NULL;
1.1397 + entryPtr = Tcl_NextHashEntry(&search)) {
1.1398 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.1399 + if (TclIsVarUndefined(varPtr)) {
1.1400 + continue;
1.1401 + }
1.1402 + varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
1.1403 + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
1.1404 + Tcl_ListObjAppendElement(interp, listPtr,
1.1405 + Tcl_NewStringObj(varName, -1));
1.1406 + }
1.1407 + }
1.1408 + }
1.1409 + Tcl_SetObjResult(interp, listPtr);
1.1410 + return TCL_OK;
1.1411 +}
1.1412 +
1.1413 +/*
1.1414 + *----------------------------------------------------------------------
1.1415 + *
1.1416 + * InfoHostnameCmd --
1.1417 + *
1.1418 + * Called to implement the "info hostname" command that returns the
1.1419 + * host name. Handles the following syntax:
1.1420 + *
1.1421 + * info hostname
1.1422 + *
1.1423 + * Results:
1.1424 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1425 + *
1.1426 + * Side effects:
1.1427 + * Returns a result in the interpreter's result object. If there is
1.1428 + * an error, the result is an error message.
1.1429 + *
1.1430 + *----------------------------------------------------------------------
1.1431 + */
1.1432 +
1.1433 +static int
1.1434 +InfoHostnameCmd(dummy, interp, objc, objv)
1.1435 + ClientData dummy; /* Not used. */
1.1436 + Tcl_Interp *interp; /* Current interpreter. */
1.1437 + int objc; /* Number of arguments. */
1.1438 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1439 +{
1.1440 + CONST char *name;
1.1441 + if (objc != 2) {
1.1442 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1443 + return TCL_ERROR;
1.1444 + }
1.1445 +
1.1446 + name = Tcl_GetHostName();
1.1447 + if (name) {
1.1448 + Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
1.1449 + return TCL_OK;
1.1450 + } else {
1.1451 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1452 + "unable to determine name of host", -1);
1.1453 + return TCL_ERROR;
1.1454 + }
1.1455 +}
1.1456 +
1.1457 +/*
1.1458 + *----------------------------------------------------------------------
1.1459 + *
1.1460 + * InfoLevelCmd --
1.1461 + *
1.1462 + * Called to implement the "info level" command that returns
1.1463 + * information about the call stack. Handles the following syntax:
1.1464 + *
1.1465 + * info level ?number?
1.1466 + *
1.1467 + * Results:
1.1468 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1469 + *
1.1470 + * Side effects:
1.1471 + * Returns a result in the interpreter's result object. If there is
1.1472 + * an error, the result is an error message.
1.1473 + *
1.1474 + *----------------------------------------------------------------------
1.1475 + */
1.1476 +
1.1477 +static int
1.1478 +InfoLevelCmd(dummy, interp, objc, objv)
1.1479 + ClientData dummy; /* Not used. */
1.1480 + Tcl_Interp *interp; /* Current interpreter. */
1.1481 + int objc; /* Number of arguments. */
1.1482 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1483 +{
1.1484 + Interp *iPtr = (Interp *) interp;
1.1485 + int level;
1.1486 + CallFrame *framePtr;
1.1487 + Tcl_Obj *listPtr;
1.1488 +
1.1489 + if (objc == 2) { /* just "info level" */
1.1490 + if (iPtr->varFramePtr == NULL) {
1.1491 + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1.1492 + } else {
1.1493 + Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
1.1494 + }
1.1495 + return TCL_OK;
1.1496 + } else if (objc == 3) {
1.1497 + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
1.1498 + return TCL_ERROR;
1.1499 + }
1.1500 + if (level <= 0) {
1.1501 + if (iPtr->varFramePtr == NULL) {
1.1502 + levelError:
1.1503 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1504 + "bad level \"",
1.1505 + Tcl_GetString(objv[2]),
1.1506 + "\"", (char *) NULL);
1.1507 + return TCL_ERROR;
1.1508 + }
1.1509 + level += iPtr->varFramePtr->level;
1.1510 + }
1.1511 + for (framePtr = iPtr->varFramePtr; framePtr != NULL;
1.1512 + framePtr = framePtr->callerVarPtr) {
1.1513 + if (framePtr->level == level) {
1.1514 + break;
1.1515 + }
1.1516 + }
1.1517 + if (framePtr == NULL) {
1.1518 + goto levelError;
1.1519 + }
1.1520 +
1.1521 + listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
1.1522 + Tcl_SetObjResult(interp, listPtr);
1.1523 + return TCL_OK;
1.1524 + }
1.1525 +
1.1526 + Tcl_WrongNumArgs(interp, 2, objv, "?number?");
1.1527 + return TCL_ERROR;
1.1528 +}
1.1529 +
1.1530 +/*
1.1531 + *----------------------------------------------------------------------
1.1532 + *
1.1533 + * InfoLibraryCmd --
1.1534 + *
1.1535 + * Called to implement the "info library" command that returns the
1.1536 + * library directory for the Tcl installation. Handles the following
1.1537 + * syntax:
1.1538 + *
1.1539 + * info library
1.1540 + *
1.1541 + * Results:
1.1542 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1543 + *
1.1544 + * Side effects:
1.1545 + * Returns a result in the interpreter's result object. If there is
1.1546 + * an error, the result is an error message.
1.1547 + *
1.1548 + *----------------------------------------------------------------------
1.1549 + */
1.1550 +
1.1551 +static int
1.1552 +InfoLibraryCmd(dummy, interp, objc, objv)
1.1553 + ClientData dummy; /* Not used. */
1.1554 + Tcl_Interp *interp; /* Current interpreter. */
1.1555 + int objc; /* Number of arguments. */
1.1556 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1557 +{
1.1558 + CONST char *libDirName;
1.1559 +
1.1560 + if (objc != 2) {
1.1561 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1562 + return TCL_ERROR;
1.1563 + }
1.1564 +
1.1565 + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
1.1566 + if (libDirName != NULL) {
1.1567 + Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
1.1568 + return TCL_OK;
1.1569 + }
1.1570 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1571 + "no library has been specified for Tcl", -1);
1.1572 + return TCL_ERROR;
1.1573 +}
1.1574 +
1.1575 +/*
1.1576 + *----------------------------------------------------------------------
1.1577 + *
1.1578 + * InfoLoadedCmd --
1.1579 + *
1.1580 + * Called to implement the "info loaded" command that returns the
1.1581 + * packages that have been loaded into an interpreter. Handles the
1.1582 + * following syntax:
1.1583 + *
1.1584 + * info loaded ?interp?
1.1585 + *
1.1586 + * Results:
1.1587 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1588 + *
1.1589 + * Side effects:
1.1590 + * Returns a result in the interpreter's result object. If there is
1.1591 + * an error, the result is an error message.
1.1592 + *
1.1593 + *----------------------------------------------------------------------
1.1594 + */
1.1595 +
1.1596 +static int
1.1597 +InfoLoadedCmd(dummy, interp, objc, objv)
1.1598 + ClientData dummy; /* Not used. */
1.1599 + Tcl_Interp *interp; /* Current interpreter. */
1.1600 + int objc; /* Number of arguments. */
1.1601 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1602 +{
1.1603 + char *interpName;
1.1604 + int result;
1.1605 +
1.1606 + if ((objc != 2) && (objc != 3)) {
1.1607 + Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
1.1608 + return TCL_ERROR;
1.1609 + }
1.1610 +
1.1611 + if (objc == 2) { /* get loaded pkgs in all interpreters */
1.1612 + interpName = NULL;
1.1613 + } else { /* get pkgs just in specified interp */
1.1614 + interpName = Tcl_GetString(objv[2]);
1.1615 + }
1.1616 + result = TclGetLoadedPackages(interp, interpName);
1.1617 + return result;
1.1618 +}
1.1619 +
1.1620 +/*
1.1621 + *----------------------------------------------------------------------
1.1622 + *
1.1623 + * InfoLocalsCmd --
1.1624 + *
1.1625 + * Called to implement the "info locals" command to return a list of
1.1626 + * local variables that match an optional pattern. Handles the
1.1627 + * following syntax:
1.1628 + *
1.1629 + * info locals ?pattern?
1.1630 + *
1.1631 + * Results:
1.1632 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1633 + *
1.1634 + * Side effects:
1.1635 + * Returns a result in the interpreter's result object. If there is
1.1636 + * an error, the result is an error message.
1.1637 + *
1.1638 + *----------------------------------------------------------------------
1.1639 + */
1.1640 +
1.1641 +static int
1.1642 +InfoLocalsCmd(dummy, interp, objc, objv)
1.1643 + ClientData dummy; /* Not used. */
1.1644 + Tcl_Interp *interp; /* Current interpreter. */
1.1645 + int objc; /* Number of arguments. */
1.1646 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1647 +{
1.1648 + Interp *iPtr = (Interp *) interp;
1.1649 + char *pattern;
1.1650 + Tcl_Obj *listPtr;
1.1651 +
1.1652 + if (objc == 2) {
1.1653 + pattern = NULL;
1.1654 + } else if (objc == 3) {
1.1655 + pattern = Tcl_GetString(objv[2]);
1.1656 + } else {
1.1657 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.1658 + return TCL_ERROR;
1.1659 + }
1.1660 +
1.1661 + if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
1.1662 + return TCL_OK;
1.1663 + }
1.1664 +
1.1665 + /*
1.1666 + * Return a list containing names of first the compiled locals (i.e. the
1.1667 + * ones stored in the call frame), then the variables in the local hash
1.1668 + * table (if one exists).
1.1669 + */
1.1670 +
1.1671 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.1672 + AppendLocals(interp, listPtr, pattern, 0);
1.1673 + Tcl_SetObjResult(interp, listPtr);
1.1674 + return TCL_OK;
1.1675 +}
1.1676 +
1.1677 +/*
1.1678 + *----------------------------------------------------------------------
1.1679 + *
1.1680 + * AppendLocals --
1.1681 + *
1.1682 + * Append the local variables for the current frame to the
1.1683 + * specified list object.
1.1684 + *
1.1685 + * Results:
1.1686 + * None.
1.1687 + *
1.1688 + * Side effects:
1.1689 + * None.
1.1690 + *
1.1691 + *----------------------------------------------------------------------
1.1692 + */
1.1693 +
1.1694 +static void
1.1695 +AppendLocals(interp, listPtr, pattern, includeLinks)
1.1696 + Tcl_Interp *interp; /* Current interpreter. */
1.1697 + Tcl_Obj *listPtr; /* List object to append names to. */
1.1698 + CONST char *pattern; /* Pattern to match against. */
1.1699 + int includeLinks; /* 1 if upvars should be included, else 0. */
1.1700 +{
1.1701 + Interp *iPtr = (Interp *) interp;
1.1702 + CompiledLocal *localPtr;
1.1703 + Var *varPtr;
1.1704 + int i, localVarCt;
1.1705 + char *varName;
1.1706 + Tcl_HashTable *localVarTablePtr;
1.1707 + register Tcl_HashEntry *entryPtr;
1.1708 + Tcl_HashSearch search;
1.1709 +
1.1710 + localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
1.1711 + localVarCt = iPtr->varFramePtr->numCompiledLocals;
1.1712 + varPtr = iPtr->varFramePtr->compiledLocals;
1.1713 + localVarTablePtr = iPtr->varFramePtr->varTablePtr;
1.1714 +
1.1715 + for (i = 0; i < localVarCt; i++) {
1.1716 + /*
1.1717 + * Skip nameless (temporary) variables and undefined variables
1.1718 + */
1.1719 +
1.1720 + if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
1.1721 + && (includeLinks || !TclIsVarLink(varPtr))) {
1.1722 + varName = varPtr->name;
1.1723 + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
1.1724 + Tcl_ListObjAppendElement(interp, listPtr,
1.1725 + Tcl_NewStringObj(varName, -1));
1.1726 + }
1.1727 + }
1.1728 + varPtr++;
1.1729 + localPtr = localPtr->nextPtr;
1.1730 + }
1.1731 +
1.1732 + if (localVarTablePtr != NULL) {
1.1733 + for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
1.1734 + entryPtr != NULL;
1.1735 + entryPtr = Tcl_NextHashEntry(&search)) {
1.1736 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.1737 + if (!TclIsVarUndefined(varPtr)
1.1738 + && (includeLinks || !TclIsVarLink(varPtr))) {
1.1739 + varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
1.1740 + if ((pattern == NULL)
1.1741 + || Tcl_StringMatch(varName, pattern)) {
1.1742 + Tcl_ListObjAppendElement(interp, listPtr,
1.1743 + Tcl_NewStringObj(varName, -1));
1.1744 + }
1.1745 + }
1.1746 + }
1.1747 + }
1.1748 +}
1.1749 +
1.1750 +/*
1.1751 + *----------------------------------------------------------------------
1.1752 + *
1.1753 + * InfoNameOfExecutableCmd --
1.1754 + *
1.1755 + * Called to implement the "info nameofexecutable" command that returns
1.1756 + * the name of the binary file running this application. Handles the
1.1757 + * following syntax:
1.1758 + *
1.1759 + * info nameofexecutable
1.1760 + *
1.1761 + * Results:
1.1762 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1763 + *
1.1764 + * Side effects:
1.1765 + * Returns a result in the interpreter's result object. If there is
1.1766 + * an error, the result is an error message.
1.1767 + *
1.1768 + *----------------------------------------------------------------------
1.1769 + */
1.1770 +
1.1771 +static int
1.1772 +InfoNameOfExecutableCmd(dummy, interp, objc, objv)
1.1773 + ClientData dummy; /* Not used. */
1.1774 + Tcl_Interp *interp; /* Current interpreter. */
1.1775 + int objc; /* Number of arguments. */
1.1776 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1777 +{
1.1778 + CONST char *nameOfExecutable;
1.1779 +
1.1780 + if (objc != 2) {
1.1781 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1782 + return TCL_ERROR;
1.1783 + }
1.1784 +
1.1785 + nameOfExecutable = Tcl_GetNameOfExecutable();
1.1786 +
1.1787 + if (nameOfExecutable != NULL) {
1.1788 + Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1);
1.1789 + }
1.1790 + return TCL_OK;
1.1791 +}
1.1792 +
1.1793 +/*
1.1794 + *----------------------------------------------------------------------
1.1795 + *
1.1796 + * InfoPatchLevelCmd --
1.1797 + *
1.1798 + * Called to implement the "info patchlevel" command that returns the
1.1799 + * default value for an argument to a procedure. Handles the following
1.1800 + * syntax:
1.1801 + *
1.1802 + * info patchlevel
1.1803 + *
1.1804 + * Results:
1.1805 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1806 + *
1.1807 + * Side effects:
1.1808 + * Returns a result in the interpreter's result object. If there is
1.1809 + * an error, the result is an error message.
1.1810 + *
1.1811 + *----------------------------------------------------------------------
1.1812 + */
1.1813 +
1.1814 +static int
1.1815 +InfoPatchLevelCmd(dummy, interp, objc, objv)
1.1816 + ClientData dummy; /* Not used. */
1.1817 + Tcl_Interp *interp; /* Current interpreter. */
1.1818 + int objc; /* Number of arguments. */
1.1819 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1820 +{
1.1821 + CONST char *patchlevel;
1.1822 +
1.1823 + if (objc != 2) {
1.1824 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1825 + return TCL_ERROR;
1.1826 + }
1.1827 +
1.1828 + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
1.1829 + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1.1830 + if (patchlevel != NULL) {
1.1831 + Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
1.1832 + return TCL_OK;
1.1833 + }
1.1834 + return TCL_ERROR;
1.1835 +}
1.1836 +
1.1837 +/*
1.1838 + *----------------------------------------------------------------------
1.1839 + *
1.1840 + * InfoProcsCmd --
1.1841 + *
1.1842 + * Called to implement the "info procs" command that returns the
1.1843 + * list of procedures in the interpreter that match an optional pattern.
1.1844 + * The pattern, if any, consists of an optional sequence of namespace
1.1845 + * names separated by "::" qualifiers, which is followed by a
1.1846 + * glob-style pattern that restricts which commands are returned.
1.1847 + * Handles the following syntax:
1.1848 + *
1.1849 + * info procs ?pattern?
1.1850 + *
1.1851 + * Results:
1.1852 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.1853 + *
1.1854 + * Side effects:
1.1855 + * Returns a result in the interpreter's result object. If there is
1.1856 + * an error, the result is an error message.
1.1857 + *
1.1858 + *----------------------------------------------------------------------
1.1859 + */
1.1860 +
1.1861 +static int
1.1862 +InfoProcsCmd(dummy, interp, objc, objv)
1.1863 + ClientData dummy; /* Not used. */
1.1864 + Tcl_Interp *interp; /* Current interpreter. */
1.1865 + int objc; /* Number of arguments. */
1.1866 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1867 +{
1.1868 + char *cmdName, *pattern;
1.1869 + CONST char *simplePattern;
1.1870 + Namespace *nsPtr;
1.1871 +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
1.1872 + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.1873 +#endif
1.1874 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.1875 + Tcl_Obj *listPtr, *elemObjPtr;
1.1876 + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
1.1877 + register Tcl_HashEntry *entryPtr;
1.1878 + Tcl_HashSearch search;
1.1879 + Command *cmdPtr, *realCmdPtr;
1.1880 +
1.1881 + /*
1.1882 + * Get the pattern and find the "effective namespace" in which to
1.1883 + * list procs.
1.1884 + */
1.1885 +
1.1886 + if (objc == 2) {
1.1887 + simplePattern = NULL;
1.1888 + nsPtr = currNsPtr;
1.1889 + specificNsInPattern = 0;
1.1890 + } else if (objc == 3) {
1.1891 + /*
1.1892 + * From the pattern, get the effective namespace and the simple
1.1893 + * pattern (no namespace qualifiers or ::'s) at the end. If an
1.1894 + * error was found while parsing the pattern, return it. Otherwise,
1.1895 + * if the namespace wasn't found, just leave nsPtr NULL: we will
1.1896 + * return an empty list since no commands there can be found.
1.1897 + */
1.1898 +
1.1899 + Namespace *dummy1NsPtr, *dummy2NsPtr;
1.1900 +
1.1901 + pattern = Tcl_GetString(objv[2]);
1.1902 + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
1.1903 + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
1.1904 + &simplePattern);
1.1905 +
1.1906 + if (nsPtr != NULL) { /* we successfully found the pattern's ns */
1.1907 + specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
1.1908 + }
1.1909 + } else {
1.1910 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.1911 + return TCL_ERROR;
1.1912 + }
1.1913 +
1.1914 + if (nsPtr == NULL) {
1.1915 + return TCL_OK;
1.1916 + }
1.1917 +
1.1918 + /*
1.1919 + * Scan through the effective namespace's command table and create a
1.1920 + * list with all procs that match the pattern. If a specific
1.1921 + * namespace was requested in the pattern, qualify the command names
1.1922 + * with the namespace name.
1.1923 + */
1.1924 +
1.1925 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.1926 +#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
1.1927 + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
1.1928 + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
1.1929 + if (entryPtr != NULL) {
1.1930 + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1.1931 +
1.1932 + if (!TclIsProc(cmdPtr)) {
1.1933 + realCmdPtr = (Command *)
1.1934 + TclGetOriginalCommand((Tcl_Command) cmdPtr);
1.1935 + if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
1.1936 + goto simpleProcOK;
1.1937 + }
1.1938 + } else {
1.1939 + simpleProcOK:
1.1940 + if (specificNsInPattern) {
1.1941 + elemObjPtr = Tcl_NewObj();
1.1942 + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
1.1943 + elemObjPtr);
1.1944 + } else {
1.1945 + elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
1.1946 + }
1.1947 + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1.1948 + }
1.1949 + }
1.1950 + } else
1.1951 +#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
1.1952 + {
1.1953 + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1.1954 + while (entryPtr != NULL) {
1.1955 + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
1.1956 + if ((simplePattern == NULL)
1.1957 + || Tcl_StringMatch(cmdName, simplePattern)) {
1.1958 + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1.1959 +
1.1960 + if (!TclIsProc(cmdPtr)) {
1.1961 + realCmdPtr = (Command *)
1.1962 + TclGetOriginalCommand((Tcl_Command) cmdPtr);
1.1963 + if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
1.1964 + goto procOK;
1.1965 + }
1.1966 + } else {
1.1967 + procOK:
1.1968 + if (specificNsInPattern) {
1.1969 + elemObjPtr = Tcl_NewObj();
1.1970 + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
1.1971 + elemObjPtr);
1.1972 + } else {
1.1973 + elemObjPtr = Tcl_NewStringObj(cmdName, -1);
1.1974 + }
1.1975 + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1.1976 + }
1.1977 + }
1.1978 + entryPtr = Tcl_NextHashEntry(&search);
1.1979 + }
1.1980 +
1.1981 + /*
1.1982 + * If the effective namespace isn't the global :: namespace, and a
1.1983 + * specific namespace wasn't requested in the pattern, then add in
1.1984 + * all global :: procs that match the simple pattern. Of course,
1.1985 + * we add in only those procs that aren't hidden by a proc in
1.1986 + * the effective namespace.
1.1987 + */
1.1988 +
1.1989 +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
1.1990 + /*
1.1991 + * If "info procs" worked like "info commands", returning the
1.1992 + * commands also seen in the global namespace, then you would
1.1993 + * include this code. As this could break backwards compatibilty
1.1994 + * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
1.1995 + * behavior slightly different.
1.1996 + */
1.1997 + if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1.1998 + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
1.1999 + while (entryPtr != NULL) {
1.2000 + cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
1.2001 + if ((simplePattern == NULL)
1.2002 + || Tcl_StringMatch(cmdName, simplePattern)) {
1.2003 + if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
1.2004 + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1.2005 + realCmdPtr = (Command *) TclGetOriginalCommand(
1.2006 + (Tcl_Command) cmdPtr);
1.2007 +
1.2008 + if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
1.2009 + && TclIsProc(realCmdPtr))) {
1.2010 + Tcl_ListObjAppendElement(interp, listPtr,
1.2011 + Tcl_NewStringObj(cmdName, -1));
1.2012 + }
1.2013 + }
1.2014 + }
1.2015 + entryPtr = Tcl_NextHashEntry(&search);
1.2016 + }
1.2017 + }
1.2018 +#endif
1.2019 + }
1.2020 +
1.2021 + Tcl_SetObjResult(interp, listPtr);
1.2022 + return TCL_OK;
1.2023 +}
1.2024 +
1.2025 +/*
1.2026 + *----------------------------------------------------------------------
1.2027 + *
1.2028 + * InfoScriptCmd --
1.2029 + *
1.2030 + * Called to implement the "info script" command that returns the
1.2031 + * script file that is currently being evaluated. Handles the
1.2032 + * following syntax:
1.2033 + *
1.2034 + * info script ?newName?
1.2035 + *
1.2036 + * If newName is specified, it will set that as the internal name.
1.2037 + *
1.2038 + * Results:
1.2039 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.2040 + *
1.2041 + * Side effects:
1.2042 + * Returns a result in the interpreter's result object. If there is
1.2043 + * an error, the result is an error message. It may change the
1.2044 + * internal script filename.
1.2045 + *
1.2046 + *----------------------------------------------------------------------
1.2047 + */
1.2048 +
1.2049 +static int
1.2050 +InfoScriptCmd(dummy, interp, objc, objv)
1.2051 + ClientData dummy; /* Not used. */
1.2052 + Tcl_Interp *interp; /* Current interpreter. */
1.2053 + int objc; /* Number of arguments. */
1.2054 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2055 +{
1.2056 + Interp *iPtr = (Interp *) interp;
1.2057 + if ((objc != 2) && (objc != 3)) {
1.2058 + Tcl_WrongNumArgs(interp, 2, objv, "?filename?");
1.2059 + return TCL_ERROR;
1.2060 + }
1.2061 +
1.2062 + if (objc == 3) {
1.2063 + if (iPtr->scriptFile != NULL) {
1.2064 + Tcl_DecrRefCount(iPtr->scriptFile);
1.2065 + }
1.2066 + iPtr->scriptFile = objv[2];
1.2067 + Tcl_IncrRefCount(iPtr->scriptFile);
1.2068 + }
1.2069 + if (iPtr->scriptFile != NULL) {
1.2070 + Tcl_SetObjResult(interp, iPtr->scriptFile);
1.2071 + }
1.2072 + return TCL_OK;
1.2073 +}
1.2074 +
1.2075 +/*
1.2076 + *----------------------------------------------------------------------
1.2077 + *
1.2078 + * InfoSharedlibCmd --
1.2079 + *
1.2080 + * Called to implement the "info sharedlibextension" command that
1.2081 + * returns the file extension used for shared libraries. Handles the
1.2082 + * following syntax:
1.2083 + *
1.2084 + * info sharedlibextension
1.2085 + *
1.2086 + * Results:
1.2087 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.2088 + *
1.2089 + * Side effects:
1.2090 + * Returns a result in the interpreter's result object. If there is
1.2091 + * an error, the result is an error message.
1.2092 + *
1.2093 + *----------------------------------------------------------------------
1.2094 + */
1.2095 +
1.2096 +static int
1.2097 +InfoSharedlibCmd(dummy, interp, objc, objv)
1.2098 + ClientData dummy; /* Not used. */
1.2099 + Tcl_Interp *interp; /* Current interpreter. */
1.2100 + int objc; /* Number of arguments. */
1.2101 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2102 +{
1.2103 + if (objc != 2) {
1.2104 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.2105 + return TCL_ERROR;
1.2106 + }
1.2107 +
1.2108 +#ifdef TCL_SHLIB_EXT
1.2109 + Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
1.2110 +#endif
1.2111 + return TCL_OK;
1.2112 +}
1.2113 +
1.2114 +/*
1.2115 + *----------------------------------------------------------------------
1.2116 + *
1.2117 + * InfoTclVersionCmd --
1.2118 + *
1.2119 + * Called to implement the "info tclversion" command that returns the
1.2120 + * version number for this Tcl library. Handles the following syntax:
1.2121 + *
1.2122 + * info tclversion
1.2123 + *
1.2124 + * Results:
1.2125 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.2126 + *
1.2127 + * Side effects:
1.2128 + * Returns a result in the interpreter's result object. If there is
1.2129 + * an error, the result is an error message.
1.2130 + *
1.2131 + *----------------------------------------------------------------------
1.2132 + */
1.2133 +
1.2134 +static int
1.2135 +InfoTclVersionCmd(dummy, interp, objc, objv)
1.2136 + ClientData dummy; /* Not used. */
1.2137 + Tcl_Interp *interp; /* Current interpreter. */
1.2138 + int objc; /* Number of arguments. */
1.2139 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2140 +{
1.2141 + CONST char *version;
1.2142 +
1.2143 + if (objc != 2) {
1.2144 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.2145 + return TCL_ERROR;
1.2146 + }
1.2147 +
1.2148 + version = Tcl_GetVar(interp, "tcl_version",
1.2149 + (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1.2150 + if (version != NULL) {
1.2151 + Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
1.2152 + return TCL_OK;
1.2153 + }
1.2154 + return TCL_ERROR;
1.2155 +}
1.2156 +
1.2157 +/*
1.2158 + *----------------------------------------------------------------------
1.2159 + *
1.2160 + * InfoVarsCmd --
1.2161 + *
1.2162 + * Called to implement the "info vars" command that returns the
1.2163 + * list of variables in the interpreter that match an optional pattern.
1.2164 + * The pattern, if any, consists of an optional sequence of namespace
1.2165 + * names separated by "::" qualifiers, which is followed by a
1.2166 + * glob-style pattern that restricts which variables are returned.
1.2167 + * Handles the following syntax:
1.2168 + *
1.2169 + * info vars ?pattern?
1.2170 + *
1.2171 + * Results:
1.2172 + * Returns TCL_OK if successful and TCL_ERROR if there is an error.
1.2173 + *
1.2174 + * Side effects:
1.2175 + * Returns a result in the interpreter's result object. If there is
1.2176 + * an error, the result is an error message.
1.2177 + *
1.2178 + *----------------------------------------------------------------------
1.2179 + */
1.2180 +
1.2181 +static int
1.2182 +InfoVarsCmd(dummy, interp, objc, objv)
1.2183 + ClientData dummy; /* Not used. */
1.2184 + Tcl_Interp *interp; /* Current interpreter. */
1.2185 + int objc; /* Number of arguments. */
1.2186 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2187 +{
1.2188 + Interp *iPtr = (Interp *) interp;
1.2189 + char *varName, *pattern;
1.2190 + CONST char *simplePattern;
1.2191 + register Tcl_HashEntry *entryPtr;
1.2192 + Tcl_HashSearch search;
1.2193 + Var *varPtr;
1.2194 + Namespace *nsPtr;
1.2195 + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.2196 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2197 + Tcl_Obj *listPtr, *elemObjPtr;
1.2198 + int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
1.2199 +
1.2200 + /*
1.2201 + * Get the pattern and find the "effective namespace" in which to
1.2202 + * list variables. We only use this effective namespace if there's
1.2203 + * no active Tcl procedure frame.
1.2204 + */
1.2205 +
1.2206 + if (objc == 2) {
1.2207 + simplePattern = NULL;
1.2208 + nsPtr = currNsPtr;
1.2209 + specificNsInPattern = 0;
1.2210 + } else if (objc == 3) {
1.2211 + /*
1.2212 + * From the pattern, get the effective namespace and the simple
1.2213 + * pattern (no namespace qualifiers or ::'s) at the end. If an
1.2214 + * error was found while parsing the pattern, return it. Otherwise,
1.2215 + * if the namespace wasn't found, just leave nsPtr NULL: we will
1.2216 + * return an empty list since no variables there can be found.
1.2217 + */
1.2218 +
1.2219 + Namespace *dummy1NsPtr, *dummy2NsPtr;
1.2220 +
1.2221 + pattern = Tcl_GetString(objv[2]);
1.2222 + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
1.2223 + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
1.2224 + &simplePattern);
1.2225 +
1.2226 + if (nsPtr != NULL) { /* we successfully found the pattern's ns */
1.2227 + specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
1.2228 + }
1.2229 + } else {
1.2230 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1.2231 + return TCL_ERROR;
1.2232 + }
1.2233 +
1.2234 + /*
1.2235 + * If the namespace specified in the pattern wasn't found, just return.
1.2236 + */
1.2237 +
1.2238 + if (nsPtr == NULL) {
1.2239 + return TCL_OK;
1.2240 + }
1.2241 +
1.2242 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.2243 +
1.2244 + if ((iPtr->varFramePtr == NULL)
1.2245 + || !iPtr->varFramePtr->isProcCallFrame
1.2246 + || specificNsInPattern) {
1.2247 + /*
1.2248 + * There is no frame pointer, the frame pointer was pushed only
1.2249 + * to activate a namespace, or we are in a procedure call frame
1.2250 + * but a specific namespace was specified. Create a list containing
1.2251 + * only the variables in the effective namespace's variable table.
1.2252 + */
1.2253 +
1.2254 + if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
1.2255 + /*
1.2256 + * If we can just do hash lookups, that simplifies things
1.2257 + * a lot.
1.2258 + */
1.2259 +
1.2260 + entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
1.2261 + if (entryPtr != NULL) {
1.2262 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.2263 + if (!TclIsVarUndefined(varPtr)
1.2264 + || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1.2265 + if (specificNsInPattern) {
1.2266 + elemObjPtr = Tcl_NewObj();
1.2267 + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
1.2268 + elemObjPtr);
1.2269 + } else {
1.2270 + elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
1.2271 + }
1.2272 + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1.2273 + }
1.2274 + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1.2275 + entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
1.2276 + simplePattern);
1.2277 + if (entryPtr != NULL) {
1.2278 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.2279 + if (!TclIsVarUndefined(varPtr)
1.2280 + || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1.2281 + Tcl_ListObjAppendElement(interp, listPtr,
1.2282 + Tcl_NewStringObj(simplePattern, -1));
1.2283 + }
1.2284 + }
1.2285 + }
1.2286 + } else {
1.2287 + /*
1.2288 + * Have to scan the tables of variables.
1.2289 + */
1.2290 +
1.2291 + entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
1.2292 + while (entryPtr != NULL) {
1.2293 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.2294 + if (!TclIsVarUndefined(varPtr)
1.2295 + || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1.2296 + varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
1.2297 + if ((simplePattern == NULL)
1.2298 + || Tcl_StringMatch(varName, simplePattern)) {
1.2299 + if (specificNsInPattern) {
1.2300 + elemObjPtr = Tcl_NewObj();
1.2301 + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
1.2302 + elemObjPtr);
1.2303 + } else {
1.2304 + elemObjPtr = Tcl_NewStringObj(varName, -1);
1.2305 + }
1.2306 + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1.2307 + }
1.2308 + }
1.2309 + entryPtr = Tcl_NextHashEntry(&search);
1.2310 + }
1.2311 +
1.2312 + /*
1.2313 + * If the effective namespace isn't the global ::
1.2314 + * namespace, and a specific namespace wasn't requested in
1.2315 + * the pattern (i.e., the pattern only specifies variable
1.2316 + * names), then add in all global :: variables that match
1.2317 + * the simple pattern. Of course, add in only those
1.2318 + * variables that aren't hidden by a variable in the
1.2319 + * effective namespace.
1.2320 + */
1.2321 +
1.2322 + if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1.2323 + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
1.2324 + while (entryPtr != NULL) {
1.2325 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.2326 + if (!TclIsVarUndefined(varPtr)
1.2327 + || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1.2328 + varName = Tcl_GetHashKey(&globalNsPtr->varTable,
1.2329 + entryPtr);
1.2330 + if ((simplePattern == NULL)
1.2331 + || Tcl_StringMatch(varName, simplePattern)) {
1.2332 + if (Tcl_FindHashEntry(&nsPtr->varTable,
1.2333 + varName) == NULL) {
1.2334 + Tcl_ListObjAppendElement(interp, listPtr,
1.2335 + Tcl_NewStringObj(varName, -1));
1.2336 + }
1.2337 + }
1.2338 + }
1.2339 + entryPtr = Tcl_NextHashEntry(&search);
1.2340 + }
1.2341 + }
1.2342 + }
1.2343 + } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
1.2344 + AppendLocals(interp, listPtr, simplePattern, 1);
1.2345 + }
1.2346 +
1.2347 + Tcl_SetObjResult(interp, listPtr);
1.2348 + return TCL_OK;
1.2349 +}
1.2350 +
1.2351 +/*
1.2352 + *----------------------------------------------------------------------
1.2353 + *
1.2354 + * Tcl_JoinObjCmd --
1.2355 + *
1.2356 + * This procedure is invoked to process the "join" Tcl command.
1.2357 + * See the user documentation for details on what it does.
1.2358 + *
1.2359 + * Results:
1.2360 + * A standard Tcl object result.
1.2361 + *
1.2362 + * Side effects:
1.2363 + * See the user documentation.
1.2364 + *
1.2365 + *----------------------------------------------------------------------
1.2366 + */
1.2367 +
1.2368 + /* ARGSUSED */
1.2369 +int
1.2370 +Tcl_JoinObjCmd(dummy, interp, objc, objv)
1.2371 + ClientData dummy; /* Not used. */
1.2372 + Tcl_Interp *interp; /* Current interpreter. */
1.2373 + int objc; /* Number of arguments. */
1.2374 + Tcl_Obj *CONST objv[]; /* The argument objects. */
1.2375 +{
1.2376 + char *joinString, *bytes;
1.2377 + int joinLength, listLen, length, i, result;
1.2378 + Tcl_Obj **elemPtrs;
1.2379 + Tcl_Obj *resObjPtr;
1.2380 +
1.2381 + if (objc == 2) {
1.2382 + joinString = " ";
1.2383 + joinLength = 1;
1.2384 + } else if (objc == 3) {
1.2385 + joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
1.2386 + } else {
1.2387 + Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
1.2388 + return TCL_ERROR;
1.2389 + }
1.2390 +
1.2391 + /*
1.2392 + * Make sure the list argument is a list object and get its length and
1.2393 + * a pointer to its array of element pointers.
1.2394 + */
1.2395 +
1.2396 + result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
1.2397 + if (result != TCL_OK) {
1.2398 + return result;
1.2399 + }
1.2400 +
1.2401 + /*
1.2402 + * Now concatenate strings to form the "joined" result. We append
1.2403 + * directly into the interpreter's result object.
1.2404 + */
1.2405 +
1.2406 + resObjPtr = Tcl_GetObjResult(interp);
1.2407 +
1.2408 + for (i = 0; i < listLen; i++) {
1.2409 + bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
1.2410 + if (i > 0) {
1.2411 + Tcl_AppendToObj(resObjPtr, joinString, joinLength);
1.2412 + }
1.2413 + Tcl_AppendToObj(resObjPtr, bytes, length);
1.2414 + }
1.2415 + return TCL_OK;
1.2416 +}
1.2417 +
1.2418 +/*
1.2419 + *----------------------------------------------------------------------
1.2420 + *
1.2421 + * Tcl_LindexObjCmd --
1.2422 + *
1.2423 + * This object-based procedure is invoked to process the "lindex" Tcl
1.2424 + * command. See the user documentation for details on what it does.
1.2425 + *
1.2426 + * Results:
1.2427 + * A standard Tcl object result.
1.2428 + *
1.2429 + * Side effects:
1.2430 + * See the user documentation.
1.2431 + *
1.2432 + *----------------------------------------------------------------------
1.2433 + */
1.2434 +
1.2435 + /* ARGSUSED */
1.2436 +int
1.2437 +Tcl_LindexObjCmd(dummy, interp, objc, objv)
1.2438 + ClientData dummy; /* Not used. */
1.2439 + Tcl_Interp *interp; /* Current interpreter. */
1.2440 + int objc; /* Number of arguments. */
1.2441 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2442 +{
1.2443 +
1.2444 + Tcl_Obj *elemPtr; /* Pointer to the element being extracted */
1.2445 +
1.2446 + if (objc < 2) {
1.2447 + Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
1.2448 + return TCL_ERROR;
1.2449 + }
1.2450 +
1.2451 + /*
1.2452 + * If objc == 3, then objv[ 2 ] may be either a single index or
1.2453 + * a list of indices: go to TclLindexList to determine which.
1.2454 + * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
1.2455 + * single indices and processed as such in TclLindexFlat.
1.2456 + */
1.2457 +
1.2458 + if ( objc == 3 ) {
1.2459 +
1.2460 + elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );
1.2461 +
1.2462 + } else {
1.2463 +
1.2464 + elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );
1.2465 +
1.2466 + }
1.2467 +
1.2468 + /*
1.2469 + * Set the interpreter's object result to the last element extracted
1.2470 + */
1.2471 +
1.2472 + if ( elemPtr == NULL ) {
1.2473 + return TCL_ERROR;
1.2474 + } else {
1.2475 + Tcl_SetObjResult(interp, elemPtr);
1.2476 + Tcl_DecrRefCount( elemPtr );
1.2477 + return TCL_OK;
1.2478 + }
1.2479 +}
1.2480 +
1.2481 +/*
1.2482 + *----------------------------------------------------------------------
1.2483 + *
1.2484 + * TclLindexList --
1.2485 + *
1.2486 + * This procedure handles the 'lindex' command when objc==3.
1.2487 + *
1.2488 + * Results:
1.2489 + * Returns a pointer to the object extracted, or NULL if an
1.2490 + * error occurred.
1.2491 + *
1.2492 + * Side effects:
1.2493 + * None.
1.2494 + *
1.2495 + * If objv[1] can be parsed as a list, TclLindexList handles extraction
1.2496 + * of the desired element locally. Otherwise, it invokes
1.2497 + * TclLindexFlat to treat objv[1] as a scalar.
1.2498 + *
1.2499 + * The reference count of the returned object includes one reference
1.2500 + * corresponding to the pointer returned. Thus, the calling code will
1.2501 + * usually do something like:
1.2502 + * Tcl_SetObjResult( interp, result );
1.2503 + * Tcl_DecrRefCount( result );
1.2504 + *
1.2505 + *----------------------------------------------------------------------
1.2506 + */
1.2507 +
1.2508 +Tcl_Obj *
1.2509 +TclLindexList( interp, listPtr, argPtr )
1.2510 + Tcl_Interp* interp; /* Tcl interpreter */
1.2511 + Tcl_Obj* listPtr; /* List being unpacked */
1.2512 + Tcl_Obj* argPtr; /* Index or index list */
1.2513 +{
1.2514 +
1.2515 + Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */
1.2516 + int listLen; /* Length of the list being manipulated. */
1.2517 + int index; /* Index into the list */
1.2518 + int result; /* Result returned from a Tcl library call */
1.2519 + int i; /* Current index number */
1.2520 + Tcl_Obj** indices; /* Array of list indices */
1.2521 + int indexCount; /* Size of the array of list indices */
1.2522 + Tcl_Obj* oldListPtr; /* Temp location to preserve the list
1.2523 + * pointer when replacing it with a sublist */
1.2524 +
1.2525 + /*
1.2526 + * Determine whether argPtr designates a list or a single index.
1.2527 + * We have to be careful about the order of the checks to avoid
1.2528 + * repeated shimmering; see TIP#22 and TIP#33 for the details.
1.2529 + */
1.2530 +
1.2531 + if ( argPtr->typePtr != &tclListType
1.2532 + && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {
1.2533 +
1.2534 + /*
1.2535 + * argPtr designates a single index.
1.2536 + */
1.2537 +
1.2538 + return TclLindexFlat( interp, listPtr, 1, &argPtr );
1.2539 +
1.2540 + } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
1.2541 + != TCL_OK ) {
1.2542 +
1.2543 + /*
1.2544 + * argPtr designates something that is neither an index nor a
1.2545 + * well-formed list. Report the error via TclLindexFlat.
1.2546 + */
1.2547 +
1.2548 + return TclLindexFlat( interp, listPtr, 1, &argPtr );
1.2549 + }
1.2550 +
1.2551 + /*
1.2552 + * Record the reference to the list that we are maintaining in
1.2553 + * the activation record.
1.2554 + */
1.2555 +
1.2556 + Tcl_IncrRefCount( listPtr );
1.2557 +
1.2558 + /*
1.2559 + * argPtr designates a list, and the 'else if' above has parsed it
1.2560 + * into indexCount and indices.
1.2561 + */
1.2562 +
1.2563 + for ( i = 0; i < indexCount; ++i ) {
1.2564 +
1.2565 + /*
1.2566 + * Convert the current listPtr to a list if necessary.
1.2567 + */
1.2568 +
1.2569 + result = Tcl_ListObjGetElements( interp, listPtr,
1.2570 + &listLen, &elemPtrs);
1.2571 + if (result != TCL_OK) {
1.2572 + Tcl_DecrRefCount( listPtr );
1.2573 + return NULL;
1.2574 + }
1.2575 +
1.2576 + /*
1.2577 + * Get the index from indices[ i ]
1.2578 + */
1.2579 +
1.2580 + result = TclGetIntForIndex( interp, indices[ i ],
1.2581 + /*endValue*/ (listLen - 1),
1.2582 + &index );
1.2583 + if ( result != TCL_OK ) {
1.2584 + /*
1.2585 + * Index could not be parsed
1.2586 + */
1.2587 +
1.2588 + Tcl_DecrRefCount( listPtr );
1.2589 + return NULL;
1.2590 +
1.2591 + } else if ( index < 0
1.2592 + || index >= listLen ) {
1.2593 + /*
1.2594 + * Index is out of range
1.2595 + */
1.2596 + Tcl_DecrRefCount( listPtr );
1.2597 + listPtr = Tcl_NewObj();
1.2598 + Tcl_IncrRefCount( listPtr );
1.2599 + return listPtr;
1.2600 + }
1.2601 +
1.2602 + /*
1.2603 + * Make sure listPtr still refers to a list object.
1.2604 + * If it shared a Tcl_Obj structure with the arguments, then
1.2605 + * it might have just been converted to something else.
1.2606 + */
1.2607 +
1.2608 + if (listPtr->typePtr != &tclListType) {
1.2609 + result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
1.2610 + &elemPtrs);
1.2611 + if (result != TCL_OK) {
1.2612 + Tcl_DecrRefCount( listPtr );
1.2613 + return NULL;
1.2614 + }
1.2615 + }
1.2616 +
1.2617 + /*
1.2618 + * Extract the pointer to the appropriate element
1.2619 + */
1.2620 +
1.2621 + oldListPtr = listPtr;
1.2622 + listPtr = elemPtrs[ index ];
1.2623 + Tcl_IncrRefCount( listPtr );
1.2624 + Tcl_DecrRefCount( oldListPtr );
1.2625 +
1.2626 + /*
1.2627 + * The work we did above may have caused the internal rep
1.2628 + * of *argPtr to change to something else. Get it back.
1.2629 + */
1.2630 +
1.2631 + result = Tcl_ListObjGetElements( interp, argPtr,
1.2632 + &indexCount, &indices );
1.2633 + if ( result != TCL_OK ) {
1.2634 + /*
1.2635 + * This can't happen unless some extension corrupted a Tcl_Obj.
1.2636 + */
1.2637 + Tcl_DecrRefCount( listPtr );
1.2638 + return NULL;
1.2639 + }
1.2640 +
1.2641 + } /* end for */
1.2642 +
1.2643 + /*
1.2644 + * Return the last object extracted. Its reference count will include
1.2645 + * the reference being returned.
1.2646 + */
1.2647 +
1.2648 + return listPtr;
1.2649 +}
1.2650 +
1.2651 +/*
1.2652 + *----------------------------------------------------------------------
1.2653 + *
1.2654 + * TclLindexFlat --
1.2655 + *
1.2656 + * This procedure handles the 'lindex' command, given that the
1.2657 + * arguments to the command are known to be a flat list.
1.2658 + *
1.2659 + * Results:
1.2660 + * Returns a standard Tcl result.
1.2661 + *
1.2662 + * Side effects:
1.2663 + * None.
1.2664 + *
1.2665 + * This procedure is called from either tclExecute.c or
1.2666 + * Tcl_LindexObjCmd whenever either is presented with
1.2667 + * objc == 2 or objc >= 4. It is also called from TclLindexList
1.2668 + * for the objc==3 case once it is determined that objv[2] cannot
1.2669 + * be parsed as a list.
1.2670 + *
1.2671 + *----------------------------------------------------------------------
1.2672 + */
1.2673 +
1.2674 +Tcl_Obj *
1.2675 +TclLindexFlat( interp, listPtr, indexCount, indexArray )
1.2676 + Tcl_Interp* interp; /* Tcl interpreter */
1.2677 + Tcl_Obj* listPtr; /* Tcl object representing the list */
1.2678 + int indexCount; /* Count of indices */
1.2679 + Tcl_Obj* CONST indexArray[];
1.2680 + /* Array of pointers to Tcl objects
1.2681 + * representing the indices in the
1.2682 + * list */
1.2683 +{
1.2684 +
1.2685 + int i; /* Current list index */
1.2686 + int result; /* Result of Tcl library calls */
1.2687 + int listLen; /* Length of the current list being
1.2688 + * processed */
1.2689 + Tcl_Obj** elemPtrs; /* Array of pointers to the elements
1.2690 + * of the current list */
1.2691 + int index; /* Parsed version of the current element
1.2692 + * of indexArray */
1.2693 + Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that
1.2694 + * its ref count can be decremented. */
1.2695 +
1.2696 + /*
1.2697 + * Record the reference to the 'listPtr' object that we are
1.2698 + * maintaining in the C activation record.
1.2699 + */
1.2700 +
1.2701 + Tcl_IncrRefCount( listPtr );
1.2702 +
1.2703 + for ( i = 0; i < indexCount; ++i ) {
1.2704 +
1.2705 + /*
1.2706 + * Convert the current listPtr to a list if necessary.
1.2707 + */
1.2708 +
1.2709 + result = Tcl_ListObjGetElements(interp, listPtr,
1.2710 + &listLen, &elemPtrs);
1.2711 + if (result != TCL_OK) {
1.2712 + Tcl_DecrRefCount( listPtr );
1.2713 + return NULL;
1.2714 + }
1.2715 +
1.2716 + /*
1.2717 + * Get the index from objv[i]
1.2718 + */
1.2719 +
1.2720 + result = TclGetIntForIndex( interp, indexArray[ i ],
1.2721 + /*endValue*/ (listLen - 1),
1.2722 + &index );
1.2723 + if ( result != TCL_OK ) {
1.2724 +
1.2725 + /* Index could not be parsed */
1.2726 +
1.2727 + Tcl_DecrRefCount( listPtr );
1.2728 + return NULL;
1.2729 +
1.2730 + } else if ( index < 0
1.2731 + || index >= listLen ) {
1.2732 +
1.2733 + /*
1.2734 + * Index is out of range
1.2735 + */
1.2736 +
1.2737 + Tcl_DecrRefCount( listPtr );
1.2738 + listPtr = Tcl_NewObj();
1.2739 + Tcl_IncrRefCount( listPtr );
1.2740 + return listPtr;
1.2741 + }
1.2742 +
1.2743 + /*
1.2744 + * Make sure listPtr still refers to a list object.
1.2745 + * It might have been converted to something else above
1.2746 + * if objv[1] overlaps with one of the other parameters.
1.2747 + */
1.2748 +
1.2749 + if (listPtr->typePtr != &tclListType) {
1.2750 + result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
1.2751 + &elemPtrs);
1.2752 + if (result != TCL_OK) {
1.2753 + Tcl_DecrRefCount( listPtr );
1.2754 + return NULL;
1.2755 + }
1.2756 + }
1.2757 +
1.2758 + /*
1.2759 + * Extract the pointer to the appropriate element
1.2760 + */
1.2761 +
1.2762 + oldListPtr = listPtr;
1.2763 + listPtr = elemPtrs[ index ];
1.2764 + Tcl_IncrRefCount( listPtr );
1.2765 + Tcl_DecrRefCount( oldListPtr );
1.2766 +
1.2767 + }
1.2768 +
1.2769 + return listPtr;
1.2770 +
1.2771 +}
1.2772 +
1.2773 +/*
1.2774 + *----------------------------------------------------------------------
1.2775 + *
1.2776 + * Tcl_LinsertObjCmd --
1.2777 + *
1.2778 + * This object-based procedure is invoked to process the "linsert" Tcl
1.2779 + * command. See the user documentation for details on what it does.
1.2780 + *
1.2781 + * Results:
1.2782 + * A new Tcl list object formed by inserting zero or more elements
1.2783 + * into a list.
1.2784 + *
1.2785 + * Side effects:
1.2786 + * See the user documentation.
1.2787 + *
1.2788 + *----------------------------------------------------------------------
1.2789 + */
1.2790 +
1.2791 + /* ARGSUSED */
1.2792 +int
1.2793 +Tcl_LinsertObjCmd(dummy, interp, objc, objv)
1.2794 + ClientData dummy; /* Not used. */
1.2795 + Tcl_Interp *interp; /* Current interpreter. */
1.2796 + register int objc; /* Number of arguments. */
1.2797 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2798 +{
1.2799 + Tcl_Obj *listPtr;
1.2800 + int index, isDuplicate, len, result;
1.2801 +
1.2802 + if (objc < 4) {
1.2803 + Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
1.2804 + return TCL_ERROR;
1.2805 + }
1.2806 +
1.2807 + result = Tcl_ListObjLength(interp, objv[1], &len);
1.2808 + if (result != TCL_OK) {
1.2809 + return result;
1.2810 + }
1.2811 +
1.2812 + /*
1.2813 + * Get the index. "end" is interpreted to be the index after the last
1.2814 + * element, such that using it will cause any inserted elements to be
1.2815 + * appended to the list.
1.2816 + */
1.2817 +
1.2818 + result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
1.2819 + if (result != TCL_OK) {
1.2820 + return result;
1.2821 + }
1.2822 + if (index > len) {
1.2823 + index = len;
1.2824 + }
1.2825 +
1.2826 + /*
1.2827 + * If the list object is unshared we can modify it directly. Otherwise
1.2828 + * we create a copy to modify: this is "copy on write".
1.2829 + */
1.2830 +
1.2831 + listPtr = objv[1];
1.2832 + isDuplicate = 0;
1.2833 + if (Tcl_IsShared(listPtr)) {
1.2834 + listPtr = Tcl_DuplicateObj(listPtr);
1.2835 + isDuplicate = 1;
1.2836 + }
1.2837 +
1.2838 + if ((objc == 4) && (index == len)) {
1.2839 + /*
1.2840 + * Special case: insert one element at the end of the list.
1.2841 + */
1.2842 + result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
1.2843 + } else if (objc > 3) {
1.2844 + result = Tcl_ListObjReplace(interp, listPtr, index, 0,
1.2845 + (objc-3), &(objv[3]));
1.2846 + }
1.2847 + if (result != TCL_OK) {
1.2848 + if (isDuplicate) {
1.2849 + Tcl_DecrRefCount(listPtr); /* free unneeded obj */
1.2850 + }
1.2851 + return result;
1.2852 + }
1.2853 +
1.2854 + /*
1.2855 + * Set the interpreter's object result.
1.2856 + */
1.2857 +
1.2858 + Tcl_SetObjResult(interp, listPtr);
1.2859 + return TCL_OK;
1.2860 +}
1.2861 +
1.2862 +/*
1.2863 + *----------------------------------------------------------------------
1.2864 + *
1.2865 + * Tcl_ListObjCmd --
1.2866 + *
1.2867 + * This procedure is invoked to process the "list" Tcl command.
1.2868 + * See the user documentation for details on what it does.
1.2869 + *
1.2870 + * Results:
1.2871 + * A standard Tcl object result.
1.2872 + *
1.2873 + * Side effects:
1.2874 + * See the user documentation.
1.2875 + *
1.2876 + *----------------------------------------------------------------------
1.2877 + */
1.2878 +
1.2879 + /* ARGSUSED */
1.2880 +int
1.2881 +Tcl_ListObjCmd(dummy, interp, objc, objv)
1.2882 + ClientData dummy; /* Not used. */
1.2883 + Tcl_Interp *interp; /* Current interpreter. */
1.2884 + register int objc; /* Number of arguments. */
1.2885 + register Tcl_Obj *CONST objv[]; /* The argument objects. */
1.2886 +{
1.2887 + /*
1.2888 + * If there are no list elements, the result is an empty object.
1.2889 + * Otherwise modify the interpreter's result object to be a list object.
1.2890 + */
1.2891 +
1.2892 + if (objc > 1) {
1.2893 + Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
1.2894 + }
1.2895 + return TCL_OK;
1.2896 +}
1.2897 +
1.2898 +/*
1.2899 + *----------------------------------------------------------------------
1.2900 + *
1.2901 + * Tcl_LlengthObjCmd --
1.2902 + *
1.2903 + * This object-based procedure is invoked to process the "llength" Tcl
1.2904 + * command. See the user documentation for details on what it does.
1.2905 + *
1.2906 + * Results:
1.2907 + * A standard Tcl object result.
1.2908 + *
1.2909 + * Side effects:
1.2910 + * See the user documentation.
1.2911 + *
1.2912 + *----------------------------------------------------------------------
1.2913 + */
1.2914 +
1.2915 + /* ARGSUSED */
1.2916 +int
1.2917 +Tcl_LlengthObjCmd(dummy, interp, objc, objv)
1.2918 + ClientData dummy; /* Not used. */
1.2919 + Tcl_Interp *interp; /* Current interpreter. */
1.2920 + int objc; /* Number of arguments. */
1.2921 + register Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2922 +{
1.2923 + int listLen, result;
1.2924 +
1.2925 + if (objc != 2) {
1.2926 + Tcl_WrongNumArgs(interp, 1, objv, "list");
1.2927 + return TCL_ERROR;
1.2928 + }
1.2929 +
1.2930 + result = Tcl_ListObjLength(interp, objv[1], &listLen);
1.2931 + if (result != TCL_OK) {
1.2932 + return result;
1.2933 + }
1.2934 +
1.2935 + /*
1.2936 + * Set the interpreter's object result to an integer object holding the
1.2937 + * length.
1.2938 + */
1.2939 +
1.2940 + Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
1.2941 + return TCL_OK;
1.2942 +}
1.2943 +
1.2944 +/*
1.2945 + *----------------------------------------------------------------------
1.2946 + *
1.2947 + * Tcl_LrangeObjCmd --
1.2948 + *
1.2949 + * This procedure is invoked to process the "lrange" Tcl command.
1.2950 + * See the user documentation for details on what it does.
1.2951 + *
1.2952 + * Results:
1.2953 + * A standard Tcl object result.
1.2954 + *
1.2955 + * Side effects:
1.2956 + * See the user documentation.
1.2957 + *
1.2958 + *----------------------------------------------------------------------
1.2959 + */
1.2960 +
1.2961 + /* ARGSUSED */
1.2962 +int
1.2963 +Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
1.2964 + ClientData notUsed; /* Not used. */
1.2965 + Tcl_Interp *interp; /* Current interpreter. */
1.2966 + int objc; /* Number of arguments. */
1.2967 + register Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2968 +{
1.2969 + Tcl_Obj *listPtr;
1.2970 + Tcl_Obj **elemPtrs;
1.2971 + int listLen, first, last, numElems, result;
1.2972 +
1.2973 + if (objc != 4) {
1.2974 + Tcl_WrongNumArgs(interp, 1, objv, "list first last");
1.2975 + return TCL_ERROR;
1.2976 + }
1.2977 +
1.2978 + /*
1.2979 + * Make sure the list argument is a list object and get its length and
1.2980 + * a pointer to its array of element pointers.
1.2981 + */
1.2982 +
1.2983 + listPtr = objv[1];
1.2984 + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
1.2985 + if (result != TCL_OK) {
1.2986 + return result;
1.2987 + }
1.2988 +
1.2989 + /*
1.2990 + * Get the first and last indexes.
1.2991 + */
1.2992 +
1.2993 + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
1.2994 + &first);
1.2995 + if (result != TCL_OK) {
1.2996 + return result;
1.2997 + }
1.2998 + if (first < 0) {
1.2999 + first = 0;
1.3000 + }
1.3001 +
1.3002 + result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
1.3003 + &last);
1.3004 + if (result != TCL_OK) {
1.3005 + return result;
1.3006 + }
1.3007 + if (last >= listLen) {
1.3008 + last = (listLen - 1);
1.3009 + }
1.3010 +
1.3011 + if (first > last) {
1.3012 + return TCL_OK; /* the result is an empty object */
1.3013 + }
1.3014 +
1.3015 + /*
1.3016 + * Make sure listPtr still refers to a list object. It might have been
1.3017 + * converted to an int above if the argument objects were shared.
1.3018 + */
1.3019 +
1.3020 + if (listPtr->typePtr != &tclListType) {
1.3021 + result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
1.3022 + &elemPtrs);
1.3023 + if (result != TCL_OK) {
1.3024 + return result;
1.3025 + }
1.3026 + }
1.3027 +
1.3028 + /*
1.3029 + * Extract a range of fields. We modify the interpreter's result object
1.3030 + * to be a list object containing the specified elements.
1.3031 + */
1.3032 +
1.3033 + numElems = (last - first + 1);
1.3034 + Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
1.3035 + return TCL_OK;
1.3036 +}
1.3037 +
1.3038 +/*
1.3039 + *----------------------------------------------------------------------
1.3040 + *
1.3041 + * Tcl_LreplaceObjCmd --
1.3042 + *
1.3043 + * This object-based procedure is invoked to process the "lreplace"
1.3044 + * Tcl command. See the user documentation for details on what it does.
1.3045 + *
1.3046 + * Results:
1.3047 + * A new Tcl list object formed by replacing zero or more elements of
1.3048 + * a list.
1.3049 + *
1.3050 + * Side effects:
1.3051 + * See the user documentation.
1.3052 + *
1.3053 + *----------------------------------------------------------------------
1.3054 + */
1.3055 +
1.3056 + /* ARGSUSED */
1.3057 +int
1.3058 +Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
1.3059 + ClientData dummy; /* Not used. */
1.3060 + Tcl_Interp *interp; /* Current interpreter. */
1.3061 + int objc; /* Number of arguments. */
1.3062 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3063 +{
1.3064 + register Tcl_Obj *listPtr;
1.3065 + int isDuplicate, first, last, listLen, numToDelete, result;
1.3066 +
1.3067 + if (objc < 4) {
1.3068 + Tcl_WrongNumArgs(interp, 1, objv,
1.3069 + "list first last ?element element ...?");
1.3070 + return TCL_ERROR;
1.3071 + }
1.3072 +
1.3073 + result = Tcl_ListObjLength(interp, objv[1], &listLen);
1.3074 + if (result != TCL_OK) {
1.3075 + return result;
1.3076 + }
1.3077 +
1.3078 + /*
1.3079 + * Get the first and last indexes. "end" is interpreted to be the index
1.3080 + * for the last element, such that using it will cause that element to
1.3081 + * be included for deletion.
1.3082 + */
1.3083 +
1.3084 + result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
1.3085 + if (result != TCL_OK) {
1.3086 + return result;
1.3087 + }
1.3088 +
1.3089 + result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
1.3090 + if (result != TCL_OK) {
1.3091 + return result;
1.3092 + }
1.3093 +
1.3094 + if (first < 0) {
1.3095 + first = 0;
1.3096 + }
1.3097 +
1.3098 + /*
1.3099 + * Complain if the user asked for a start element that is greater than the
1.3100 + * list length. This won't ever trigger for the "end*" case as that will
1.3101 + * be properly constrained by TclGetIntForIndex because we use listLen-1
1.3102 + * (to allow for replacing the last elem).
1.3103 + */
1.3104 +
1.3105 + if ((first >= listLen) && (listLen > 0)) {
1.3106 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.3107 + "list doesn't contain element ",
1.3108 + Tcl_GetString(objv[2]), (int *) NULL);
1.3109 + return TCL_ERROR;
1.3110 + }
1.3111 + if (last >= listLen) {
1.3112 + last = (listLen - 1);
1.3113 + }
1.3114 + if (first <= last) {
1.3115 + numToDelete = (last - first + 1);
1.3116 + } else {
1.3117 + numToDelete = 0;
1.3118 + }
1.3119 +
1.3120 + /*
1.3121 + * If the list object is unshared we can modify it directly, otherwise
1.3122 + * we create a copy to modify: this is "copy on write".
1.3123 + */
1.3124 +
1.3125 + listPtr = objv[1];
1.3126 + isDuplicate = 0;
1.3127 + if (Tcl_IsShared(listPtr)) {
1.3128 + listPtr = Tcl_DuplicateObj(listPtr);
1.3129 + isDuplicate = 1;
1.3130 + }
1.3131 + if (objc > 4) {
1.3132 + result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
1.3133 + (objc-4), &(objv[4]));
1.3134 + } else {
1.3135 + result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
1.3136 + 0, NULL);
1.3137 + }
1.3138 + if (result != TCL_OK) {
1.3139 + if (isDuplicate) {
1.3140 + Tcl_DecrRefCount(listPtr); /* free unneeded obj */
1.3141 + }
1.3142 + return result;
1.3143 + }
1.3144 +
1.3145 + /*
1.3146 + * Set the interpreter's object result.
1.3147 + */
1.3148 +
1.3149 + Tcl_SetObjResult(interp, listPtr);
1.3150 + return TCL_OK;
1.3151 +}
1.3152 +
1.3153 +/*
1.3154 + *----------------------------------------------------------------------
1.3155 + *
1.3156 + * Tcl_LsearchObjCmd --
1.3157 + *
1.3158 + * This procedure is invoked to process the "lsearch" Tcl command.
1.3159 + * See the user documentation for details on what it does.
1.3160 + *
1.3161 + * Results:
1.3162 + * A standard Tcl result.
1.3163 + *
1.3164 + * Side effects:
1.3165 + * See the user documentation.
1.3166 + *
1.3167 + *----------------------------------------------------------------------
1.3168 + */
1.3169 +
1.3170 +int
1.3171 +Tcl_LsearchObjCmd(clientData, interp, objc, objv)
1.3172 + ClientData clientData; /* Not used. */
1.3173 + Tcl_Interp *interp; /* Current interpreter. */
1.3174 + int objc; /* Number of arguments. */
1.3175 + Tcl_Obj *CONST objv[]; /* Argument values. */
1.3176 +{
1.3177 + char *bytes, *patternBytes;
1.3178 + int i, match, mode, index, result, listc, length, elemLen;
1.3179 + int dataType, isIncreasing, lower, upper, patInt, objInt;
1.3180 + int offset, allMatches, inlineReturn, negatedMatch;
1.3181 + double patDouble, objDouble;
1.3182 + Tcl_Obj *patObj, **listv, *listPtr, *startPtr;
1.3183 + Tcl_RegExp regexp = NULL;
1.3184 + static CONST char *options[] = {
1.3185 + "-all", "-ascii", "-decreasing", "-dictionary",
1.3186 + "-exact", "-glob", "-increasing", "-inline",
1.3187 + "-integer", "-not", "-real", "-regexp",
1.3188 + "-sorted", "-start", NULL
1.3189 + };
1.3190 + enum options {
1.3191 + LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
1.3192 + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE,
1.3193 + LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP,
1.3194 + LSEARCH_SORTED, LSEARCH_START
1.3195 + };
1.3196 + enum datatypes {
1.3197 + ASCII, DICTIONARY, INTEGER, REAL
1.3198 + };
1.3199 + enum modes {
1.3200 + EXACT, GLOB, REGEXP, SORTED
1.3201 + };
1.3202 +
1.3203 + mode = GLOB;
1.3204 + dataType = ASCII;
1.3205 + isIncreasing = 1;
1.3206 + allMatches = 0;
1.3207 + inlineReturn = 0;
1.3208 + negatedMatch = 0;
1.3209 + listPtr = NULL;
1.3210 + startPtr = NULL;
1.3211 + offset = 0;
1.3212 +
1.3213 + if (objc < 3) {
1.3214 + Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
1.3215 + return TCL_ERROR;
1.3216 + }
1.3217 +
1.3218 + for (i = 1; i < objc-2; i++) {
1.3219 + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
1.3220 + != TCL_OK) {
1.3221 + if (startPtr) {
1.3222 + Tcl_DecrRefCount(startPtr);
1.3223 + }
1.3224 + return TCL_ERROR;
1.3225 + }
1.3226 + switch ((enum options) index) {
1.3227 + case LSEARCH_ALL: /* -all */
1.3228 + allMatches = 1;
1.3229 + break;
1.3230 + case LSEARCH_ASCII: /* -ascii */
1.3231 + dataType = ASCII;
1.3232 + break;
1.3233 + case LSEARCH_DECREASING: /* -decreasing */
1.3234 + isIncreasing = 0;
1.3235 + break;
1.3236 + case LSEARCH_DICTIONARY: /* -dictionary */
1.3237 + dataType = DICTIONARY;
1.3238 + break;
1.3239 + case LSEARCH_EXACT: /* -increasing */
1.3240 + mode = EXACT;
1.3241 + break;
1.3242 + case LSEARCH_GLOB: /* -glob */
1.3243 + mode = GLOB;
1.3244 + break;
1.3245 + case LSEARCH_INCREASING: /* -increasing */
1.3246 + isIncreasing = 1;
1.3247 + break;
1.3248 + case LSEARCH_INLINE: /* -inline */
1.3249 + inlineReturn = 1;
1.3250 + break;
1.3251 + case LSEARCH_INTEGER: /* -integer */
1.3252 + dataType = INTEGER;
1.3253 + break;
1.3254 + case LSEARCH_NOT: /* -not */
1.3255 + negatedMatch = 1;
1.3256 + break;
1.3257 + case LSEARCH_REAL: /* -real */
1.3258 + dataType = REAL;
1.3259 + break;
1.3260 + case LSEARCH_REGEXP: /* -regexp */
1.3261 + mode = REGEXP;
1.3262 + break;
1.3263 + case LSEARCH_SORTED: /* -sorted */
1.3264 + mode = SORTED;
1.3265 + break;
1.3266 + case LSEARCH_START: /* -start */
1.3267 + /*
1.3268 + * If there was a previous -start option, release its saved
1.3269 + * index because it will either be replaced or there will be
1.3270 + * an error.
1.3271 + */
1.3272 + if (startPtr) {
1.3273 + Tcl_DecrRefCount(startPtr);
1.3274 + }
1.3275 + if (i > objc-4) {
1.3276 + Tcl_AppendResult(interp, "missing starting index", NULL);
1.3277 + return TCL_ERROR;
1.3278 + }
1.3279 + i++;
1.3280 + if (objv[i] == objv[objc - 2]) {
1.3281 + /*
1.3282 + * Take copy to prevent shimmering problems. Note
1.3283 + * that it does not matter if the index obj is also a
1.3284 + * component of the list being searched. We only need
1.3285 + * to copy where the list and the index are
1.3286 + * one-and-the-same.
1.3287 + */
1.3288 + startPtr = Tcl_DuplicateObj(objv[i]);
1.3289 + } else {
1.3290 + startPtr = objv[i];
1.3291 + Tcl_IncrRefCount(startPtr);
1.3292 + }
1.3293 + }
1.3294 + }
1.3295 +
1.3296 + if ((enum modes) mode == REGEXP) {
1.3297 + /*
1.3298 + * We can shimmer regexp/list if listv[i] == pattern, so get the
1.3299 + * regexp rep before the list rep. First time round, omit the interp
1.3300 + * and hope that the compilation will succeed. If it fails, we'll
1.3301 + * recompile in "expensive" mode with a place to put error messages.
1.3302 + */
1.3303 +
1.3304 + regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1],
1.3305 + TCL_REG_ADVANCED | TCL_REG_NOSUB);
1.3306 + if (regexp == NULL) {
1.3307 + /*
1.3308 + * Failed to compile the RE. Try again without the TCL_REG_NOSUB
1.3309 + * flag in case the RE had sub-expressions in it [Bug 1366683].
1.3310 + * If this fails, an error message will be left in the
1.3311 + * interpreter.
1.3312 + */
1.3313 +
1.3314 + regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
1.3315 + TCL_REG_ADVANCED);
1.3316 + }
1.3317 +
1.3318 + if (regexp == NULL) {
1.3319 + if (startPtr) {
1.3320 + Tcl_DecrRefCount(startPtr);
1.3321 + }
1.3322 + return TCL_ERROR;
1.3323 + }
1.3324 + }
1.3325 +
1.3326 + /*
1.3327 + * Make sure the list argument is a list object and get its length and
1.3328 + * a pointer to its array of element pointers.
1.3329 + */
1.3330 +
1.3331 + result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
1.3332 + if (result != TCL_OK) {
1.3333 + if (startPtr) {
1.3334 + Tcl_DecrRefCount(startPtr);
1.3335 + }
1.3336 + return result;
1.3337 + }
1.3338 +
1.3339 + /*
1.3340 + * Get the user-specified start offset.
1.3341 + */
1.3342 + if (startPtr) {
1.3343 + result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
1.3344 + Tcl_DecrRefCount(startPtr);
1.3345 + if (result != TCL_OK) {
1.3346 + return result;
1.3347 + }
1.3348 +
1.3349 + /*
1.3350 + * If the search started past the end of the list, we just return a
1.3351 + * "did not match anything at all" result straight away. [Bug 1374778]
1.3352 + */
1.3353 +
1.3354 + if (offset > listc-1) {
1.3355 + if (allMatches || inlineReturn) {
1.3356 + Tcl_ResetResult(interp);
1.3357 + } else {
1.3358 + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
1.3359 + }
1.3360 + return TCL_OK;
1.3361 + }
1.3362 + if (offset < 0) {
1.3363 + offset = 0;
1.3364 + }
1.3365 + }
1.3366 +
1.3367 + patObj = objv[objc - 1];
1.3368 + patternBytes = NULL;
1.3369 + if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) {
1.3370 + switch ((enum datatypes) dataType) {
1.3371 + case ASCII:
1.3372 + case DICTIONARY:
1.3373 + patternBytes = Tcl_GetStringFromObj(patObj, &length);
1.3374 + break;
1.3375 + case INTEGER:
1.3376 + result = Tcl_GetIntFromObj(interp, patObj, &patInt);
1.3377 + if (result != TCL_OK) {
1.3378 + return result;
1.3379 + }
1.3380 + break;
1.3381 + case REAL:
1.3382 + result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
1.3383 + if (result != TCL_OK) {
1.3384 + return result;
1.3385 + }
1.3386 + break;
1.3387 + }
1.3388 + } else {
1.3389 + patternBytes = Tcl_GetStringFromObj(patObj, &length);
1.3390 + }
1.3391 +
1.3392 + /*
1.3393 + * Set default index value to -1, indicating failure; if we find the
1.3394 + * item in the course of our search, index will be set to the correct
1.3395 + * value.
1.3396 + */
1.3397 + index = -1;
1.3398 + match = 0;
1.3399 +
1.3400 + if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
1.3401 + /*
1.3402 + * If the data is sorted, we can do a more intelligent search.
1.3403 + * Note that there is no point in being smart when -all was
1.3404 + * specified; in that case, we have to look at all items anyway,
1.3405 + * and there is no sense in doing this when the match sense is
1.3406 + * inverted.
1.3407 + */
1.3408 + lower = offset - 1;
1.3409 + upper = listc;
1.3410 + while (lower + 1 != upper) {
1.3411 + i = (lower + upper)/2;
1.3412 + switch ((enum datatypes) dataType) {
1.3413 + case ASCII:
1.3414 + bytes = Tcl_GetString(listv[i]);
1.3415 + match = strcmp(patternBytes, bytes);
1.3416 + break;
1.3417 + case DICTIONARY:
1.3418 + bytes = Tcl_GetString(listv[i]);
1.3419 + match = DictionaryCompare(patternBytes, bytes);
1.3420 + break;
1.3421 + case INTEGER:
1.3422 + result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
1.3423 + if (result != TCL_OK) {
1.3424 + return result;
1.3425 + }
1.3426 + if (patInt == objInt) {
1.3427 + match = 0;
1.3428 + } else if (patInt < objInt) {
1.3429 + match = -1;
1.3430 + } else {
1.3431 + match = 1;
1.3432 + }
1.3433 + break;
1.3434 + case REAL:
1.3435 + result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble);
1.3436 + if (result != TCL_OK) {
1.3437 + return result;
1.3438 + }
1.3439 + if (patDouble == objDouble) {
1.3440 + match = 0;
1.3441 + } else if (patDouble < objDouble) {
1.3442 + match = -1;
1.3443 + } else {
1.3444 + match = 1;
1.3445 + }
1.3446 + break;
1.3447 + }
1.3448 + if (match == 0) {
1.3449 + /*
1.3450 + * Normally, binary search is written to stop when it
1.3451 + * finds a match. If there are duplicates of an element in
1.3452 + * the list, our first match might not be the first occurance.
1.3453 + * Consider: 0 0 0 1 1 1 2 2 2
1.3454 + * To maintain consistancy with standard lsearch semantics,
1.3455 + * we must find the leftmost occurance of the pattern in the
1.3456 + * list. Thus we don't just stop searching here. This
1.3457 + * variation means that a search always makes log n
1.3458 + * comparisons (normal binary search might "get lucky" with
1.3459 + * an early comparison).
1.3460 + */
1.3461 + index = i;
1.3462 + upper = i;
1.3463 + } else if (match > 0) {
1.3464 + if (isIncreasing) {
1.3465 + lower = i;
1.3466 + } else {
1.3467 + upper = i;
1.3468 + }
1.3469 + } else {
1.3470 + if (isIncreasing) {
1.3471 + upper = i;
1.3472 + } else {
1.3473 + lower = i;
1.3474 + }
1.3475 + }
1.3476 + }
1.3477 +
1.3478 + } else {
1.3479 + /*
1.3480 + * We need to do a linear search, because (at least one) of:
1.3481 + * - our matcher can only tell equal vs. not equal
1.3482 + * - our matching sense is negated
1.3483 + * - we're building a list of all matched items
1.3484 + */
1.3485 + if (allMatches) {
1.3486 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.3487 + }
1.3488 + for (i = offset; i < listc; i++) {
1.3489 + match = 0;
1.3490 + switch ((enum modes) mode) {
1.3491 + case SORTED:
1.3492 + case EXACT:
1.3493 + switch ((enum datatypes) dataType) {
1.3494 + case ASCII:
1.3495 + bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
1.3496 + if (length == elemLen) {
1.3497 + match = (memcmp(bytes, patternBytes,
1.3498 + (size_t) length) == 0);
1.3499 + }
1.3500 + break;
1.3501 + case DICTIONARY:
1.3502 + bytes = Tcl_GetString(listv[i]);
1.3503 + match = (DictionaryCompare(bytes, patternBytes) == 0);
1.3504 + break;
1.3505 + case INTEGER:
1.3506 + result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
1.3507 + if (result != TCL_OK) {
1.3508 + if (listPtr) {
1.3509 + Tcl_DecrRefCount(listPtr);
1.3510 + }
1.3511 + return result;
1.3512 + }
1.3513 + match = (objInt == patInt);
1.3514 + break;
1.3515 + case REAL:
1.3516 + result = Tcl_GetDoubleFromObj(interp, listv[i],
1.3517 + &objDouble);
1.3518 + if (result != TCL_OK) {
1.3519 + if (listPtr) {
1.3520 + Tcl_DecrRefCount(listPtr);
1.3521 + }
1.3522 + return result;
1.3523 + }
1.3524 + match = (objDouble == patDouble);
1.3525 + break;
1.3526 + }
1.3527 + break;
1.3528 + case GLOB:
1.3529 + match = Tcl_StringMatch(Tcl_GetString(listv[i]),
1.3530 + patternBytes);
1.3531 + break;
1.3532 + case REGEXP:
1.3533 + match = Tcl_RegExpExecObj(interp, regexp, listv[i], 0, 0, 0);
1.3534 + if (match < 0) {
1.3535 + Tcl_DecrRefCount(patObj);
1.3536 + if (listPtr) {
1.3537 + Tcl_DecrRefCount(listPtr);
1.3538 + }
1.3539 + return TCL_ERROR;
1.3540 + }
1.3541 + break;
1.3542 + }
1.3543 + /*
1.3544 + * Invert match condition for -not
1.3545 + */
1.3546 + if (negatedMatch) {
1.3547 + match = !match;
1.3548 + }
1.3549 + if (match != 0) {
1.3550 + if (!allMatches) {
1.3551 + index = i;
1.3552 + break;
1.3553 + } else if (inlineReturn) {
1.3554 + /*
1.3555 + * Note that these appends are not expected to fail.
1.3556 + */
1.3557 + Tcl_ListObjAppendElement(interp, listPtr, listv[i]);
1.3558 + } else {
1.3559 + Tcl_ListObjAppendElement(interp, listPtr,
1.3560 + Tcl_NewIntObj(i));
1.3561 + }
1.3562 + }
1.3563 + }
1.3564 + }
1.3565 +
1.3566 + /*
1.3567 + * Return everything or a single value.
1.3568 + */
1.3569 + if (allMatches) {
1.3570 + Tcl_SetObjResult(interp, listPtr);
1.3571 + } else if (!inlineReturn) {
1.3572 + Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
1.3573 + } else if (index < 0) {
1.3574 + /*
1.3575 + * Is this superfluous? The result should be a blank object
1.3576 + * by default...
1.3577 + */
1.3578 + Tcl_SetObjResult(interp, Tcl_NewObj());
1.3579 + } else {
1.3580 + Tcl_SetObjResult(interp, listv[index]);
1.3581 + }
1.3582 + return TCL_OK;
1.3583 +}
1.3584 +
1.3585 +/*
1.3586 + *----------------------------------------------------------------------
1.3587 + *
1.3588 + * Tcl_LsetObjCmd --
1.3589 + *
1.3590 + * This procedure is invoked to process the "lset" Tcl command.
1.3591 + * See the user documentation for details on what it does.
1.3592 + *
1.3593 + * Results:
1.3594 + * A standard Tcl result.
1.3595 + *
1.3596 + * Side effects:
1.3597 + * See the user documentation.
1.3598 + *
1.3599 + *----------------------------------------------------------------------
1.3600 + */
1.3601 +
1.3602 +int
1.3603 +Tcl_LsetObjCmd( clientData, interp, objc, objv )
1.3604 + ClientData clientData; /* Not used. */
1.3605 + Tcl_Interp *interp; /* Current interpreter. */
1.3606 + int objc; /* Number of arguments. */
1.3607 + Tcl_Obj *CONST objv[]; /* Argument values. */
1.3608 +{
1.3609 +
1.3610 + Tcl_Obj* listPtr; /* Pointer to the list being altered. */
1.3611 + Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */
1.3612 +
1.3613 + /* Check parameter count */
1.3614 +
1.3615 + if ( objc < 3 ) {
1.3616 + Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
1.3617 + return TCL_ERROR;
1.3618 + }
1.3619 +
1.3620 + /* Look up the list variable's value */
1.3621 +
1.3622 + listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
1.3623 + TCL_LEAVE_ERR_MSG );
1.3624 + if ( listPtr == NULL ) {
1.3625 + return TCL_ERROR;
1.3626 + }
1.3627 +
1.3628 + /*
1.3629 + * Substitute the value in the value. Return either the value or
1.3630 + * else an unshared copy of it.
1.3631 + */
1.3632 +
1.3633 + if ( objc == 4 ) {
1.3634 + finalValuePtr = TclLsetList( interp, listPtr,
1.3635 + objv[ 2 ], objv[ 3 ] );
1.3636 + } else {
1.3637 + finalValuePtr = TclLsetFlat( interp, listPtr,
1.3638 + objc-3, objv+2, objv[ objc-1 ] );
1.3639 + }
1.3640 +
1.3641 + /*
1.3642 + * If substitution has failed, bail out.
1.3643 + */
1.3644 +
1.3645 + if ( finalValuePtr == NULL ) {
1.3646 + return TCL_ERROR;
1.3647 + }
1.3648 +
1.3649 + /* Finally, update the variable so that traces fire. */
1.3650 +
1.3651 + listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
1.3652 + TCL_LEAVE_ERR_MSG );
1.3653 + Tcl_DecrRefCount( finalValuePtr );
1.3654 + if ( listPtr == NULL ) {
1.3655 + return TCL_ERROR;
1.3656 + }
1.3657 +
1.3658 + /* Return the new value of the variable as the interpreter result. */
1.3659 +
1.3660 + Tcl_SetObjResult( interp, listPtr );
1.3661 + return TCL_OK;
1.3662 +
1.3663 +}
1.3664 +
1.3665 +/*
1.3666 + *----------------------------------------------------------------------
1.3667 + *
1.3668 + * Tcl_LsortObjCmd --
1.3669 + *
1.3670 + * This procedure is invoked to process the "lsort" Tcl command.
1.3671 + * See the user documentation for details on what it does.
1.3672 + *
1.3673 + * Results:
1.3674 + * A standard Tcl result.
1.3675 + *
1.3676 + * Side effects:
1.3677 + * See the user documentation.
1.3678 + *
1.3679 + *----------------------------------------------------------------------
1.3680 + */
1.3681 +
1.3682 +int
1.3683 +Tcl_LsortObjCmd(clientData, interp, objc, objv)
1.3684 + ClientData clientData; /* Not used. */
1.3685 + Tcl_Interp *interp; /* Current interpreter. */
1.3686 + int objc; /* Number of arguments. */
1.3687 + Tcl_Obj *CONST objv[]; /* Argument values. */
1.3688 +{
1.3689 + int i, index, unique;
1.3690 + Tcl_Obj *resultPtr;
1.3691 + int length;
1.3692 + Tcl_Obj *cmdPtr, **listObjPtrs;
1.3693 + SortElement *elementArray;
1.3694 + SortElement *elementPtr;
1.3695 + SortInfo sortInfo; /* Information about this sort that
1.3696 + * needs to be passed to the
1.3697 + * comparison function */
1.3698 + static CONST char *switches[] = {
1.3699 + "-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
1.3700 + "-index", "-integer", "-real", "-unique", (char *) NULL
1.3701 + };
1.3702 +
1.3703 + resultPtr = Tcl_GetObjResult(interp);
1.3704 + if (objc < 2) {
1.3705 + Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
1.3706 + return TCL_ERROR;
1.3707 + }
1.3708 +
1.3709 + /*
1.3710 + * Parse arguments to set up the mode for the sort.
1.3711 + */
1.3712 +
1.3713 + sortInfo.isIncreasing = 1;
1.3714 + sortInfo.sortMode = SORTMODE_ASCII;
1.3715 + sortInfo.index = SORTIDX_NONE;
1.3716 + sortInfo.interp = interp;
1.3717 + sortInfo.resultCode = TCL_OK;
1.3718 + cmdPtr = NULL;
1.3719 + unique = 0;
1.3720 + for (i = 1; i < objc-1; i++) {
1.3721 + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
1.3722 + != TCL_OK) {
1.3723 + return TCL_ERROR;
1.3724 + }
1.3725 + switch (index) {
1.3726 + case 0: /* -ascii */
1.3727 + sortInfo.sortMode = SORTMODE_ASCII;
1.3728 + break;
1.3729 + case 1: /* -command */
1.3730 + if (i == (objc-2)) {
1.3731 + Tcl_AppendToObj(resultPtr,
1.3732 + "\"-command\" option must be followed by comparison command",
1.3733 + -1);
1.3734 + return TCL_ERROR;
1.3735 + }
1.3736 + sortInfo.sortMode = SORTMODE_COMMAND;
1.3737 + cmdPtr = objv[i+1];
1.3738 + i++;
1.3739 + break;
1.3740 + case 2: /* -decreasing */
1.3741 + sortInfo.isIncreasing = 0;
1.3742 + break;
1.3743 + case 3: /* -dictionary */
1.3744 + sortInfo.sortMode = SORTMODE_DICTIONARY;
1.3745 + break;
1.3746 + case 4: /* -increasing */
1.3747 + sortInfo.isIncreasing = 1;
1.3748 + break;
1.3749 + case 5: /* -index */
1.3750 + if (i == (objc-2)) {
1.3751 + Tcl_AppendToObj(resultPtr,
1.3752 + "\"-index\" option must be followed by list index",
1.3753 + -1);
1.3754 + return TCL_ERROR;
1.3755 + }
1.3756 + if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END,
1.3757 + &sortInfo.index) != TCL_OK) {
1.3758 + return TCL_ERROR;
1.3759 + }
1.3760 + i++;
1.3761 + break;
1.3762 + case 6: /* -integer */
1.3763 + sortInfo.sortMode = SORTMODE_INTEGER;
1.3764 + break;
1.3765 + case 7: /* -real */
1.3766 + sortInfo.sortMode = SORTMODE_REAL;
1.3767 + break;
1.3768 + case 8: /* -unique */
1.3769 + unique = 1;
1.3770 + break;
1.3771 + }
1.3772 + }
1.3773 + if (sortInfo.sortMode == SORTMODE_COMMAND) {
1.3774 + /*
1.3775 + * The existing command is a list. We want to flatten it, append
1.3776 + * two dummy arguments on the end, and replace these arguments
1.3777 + * later.
1.3778 + */
1.3779 +
1.3780 + Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
1.3781 + Tcl_Obj *newObjPtr = Tcl_NewObj();
1.3782 +
1.3783 + Tcl_IncrRefCount(newCommandPtr);
1.3784 + if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr)
1.3785 + != TCL_OK) {
1.3786 + Tcl_DecrRefCount(newCommandPtr);
1.3787 + Tcl_IncrRefCount(newObjPtr);
1.3788 + Tcl_DecrRefCount(newObjPtr);
1.3789 + return TCL_ERROR;
1.3790 + }
1.3791 + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
1.3792 + sortInfo.compareCmdPtr = newCommandPtr;
1.3793 + }
1.3794 +
1.3795 + sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
1.3796 + &length, &listObjPtrs);
1.3797 + if (sortInfo.resultCode != TCL_OK || length <= 0) {
1.3798 + goto done;
1.3799 + }
1.3800 + elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
1.3801 + for (i=0; i < length; i++){
1.3802 + elementArray[i].objPtr = listObjPtrs[i];
1.3803 + elementArray[i].count = 0;
1.3804 + elementArray[i].nextPtr = &elementArray[i+1];
1.3805 +
1.3806 + /*
1.3807 + * When sorting using a command, we are reentrant and therefore might
1.3808 + * have the representation of the list being sorted shimmered out from
1.3809 + * underneath our feet. Increment the reference counts of the elements
1.3810 + * to sort to prevent this. [Bug 1675116]
1.3811 + */
1.3812 +
1.3813 + Tcl_IncrRefCount(elementArray[i].objPtr);
1.3814 + }
1.3815 + elementArray[length-1].nextPtr = NULL;
1.3816 + elementPtr = MergeSort(elementArray, &sortInfo);
1.3817 + if (sortInfo.resultCode == TCL_OK) {
1.3818 + /*
1.3819 + * Note: must clear the interpreter's result object: it could
1.3820 + * have been set by the -command script.
1.3821 + */
1.3822 +
1.3823 + Tcl_ResetResult(interp);
1.3824 + resultPtr = Tcl_GetObjResult(interp);
1.3825 + if (unique) {
1.3826 + for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
1.3827 + if (elementPtr->count == 0) {
1.3828 + Tcl_ListObjAppendElement(interp, resultPtr,
1.3829 + elementPtr->objPtr);
1.3830 + }
1.3831 + }
1.3832 + } else {
1.3833 + for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
1.3834 + Tcl_ListObjAppendElement(interp, resultPtr,
1.3835 + elementPtr->objPtr);
1.3836 + }
1.3837 + }
1.3838 + }
1.3839 + for (i=0; i<length; i++) {
1.3840 + Tcl_DecrRefCount(elementArray[i].objPtr);
1.3841 + }
1.3842 + ckfree((char*) elementArray);
1.3843 +
1.3844 + done:
1.3845 + if (sortInfo.sortMode == SORTMODE_COMMAND) {
1.3846 + Tcl_DecrRefCount(sortInfo.compareCmdPtr);
1.3847 + sortInfo.compareCmdPtr = NULL;
1.3848 + }
1.3849 + return sortInfo.resultCode;
1.3850 +}
1.3851 +
1.3852 +/*
1.3853 + *----------------------------------------------------------------------
1.3854 + *
1.3855 + * MergeSort -
1.3856 + *
1.3857 + * This procedure sorts a linked list of SortElement structures
1.3858 + * use the merge-sort algorithm.
1.3859 + *
1.3860 + * Results:
1.3861 + * A pointer to the head of the list after sorting is returned.
1.3862 + *
1.3863 + * Side effects:
1.3864 + * None, unless a user-defined comparison command does something
1.3865 + * weird.
1.3866 + *
1.3867 + *----------------------------------------------------------------------
1.3868 + */
1.3869 +
1.3870 +static SortElement *
1.3871 +MergeSort(headPtr, infoPtr)
1.3872 + SortElement *headPtr; /* First element on the list */
1.3873 + SortInfo *infoPtr; /* Information needed by the
1.3874 + * comparison operator */
1.3875 +{
1.3876 + /*
1.3877 + * The subList array below holds pointers to temporary lists built
1.3878 + * during the merge sort. Element i of the array holds a list of
1.3879 + * length 2**i.
1.3880 + */
1.3881 +
1.3882 +# define NUM_LISTS 30
1.3883 + SortElement *subList[NUM_LISTS];
1.3884 + SortElement *elementPtr;
1.3885 + int i;
1.3886 +
1.3887 + for(i = 0; i < NUM_LISTS; i++){
1.3888 + subList[i] = NULL;
1.3889 + }
1.3890 + while (headPtr != NULL) {
1.3891 + elementPtr = headPtr;
1.3892 + headPtr = headPtr->nextPtr;
1.3893 + elementPtr->nextPtr = 0;
1.3894 + for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
1.3895 + elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
1.3896 + subList[i] = NULL;
1.3897 + }
1.3898 + if (i >= NUM_LISTS) {
1.3899 + i = NUM_LISTS-1;
1.3900 + }
1.3901 + subList[i] = elementPtr;
1.3902 + }
1.3903 + elementPtr = NULL;
1.3904 + for (i = 0; i < NUM_LISTS; i++){
1.3905 + elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
1.3906 + }
1.3907 + return elementPtr;
1.3908 +}
1.3909 +
1.3910 +/*
1.3911 + *----------------------------------------------------------------------
1.3912 + *
1.3913 + * MergeLists -
1.3914 + *
1.3915 + * This procedure combines two sorted lists of SortElement structures
1.3916 + * into a single sorted list.
1.3917 + *
1.3918 + * Results:
1.3919 + * The unified list of SortElement structures.
1.3920 + *
1.3921 + * Side effects:
1.3922 + * None, unless a user-defined comparison command does something
1.3923 + * weird.
1.3924 + *
1.3925 + *----------------------------------------------------------------------
1.3926 + */
1.3927 +
1.3928 +static SortElement *
1.3929 +MergeLists(leftPtr, rightPtr, infoPtr)
1.3930 + SortElement *leftPtr; /* First list to be merged; may be
1.3931 + * NULL. */
1.3932 + SortElement *rightPtr; /* Second list to be merged; may be
1.3933 + * NULL. */
1.3934 + SortInfo *infoPtr; /* Information needed by the
1.3935 + * comparison operator. */
1.3936 +{
1.3937 + SortElement *headPtr;
1.3938 + SortElement *tailPtr;
1.3939 + int cmp;
1.3940 +
1.3941 + if (leftPtr == NULL) {
1.3942 + return rightPtr;
1.3943 + }
1.3944 + if (rightPtr == NULL) {
1.3945 + return leftPtr;
1.3946 + }
1.3947 + cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
1.3948 + if (cmp > 0) {
1.3949 + tailPtr = rightPtr;
1.3950 + rightPtr = rightPtr->nextPtr;
1.3951 + } else {
1.3952 + if (cmp == 0) {
1.3953 + leftPtr->count++;
1.3954 + }
1.3955 + tailPtr = leftPtr;
1.3956 + leftPtr = leftPtr->nextPtr;
1.3957 + }
1.3958 + headPtr = tailPtr;
1.3959 + while ((leftPtr != NULL) && (rightPtr != NULL)) {
1.3960 + cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
1.3961 + if (cmp > 0) {
1.3962 + tailPtr->nextPtr = rightPtr;
1.3963 + tailPtr = rightPtr;
1.3964 + rightPtr = rightPtr->nextPtr;
1.3965 + } else {
1.3966 + if (cmp == 0) {
1.3967 + leftPtr->count++;
1.3968 + }
1.3969 + tailPtr->nextPtr = leftPtr;
1.3970 + tailPtr = leftPtr;
1.3971 + leftPtr = leftPtr->nextPtr;
1.3972 + }
1.3973 + }
1.3974 + if (leftPtr != NULL) {
1.3975 + tailPtr->nextPtr = leftPtr;
1.3976 + } else {
1.3977 + tailPtr->nextPtr = rightPtr;
1.3978 + }
1.3979 + return headPtr;
1.3980 +}
1.3981 +
1.3982 +/*
1.3983 + *----------------------------------------------------------------------
1.3984 + *
1.3985 + * SortCompare --
1.3986 + *
1.3987 + * This procedure is invoked by MergeLists to determine the proper
1.3988 + * ordering between two elements.
1.3989 + *
1.3990 + * Results:
1.3991 + * A negative results means the the first element comes before the
1.3992 + * second, and a positive results means that the second element
1.3993 + * should come first. A result of zero means the two elements
1.3994 + * are equal and it doesn't matter which comes first.
1.3995 + *
1.3996 + * Side effects:
1.3997 + * None, unless a user-defined comparison command does something
1.3998 + * weird.
1.3999 + *
1.4000 + *----------------------------------------------------------------------
1.4001 + */
1.4002 +
1.4003 +static int
1.4004 +SortCompare(objPtr1, objPtr2, infoPtr)
1.4005 + Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
1.4006 + SortInfo *infoPtr; /* Information passed from the
1.4007 + * top-level "lsort" command */
1.4008 +{
1.4009 + int order, listLen, index;
1.4010 + Tcl_Obj *objPtr;
1.4011 + char buffer[TCL_INTEGER_SPACE];
1.4012 +
1.4013 + order = 0;
1.4014 + if (infoPtr->resultCode != TCL_OK) {
1.4015 + /*
1.4016 + * Once an error has occurred, skip any future comparisons
1.4017 + * so as to preserve the error message in sortInterp->result.
1.4018 + */
1.4019 +
1.4020 + return order;
1.4021 + }
1.4022 + if (infoPtr->index != SORTIDX_NONE) {
1.4023 + /*
1.4024 + * The "-index" option was specified. Treat each object as a
1.4025 + * list, extract the requested element from each list, and
1.4026 + * compare the elements, not the lists. "end"-relative indices
1.4027 + * are signaled here with large negative values.
1.4028 + */
1.4029 +
1.4030 + if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
1.4031 + infoPtr->resultCode = TCL_ERROR;
1.4032 + return order;
1.4033 + }
1.4034 + if (infoPtr->index < SORTIDX_NONE) {
1.4035 + index = listLen + infoPtr->index + 1;
1.4036 + } else {
1.4037 + index = infoPtr->index;
1.4038 + }
1.4039 +
1.4040 + if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
1.4041 + != TCL_OK) {
1.4042 + infoPtr->resultCode = TCL_ERROR;
1.4043 + return order;
1.4044 + }
1.4045 + if (objPtr == NULL) {
1.4046 + objPtr = objPtr1;
1.4047 + missingElement:
1.4048 + TclFormatInt(buffer, infoPtr->index);
1.4049 + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
1.4050 + "element ", buffer, " missing from sublist \"",
1.4051 + Tcl_GetString(objPtr), "\"", (char *) NULL);
1.4052 + infoPtr->resultCode = TCL_ERROR;
1.4053 + return order;
1.4054 + }
1.4055 + objPtr1 = objPtr;
1.4056 +
1.4057 + if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
1.4058 + infoPtr->resultCode = TCL_ERROR;
1.4059 + return order;
1.4060 + }
1.4061 + if (infoPtr->index < SORTIDX_NONE) {
1.4062 + index = listLen + infoPtr->index + 1;
1.4063 + } else {
1.4064 + index = infoPtr->index;
1.4065 + }
1.4066 +
1.4067 + if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
1.4068 + != TCL_OK) {
1.4069 + infoPtr->resultCode = TCL_ERROR;
1.4070 + return order;
1.4071 + }
1.4072 + if (objPtr == NULL) {
1.4073 + objPtr = objPtr2;
1.4074 + goto missingElement;
1.4075 + }
1.4076 + objPtr2 = objPtr;
1.4077 + }
1.4078 + if (infoPtr->sortMode == SORTMODE_ASCII) {
1.4079 + order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
1.4080 + } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
1.4081 + order = DictionaryCompare(
1.4082 + Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
1.4083 + } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
1.4084 + long a, b;
1.4085 +
1.4086 + if ((Tcl_GetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
1.4087 + || (Tcl_GetLongFromObj(infoPtr->interp, objPtr2, &b)
1.4088 + != TCL_OK)) {
1.4089 + infoPtr->resultCode = TCL_ERROR;
1.4090 + return order;
1.4091 + }
1.4092 + if (a > b) {
1.4093 + order = 1;
1.4094 + } else if (b > a) {
1.4095 + order = -1;
1.4096 + }
1.4097 + } else if (infoPtr->sortMode == SORTMODE_REAL) {
1.4098 + double a, b;
1.4099 +
1.4100 + if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
1.4101 + || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
1.4102 + != TCL_OK)) {
1.4103 + infoPtr->resultCode = TCL_ERROR;
1.4104 + return order;
1.4105 + }
1.4106 + if (a > b) {
1.4107 + order = 1;
1.4108 + } else if (b > a) {
1.4109 + order = -1;
1.4110 + }
1.4111 + } else {
1.4112 + Tcl_Obj **objv, *paramObjv[2];
1.4113 + int objc;
1.4114 +
1.4115 + paramObjv[0] = objPtr1;
1.4116 + paramObjv[1] = objPtr2;
1.4117 +
1.4118 + /*
1.4119 + * We made space in the command list for the two things to
1.4120 + * compare. Replace them and evaluate the result.
1.4121 + */
1.4122 +
1.4123 + Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
1.4124 + Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
1.4125 + 2, 2, paramObjv);
1.4126 + Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
1.4127 + &objc, &objv);
1.4128 +
1.4129 + infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
1.4130 +
1.4131 + if (infoPtr->resultCode != TCL_OK) {
1.4132 + Tcl_AddErrorInfo(infoPtr->interp,
1.4133 + "\n (-compare command)");
1.4134 + return order;
1.4135 + }
1.4136 +
1.4137 + /*
1.4138 + * Parse the result of the command.
1.4139 + */
1.4140 +
1.4141 + if (Tcl_GetIntFromObj(infoPtr->interp,
1.4142 + Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
1.4143 + Tcl_ResetResult(infoPtr->interp);
1.4144 + Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
1.4145 + "-compare command returned non-integer result", -1);
1.4146 + infoPtr->resultCode = TCL_ERROR;
1.4147 + return order;
1.4148 + }
1.4149 + }
1.4150 + if (!infoPtr->isIncreasing) {
1.4151 + order = -order;
1.4152 + }
1.4153 + return order;
1.4154 +}
1.4155 +
1.4156 +/*
1.4157 + *----------------------------------------------------------------------
1.4158 + *
1.4159 + * DictionaryCompare
1.4160 + *
1.4161 + * This function compares two strings as if they were being used in
1.4162 + * an index or card catalog. The case of alphabetic characters is
1.4163 + * ignored, except to break ties. Thus "B" comes before "b" but
1.4164 + * after "a". Also, integers embedded in the strings compare in
1.4165 + * numerical order. In other words, "x10y" comes after "x9y", not
1.4166 + * before it as it would when using strcmp().
1.4167 + *
1.4168 + * Results:
1.4169 + * A negative result means that the first element comes before the
1.4170 + * second, and a positive result means that the second element
1.4171 + * should come first. A result of zero means the two elements
1.4172 + * are equal and it doesn't matter which comes first.
1.4173 + *
1.4174 + * Side effects:
1.4175 + * None.
1.4176 + *
1.4177 + *----------------------------------------------------------------------
1.4178 + */
1.4179 +
1.4180 +static int
1.4181 +DictionaryCompare(left, right)
1.4182 + char *left, *right; /* The strings to compare */
1.4183 +{
1.4184 + Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower;
1.4185 + int diff, zeros;
1.4186 + int secondaryDiff = 0;
1.4187 +
1.4188 + while (1) {
1.4189 + if (isdigit(UCHAR(*right)) /* INTL: digit */
1.4190 + && isdigit(UCHAR(*left))) { /* INTL: digit */
1.4191 + /*
1.4192 + * There are decimal numbers embedded in the two
1.4193 + * strings. Compare them as numbers, rather than
1.4194 + * strings. If one number has more leading zeros than
1.4195 + * the other, the number with more leading zeros sorts
1.4196 + * later, but only as a secondary choice.
1.4197 + */
1.4198 +
1.4199 + zeros = 0;
1.4200 + while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
1.4201 + right++;
1.4202 + zeros--;
1.4203 + }
1.4204 + while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
1.4205 + left++;
1.4206 + zeros++;
1.4207 + }
1.4208 + if (secondaryDiff == 0) {
1.4209 + secondaryDiff = zeros;
1.4210 + }
1.4211 +
1.4212 + /*
1.4213 + * The code below compares the numbers in the two
1.4214 + * strings without ever converting them to integers. It
1.4215 + * does this by first comparing the lengths of the
1.4216 + * numbers and then comparing the digit values.
1.4217 + */
1.4218 +
1.4219 + diff = 0;
1.4220 + while (1) {
1.4221 + if (diff == 0) {
1.4222 + diff = UCHAR(*left) - UCHAR(*right);
1.4223 + }
1.4224 + right++;
1.4225 + left++;
1.4226 + if (!isdigit(UCHAR(*right))) { /* INTL: digit */
1.4227 + if (isdigit(UCHAR(*left))) { /* INTL: digit */
1.4228 + return 1;
1.4229 + } else {
1.4230 + /*
1.4231 + * The two numbers have the same length. See
1.4232 + * if their values are different.
1.4233 + */
1.4234 +
1.4235 + if (diff != 0) {
1.4236 + return diff;
1.4237 + }
1.4238 + break;
1.4239 + }
1.4240 + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */
1.4241 + return -1;
1.4242 + }
1.4243 + }
1.4244 + continue;
1.4245 + }
1.4246 +
1.4247 + /*
1.4248 + * Convert character to Unicode for comparison purposes. If either
1.4249 + * string is at the terminating null, do a byte-wise comparison and
1.4250 + * bail out immediately.
1.4251 + */
1.4252 +
1.4253 + if ((*left != '\0') && (*right != '\0')) {
1.4254 + left += Tcl_UtfToUniChar(left, &uniLeft);
1.4255 + right += Tcl_UtfToUniChar(right, &uniRight);
1.4256 + /*
1.4257 + * Convert both chars to lower for the comparison, because
1.4258 + * dictionary sorts are case insensitve. Covert to lower, not
1.4259 + * upper, so chars between Z and a will sort before A (where most
1.4260 + * other interesting punctuations occur)
1.4261 + */
1.4262 + uniLeftLower = Tcl_UniCharToLower(uniLeft);
1.4263 + uniRightLower = Tcl_UniCharToLower(uniRight);
1.4264 + } else {
1.4265 + diff = UCHAR(*left) - UCHAR(*right);
1.4266 + break;
1.4267 + }
1.4268 +
1.4269 + diff = uniLeftLower - uniRightLower;
1.4270 + if (diff) {
1.4271 + return diff;
1.4272 + } else if (secondaryDiff == 0) {
1.4273 + if (Tcl_UniCharIsUpper(uniLeft) &&
1.4274 + Tcl_UniCharIsLower(uniRight)) {
1.4275 + secondaryDiff = -1;
1.4276 + } else if (Tcl_UniCharIsUpper(uniRight)
1.4277 + && Tcl_UniCharIsLower(uniLeft)) {
1.4278 + secondaryDiff = 1;
1.4279 + }
1.4280 + }
1.4281 + }
1.4282 + if (diff == 0) {
1.4283 + diff = secondaryDiff;
1.4284 + }
1.4285 + return diff;
1.4286 +}
1.4287 +
1.4288 +/*
1.4289 + * Local Variables:
1.4290 + * mode: c
1.4291 + * c-basic-offset: 4
1.4292 + * fill-column: 78
1.4293 + * End:
1.4294 + */
1.4295 +