Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Artifact 4f565a01560e42fc79e955ecb4b85322552c58b8b6fe6778841287aad0750569:


     1  /*
     2   * tclCmdIL.c --
     3   *
     4   *	This file contains the top-level command routines for most of the Tcl
     5   *	built-in commands whose names begin with the letters I through L. It
     6   *	contains only commands in the generic core (i.e., those that don't
     7   *	depend much upon UNIX facilities).
     8   *
     9   * Copyright (c) 1987-1993 The Regents of the University of California.
    10   * Copyright (c) 1993-1997 Lucent Technologies.
    11   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
    12   * Copyright (c) 1998-1999 by Scriptics Corporation.
    13   * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
    14   * Copyright (c) 2005 Donal K. Fellows.
    15   *
    16   * See the file "license.terms" for information on usage and redistribution of
    17   * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    18   */
    19  
    20  #include "tclInt.h"
    21  #include "tclRegexp.h"
    22  
    23  /*
    24   * During execution of the "lsort" command, structures of the following type
    25   * are used to arrange the objects being sorted into a collection of linked
    26   * lists.
    27   */
    28  
    29  typedef struct SortElement {
    30      union {			/* The value that we sorting by. */
    31  	const char *strValuePtr;
    32  	Tcl_WideInt wideValue;
    33  	double doubleValue;
    34  	Tcl_Obj *objValuePtr;
    35      } collationKey;
    36      union {			/* Object being sorted, or its index. */
    37  	Tcl_Obj *objPtr;
    38  	size_t index;
    39      } payload;
    40      struct SortElement *nextPtr;/* Next element in the list, or NULL for end
    41  				 * of list. */
    42  } SortElement;
    43  
    44  /*
    45   * These function pointer types are used with the "lsearch" and "lsort"
    46   * commands to facilitate the "-nocase" option.
    47   */
    48  
    49  typedef int (*SortStrCmpFn_t) (const char *, const char *);
    50  typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
    51  
    52  /*
    53   * The "lsort" command needs to pass certain information down to the function
    54   * that compares two list elements, and the comparison function needs to pass
    55   * success or failure information back up to the top-level "lsort" command.
    56   * The following structure is used to pass this information.
    57   */
    58  
    59  typedef struct {
    60      int isIncreasing;		/* Nonzero means sort in increasing order. */
    61      int sortMode;		/* The sort mode. One of SORTMODE_* values
    62  				 * defined below. */
    63      Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
    64  				 * SORTMODE_COMMAND. Pre-initialized to hold
    65  				 * base of command. */
    66      int *indexv;		/* If the -index option was specified, this
    67  				 * holds an encoding of the indexes contained
    68  				 * in the list supplied as an argument to
    69  				 * that option.
    70  				 * NULL if no indexes supplied, and points to
    71  				 * singleIndex field when only one
    72  				 * supplied. */
    73      int indexc;			/* Number of indexes in indexv array. */
    74      int singleIndex;		/* Static space for common index case. */
    75      int unique;
    76      int numElements;
    77      Tcl_Interp *interp;		/* The interpreter in which the sort is being
    78  				 * done. */
    79      int resultCode;		/* Completion code for the lsort command. If
    80  				 * an error occurs during the sort this is
    81  				 * changed from TCL_OK to TCL_ERROR. */
    82  } SortInfo;
    83  
    84  /*
    85   * The "sortMode" field of the SortInfo structure can take on any of the
    86   * following values.
    87   */
    88  
    89  #define SORTMODE_ASCII		0
    90  #define SORTMODE_INTEGER	1
    91  #define SORTMODE_REAL		2
    92  #define SORTMODE_COMMAND	3
    93  #define SORTMODE_DICTIONARY	4
    94  #define SORTMODE_ASCII_NC	8
    95  
    96  /*
    97   * Forward declarations for procedures defined in this file:
    98   */
    99  
   100  static int		DictionaryCompare(const char *left, const char *right);
   101  static Tcl_NRPostProc	IfConditionCallback;
   102  static int		InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
   103  			    int objc, Tcl_Obj *const objv[]);
   104  static int		InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
   105  			    int objc, Tcl_Obj *const objv[]);
   106  static int		InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp,
   107  			    int objc, Tcl_Obj *const objv[]);
   108  static int		InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp,
   109  			    int objc, Tcl_Obj *const objv[]);
   110  static int		InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
   111  			    int objc, Tcl_Obj *const objv[]);
   112  static int		InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
   113  			    int objc, Tcl_Obj *const objv[]);
   114  /* TIP #348 - New 'info' subcommand 'errorstack' */
   115  static int		InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
   116  			    int objc, Tcl_Obj *const objv[]);
   117  /* TIP #280 - New 'info' subcommand 'frame' */
   118  static int		InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
   119  			    int objc, Tcl_Obj *const objv[]);
   120  static int		InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
   121  			    int objc, Tcl_Obj *const objv[]);
   122  static int		InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
   123  			    int objc, Tcl_Obj *const objv[]);
   124  static int		InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
   125  			    int objc, Tcl_Obj *const objv[]);
   126  static int		InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
   127  			    int objc, Tcl_Obj *const objv[]);
   128  static int		InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
   129  			    int objc, Tcl_Obj *const objv[]);
   130  static int		InfoNameOfExecutableCmd(ClientData dummy,
   131  			    Tcl_Interp *interp, int objc,
   132  			    Tcl_Obj *const objv[]);
   133  static int		InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
   134  			    int objc, Tcl_Obj *const objv[]);
   135  static int		InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
   136  			    int objc, Tcl_Obj *const objv[]);
   137  static int		InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
   138  			    int objc, Tcl_Obj *const objv[]);
   139  static int		InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
   140  			    int objc, Tcl_Obj *const objv[]);
   141  static int		InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp,
   142  			    int objc, Tcl_Obj *const objv[]);
   143  static int		InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
   144  			    int objc, Tcl_Obj *const objv[]);
   145  static SortElement *	MergeLists(SortElement *leftPtr, SortElement *rightPtr,
   146  			    SortInfo *infoPtr);
   147  static int		SortCompare(SortElement *firstPtr, SortElement *second,
   148  			    SortInfo *infoPtr);
   149  static Tcl_Obj *	SelectObjFromSublist(Tcl_Obj *firstPtr,
   150  			    SortInfo *infoPtr);
   151  
   152  /*
   153   * Array of values describing how to implement each standard subcommand of the
   154   * "info" command.
   155   */
   156  
   157  static const EnsembleImplMap defaultInfoMap[] = {
   158      {"args",		   InfoArgsCmd,		    TclCompileBasic1ArgCmd, NULL, NULL, 0},
   159      {"body",		   InfoBodyCmd,		    TclCompileBasic1ArgCmd, NULL, NULL, 0},
   160      {"cmdcount",	   InfoCmdCountCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
   161      {"cmdtype",		   InfoCmdTypeCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 1},
   162      {"commands",	   InfoCommandsCmd,	    TclCompileInfoCommandsCmd, NULL, NULL, 0},
   163      {"complete",	   InfoCompleteCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
   164      {"coroutine",	   TclInfoCoroutineCmd,     TclCompileInfoCoroutineCmd, NULL, NULL, 0},
   165      {"default",		   InfoDefaultCmd,	    TclCompileBasic3ArgCmd, NULL, NULL, 0},
   166      {"errorstack",	   InfoErrorStackCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   167      {"exists",		   TclInfoExistsCmd,	    TclCompileInfoExistsCmd, NULL, NULL, 0},
   168      {"frame",		   InfoFrameCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   169      {"functions",	   InfoFunctionsCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   170      {"globals",		   TclInfoGlobalsCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   171      {"hostname",	   InfoHostnameCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
   172      {"level",		   InfoLevelCmd,	    TclCompileInfoLevelCmd, NULL, NULL, 0},
   173      {"library",		   InfoLibraryCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
   174      {"loaded",		   InfoLoadedCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   175      {"locals",		   TclInfoLocalsCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   176      {"nameofexecutable",   InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
   177      {"patchlevel",	   InfoPatchLevelCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
   178      {"procs",		   InfoProcsCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   179      {"script",		   InfoScriptCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   180      {"sharedlibextension", InfoSharedlibCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
   181      {"tclversion",	   InfoTclVersionCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
   182      {"vars",		   TclInfoVarsCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
   183      {NULL, NULL, NULL, NULL, NULL, 0}
   184  };
   185  
   186  /*
   187   *----------------------------------------------------------------------
   188   *
   189   * Tcl_IfObjCmd --
   190   *
   191   *	This procedure is invoked to process the "if" Tcl command. See the
   192   *	user documentation for details on what it does.
   193   *
   194   *	With the bytecode compiler, this procedure is only called when a
   195   *	command name is computed at runtime, and is "if" or the name to which
   196   *	"if" was renamed: e.g., "set z if; $z 1 {puts foo}"
   197   *
   198   * Results:
   199   *	A standard Tcl result.
   200   *
   201   * Side effects:
   202   *	See the user documentation.
   203   *
   204   *----------------------------------------------------------------------
   205   */
   206  
   207  int
   208  Tcl_IfObjCmd(
   209      ClientData dummy,		/* Not used. */
   210      Tcl_Interp *interp,		/* Current interpreter. */
   211      int objc,			/* Number of arguments. */
   212      Tcl_Obj *const objv[])	/* Argument objects. */
   213  {
   214      return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
   215  }
   216  
   217  int
   218  TclNRIfObjCmd(
   219      ClientData dummy,		/* Not used. */
   220      Tcl_Interp *interp,		/* Current interpreter. */
   221      int objc,			/* Number of arguments. */
   222      Tcl_Obj *const objv[])	/* Argument objects. */
   223  {
   224      Tcl_Obj *boolObj;
   225  
   226      if (objc <= 1) {
   227  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   228  		"wrong # args: no expression after \"%s\" argument",
   229  		TclGetString(objv[0])));
   230  	Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
   231  	return TCL_ERROR;
   232      }
   233  
   234      /*
   235       * At this point, objv[1] refers to the main expression to test. The
   236       * arguments after the expression must be "then" (optional) and a script
   237       * to execute if the expression is true.
   238       */
   239  
   240      TclNewObj(boolObj);
   241      Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc),
   242  	    (ClientData) objv, INT2PTR(1), boolObj);
   243      return Tcl_NRExprObj(interp, objv[1], boolObj);
   244  }
   245  
   246  static int
   247  IfConditionCallback(
   248      ClientData data[],
   249      Tcl_Interp *interp,
   250      int result)
   251  {
   252      Interp *iPtr = (Interp *) interp;
   253      int objc = PTR2INT(data[0]);
   254      Tcl_Obj *const *objv = data[1];
   255      int i = PTR2INT(data[2]);
   256      Tcl_Obj *boolObj = data[3];
   257      int value, thenScriptIndex = 0;
   258      const char *clause;
   259  
   260      if (result != TCL_OK) {
   261  	TclDecrRefCount(boolObj);
   262  	return result;
   263      }
   264      if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
   265  	TclDecrRefCount(boolObj);
   266  	return TCL_ERROR;
   267      }
   268      TclDecrRefCount(boolObj);
   269  
   270      while (1) {
   271  	i++;
   272  	if (i >= objc) {
   273  	    goto missingScript;
   274  	}
   275  	clause = TclGetString(objv[i]);
   276  	if ((i < objc) && (strcmp(clause, "then") == 0)) {
   277  	    i++;
   278  	}
   279  	if (i >= objc) {
   280  	    goto missingScript;
   281  	}
   282  	if (value) {
   283  	    thenScriptIndex = i;
   284  	    value = 0;
   285  	}
   286  
   287  	/*
   288  	 * The expression evaluated to false. Skip the command, then see if
   289  	 * there is an "else" or "elseif" clause.
   290  	 */
   291  
   292  	i++;
   293  	if (i >= objc) {
   294  	    if (thenScriptIndex) {
   295  		/*
   296  		 * TIP #280. Make invoking context available to branch.
   297  		 */
   298  
   299  		return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
   300  			iPtr->cmdFramePtr, thenScriptIndex);
   301  	    }
   302  	    return TCL_OK;
   303  	}
   304  	clause = TclGetString(objv[i]);
   305  	if ((clause[0] != 'e') || (strcmp(clause, "elseif") != 0)) {
   306  	    break;
   307  	}
   308  	i++;
   309  
   310  	/*
   311  	 * At this point in the loop, objv and objc refer to an expression to
   312  	 * test, either for the main expression or an expression following an
   313  	 * "elseif". The arguments after the expression must be "then"
   314  	 * (optional) and a script to execute if the expression is true.
   315  	 */
   316  
   317  	if (i >= objc) {
   318  	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   319  		    "wrong # args: no expression after \"%s\" argument",
   320  		    clause));
   321  	    Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
   322  	    return TCL_ERROR;
   323  	}
   324  	if (!thenScriptIndex) {
   325  	    TclNewObj(boolObj);
   326  	    Tcl_NRAddCallback(interp, IfConditionCallback, data[0], data[1],
   327  		    INT2PTR(i), boolObj);
   328  	    return Tcl_NRExprObj(interp, objv[i], boolObj);
   329  	}
   330      }
   331  
   332      /*
   333       * Couldn't find a "then" or "elseif" clause to execute. Check now for an
   334       * "else" clause. We know that there's at least one more argument when we
   335       * get here.
   336       */
   337  
   338      if (strcmp(clause, "else") == 0) {
   339  	i++;
   340  	if (i >= objc) {
   341  	    goto missingScript;
   342  	}
   343      }
   344      if (i < objc - 1) {
   345  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
   346  		"wrong # args: extra words after \"else\" clause in \"if\" command",
   347  		-1));
   348  	Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
   349  	return TCL_ERROR;
   350      }
   351      if (thenScriptIndex) {
   352  	/*
   353  	 * TIP #280. Make invoking context available to branch/else.
   354  	 */
   355  
   356  	return TclNREvalObjEx(interp, objv[thenScriptIndex], 0,
   357  		iPtr->cmdFramePtr, thenScriptIndex);
   358      }
   359      return TclNREvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr, i);
   360  
   361    missingScript:
   362      Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   363  	    "wrong # args: no script following \"%s\" argument",
   364  	    TclGetString(objv[i-1])));
   365      Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
   366      return TCL_ERROR;
   367  }
   368  
   369  /*
   370   *----------------------------------------------------------------------
   371   *
   372   * Tcl_IncrObjCmd --
   373   *
   374   *	This procedure is invoked to process the "incr" Tcl command. See the
   375   *	user documentation for details on what it does.
   376   *
   377   *	With the bytecode compiler, this procedure is only called when a
   378   *	command name is computed at runtime, and is "incr" or the name to
   379   *	which "incr" was renamed: e.g., "set z incr; $z i -1"
   380   *
   381   * Results:
   382   *	A standard Tcl result.
   383   *
   384   * Side effects:
   385   *	See the user documentation.
   386   *
   387   *----------------------------------------------------------------------
   388   */
   389  
   390  int
   391  Tcl_IncrObjCmd(
   392      ClientData dummy,		/* Not used. */
   393      Tcl_Interp *interp,		/* Current interpreter. */
   394      int objc,			/* Number of arguments. */
   395      Tcl_Obj *const objv[])	/* Argument objects. */
   396  {
   397      Tcl_Obj *newValuePtr, *incrPtr;
   398  
   399      if ((objc != 2) && (objc != 3)) {
   400  	Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
   401  	return TCL_ERROR;
   402      }
   403  
   404      if (objc == 3) {
   405  	incrPtr = objv[2];
   406      } else {
   407  	incrPtr = Tcl_NewWideIntObj(1);
   408      }
   409      Tcl_IncrRefCount(incrPtr);
   410      newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
   411  	    incrPtr, TCL_LEAVE_ERR_MSG);
   412      Tcl_DecrRefCount(incrPtr);
   413  
   414      if (newValuePtr == NULL) {
   415  	return TCL_ERROR;
   416      }
   417  
   418      /*
   419       * Set the interpreter's object result to refer to the variable's new
   420       * value object.
   421       */
   422  
   423      Tcl_SetObjResult(interp, newValuePtr);
   424      return TCL_OK;
   425  }
   426  
   427  /*
   428   *----------------------------------------------------------------------
   429   *
   430   * TclInitInfoCmd --
   431   *
   432   *	This function is called to create the "info" Tcl command. See the user
   433   *	documentation for details on what it does.
   434   *
   435   * Results:
   436   *	Handle for the info command, or NULL on failure.
   437   *
   438   * Side effects:
   439   *	none
   440   *
   441   *----------------------------------------------------------------------
   442   */
   443  
   444  Tcl_Command
   445  TclInitInfoCmd(
   446      Tcl_Interp *interp)		/* Current interpreter. */
   447  {
   448      return TclMakeEnsemble(interp, "info", defaultInfoMap);
   449  }
   450  
   451  /*
   452   *----------------------------------------------------------------------
   453   *
   454   * InfoArgsCmd --
   455   *
   456   *	Called to implement the "info args" command that returns the argument
   457   *	list for a procedure. Handles the following syntax:
   458   *
   459   *	    info args procName
   460   *
   461   * Results:
   462   *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
   463   *
   464   * Side effects:
   465   *	Returns a result in the interpreter's result object. If there is an
   466   *	error, the result is an error message.
   467   *
   468   *----------------------------------------------------------------------
   469   */
   470  
   471  static int
   472  InfoArgsCmd(
   473      ClientData dummy,		/* Not used. */
   474      Tcl_Interp *interp,		/* Current interpreter. */
   475      int objc,			/* Number of arguments. */
   476      Tcl_Obj *const objv[])	/* Argument objects. */
   477  {
   478      register Interp *iPtr = (Interp *) interp;
   479      const char *name;
   480      Proc *procPtr;
   481      CompiledLocal *localPtr;
   482      Tcl_Obj *listObjPtr;
   483  
   484      if (objc != 2) {
   485  	Tcl_WrongNumArgs(interp, 1, objv, "procname");
   486  	return TCL_ERROR;
   487      }
   488  
   489      name = TclGetString(objv[1]);
   490      procPtr = TclFindProc(iPtr, name);
   491      if (procPtr == NULL) {
   492  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
   493  		"\"%s\" isn't a procedure", name));
   494  	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
   495  	return TCL_ERROR;
   496      }
   497  
   498      /*
   499       * Build a return list containing the arguments.
   500       */
   501  
   502      listObjPtr = Tcl_NewListObj(0, NULL);
   503      for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
   504  	    localPtr = localPtr->nextPtr) {
   505  	if (TclIsVarArgument(localPtr)) {
   506  	    Tcl_ListObjAppendElement(interp, listObjPtr,
   507  		    Tcl_NewStringObj(localPtr->name, -1));
   508  	}
   509      }
   510      Tcl_SetObjResult(interp, listObjPtr);
   511      return TCL_OK;
   512  }
   513  
   514  /*
   515   *----------------------------------------------------------------------
   516   *
   517   * InfoBodyCmd --
   518   *
   519   *	Called to implement the "info body" command that returns the body for
   520   *	a procedure. Handles the following syntax:
   521   *
   522   *	    info body procName
   523   *
   524   * Results:
   525   *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
   526   *
   527   * Side effects:
   528   *	Returns a result in the interpreter's result object. If there is an
   529   *	error, the result is an error message.
   530   *
   531   *----------------------------------------------------------------------
   532   */
   533  
   534  static int
   535  InfoBodyCmd(
   536      ClientData dummy,		/* Not used. */
   537      Tcl_Interp *interp,		/* Current interpreter. */
   538      int objc,			/* Number of arguments. */
   539      Tcl_Obj *const objv[])	/* Argument objects. */
   540  {
   541      register Interp *iPtr = (Interp *) interp;
   542      const char *name, *bytes;
   543      Proc *procPtr;
   544      size_t numBytes;
   545  
   546      if (objc != 2) {
   547  	Tcl_WrongNumArgs(interp, 1, objv, "procname");
   548  	return TCL_ERROR;
   549      }
   550  
551 name = TclGetString(objv[1]); 552 procPtr = TclFindProc(iPtr, name);
553 if (procPtr == NULL) { 554 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 555 "\"%s\" isn't a procedure", name)); 556 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL); 557 return TCL_ERROR; 558 } 559
560 /* 561 * Here we used to return procPtr->bodyPtr, except when the body was 562 * bytecompiled - in that case, the return was a copy of the body's string 563 * rep. In order to better isolate the implementation details of the 564 * compiler/engine subsystem, we now always return a copy of the string 565 * rep. It is important to return a copy so that later manipulations of 566 * the object do not invalidate the internal rep. 567 */ 568 569 bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); 570 Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); 571 return TCL_OK;
572 } 573 574 /* 575 *---------------------------------------------------------------------- 576 * 577 * InfoCmdCountCmd -- 578 * 579 * Called to implement the "info cmdcount" command that returns the 580 * number of commands that have been executed. Handles the following 581 * syntax: 582 * 583 * info cmdcount 584 * 585 * Results: 586 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 587 * 588 * Side effects: 589 * Returns a result in the interpreter's result object. If there is an 590 * error, the result is an error message. 591 * 592 *---------------------------------------------------------------------- 593 */ 594 595 static int 596 InfoCmdCountCmd( 597 ClientData dummy, /* Not used. */ 598 Tcl_Interp *interp, /* Current interpreter. */ 599 int objc, /* Number of arguments. */ 600 Tcl_Obj *const objv[]) /* Argument objects. */ 601 { 602 Interp *iPtr = (Interp *) interp; 603 604 if (objc != 1) { 605 Tcl_WrongNumArgs(interp, 1, objv, NULL); 606 return TCL_ERROR; 607 } 608 609 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount)); 610 return TCL_OK; 611 } 612 613 /* 614 *---------------------------------------------------------------------- 615 * 616 * InfoCommandsCmd -- 617 * 618 * Called to implement the "info commands" command that returns the list 619 * of commands in the interpreter that match an optional pattern. The 620 * pattern, if any, consists of an optional sequence of namespace names 621 * separated by "::" qualifiers, which is followed by a glob-style 622 * pattern that restricts which commands are returned. Handles the 623 * following syntax: 624 * 625 * info commands ?pattern? 626 * 627 * Results: 628 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 629 * 630 * Side effects: 631 * Returns a result in the interpreter's result object. If there is an 632 * error, the result is an error message. 633 * 634 *---------------------------------------------------------------------- 635 */ 636 637 static int 638 InfoCommandsCmd( 639 ClientData dummy, /* Not used. */ 640 Tcl_Interp *interp, /* Current interpreter. */ 641 int objc, /* Number of arguments. */ 642 Tcl_Obj *const objv[]) /* Argument objects. */ 643 { 644 const char *cmdName, *pattern; 645 const char *simplePattern; 646 register Tcl_HashEntry *entryPtr; 647 Tcl_HashSearch search; 648 Namespace *nsPtr; 649 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 650 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 651 Tcl_Obj *listPtr, *elemObjPtr; 652 int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ 653 Tcl_Command cmd; 654 size_t i; 655 656 /* 657 * Get the pattern and find the "effective namespace" in which to list 658 * commands. 659 */ 660 661 if (objc == 1) { 662 simplePattern = NULL; 663 nsPtr = currNsPtr; 664 specificNsInPattern = 0; 665 } else if (objc == 2) { 666 /* 667 * From the pattern, get the effective namespace and the simple 668 * pattern (no namespace qualifiers or ::'s) at the end. If an error 669 * was found while parsing the pattern, return it. Otherwise, if the 670 * namespace wasn't found, just leave nsPtr NULL: we will return an 671 * empty list since no commands there can be found. 672 */ 673 674 Namespace *dummy1NsPtr, *dummy2NsPtr; 675 676 pattern = TclGetString(objv[1]); 677 TclGetNamespaceForQualName(interp, pattern, NULL, 0, &nsPtr, 678 &dummy1NsPtr, &dummy2NsPtr, &simplePattern); 679 680 if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ 681 specificNsInPattern = (strcmp(simplePattern, pattern) != 0); 682 } 683 } else { 684 Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); 685 return TCL_ERROR; 686 } 687 688 /* 689 * Exit as quickly as possible if we couldn't find the namespace. 690 */ 691 692 if (nsPtr == NULL) { 693 return TCL_OK; 694 } 695 696 /* 697 * Scan through the effective namespace's command table and create a list 698 * with all commands that match the pattern. If a specific namespace was 699 * requested in the pattern, qualify the command names with the namespace 700 * name. 701 */ 702 703 listPtr = Tcl_NewListObj(0, NULL); 704 705 if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { 706 /* 707 * Special case for when the pattern doesn't include any of glob's 708 * special characters. This lets us avoid scans of any hash tables. 709 */ 710 711 entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); 712 if (entryPtr != NULL) { 713 if (specificNsInPattern) { 714 cmd = Tcl_GetHashValue(entryPtr); 715 elemObjPtr = Tcl_NewObj(); 716 Tcl_GetCommandFullName(interp, cmd, elemObjPtr); 717 } else { 718 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 719 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 720 } 721 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 722 Tcl_SetObjResult(interp, listPtr); 723 return TCL_OK; 724 } 725 if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 726 Tcl_HashTable *tablePtr = NULL; /* Quell warning. */ 727 728 for (i=0 ; i<nsPtr->commandPathLength ; i++) { 729 Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; 730 731 if (pathNsPtr == NULL) { 732 continue; 733 } 734 tablePtr = &pathNsPtr->cmdTable; 735 entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); 736 if (entryPtr != NULL) { 737 break; 738 } 739 } 740 if (entryPtr == NULL) { 741 tablePtr = &globalNsPtr->cmdTable; 742 entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern); 743 } 744 if (entryPtr != NULL) { 745 cmdName = Tcl_GetHashKey(tablePtr, entryPtr); 746 Tcl_ListObjAppendElement(interp, listPtr, 747 Tcl_NewStringObj(cmdName, -1)); 748 Tcl_SetObjResult(interp, listPtr); 749 return TCL_OK; 750 } 751 } 752 } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) { 753 /* 754 * The pattern is non-trivial, but either there is no explicit path or 755 * there is an explicit namespace in the pattern. In both cases, the 756 * old matching scheme is perfect. 757 */ 758 759 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 760 while (entryPtr != NULL) { 761 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 762 if ((simplePattern == NULL) 763 || Tcl_StringMatch(cmdName, simplePattern)) { 764 if (specificNsInPattern) { 765 cmd = Tcl_GetHashValue(entryPtr); 766 elemObjPtr = Tcl_NewObj(); 767 Tcl_GetCommandFullName(interp, cmd, elemObjPtr); 768 } else { 769 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 770 } 771 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 772 } 773 entryPtr = Tcl_NextHashEntry(&search); 774 } 775 776 /* 777 * If the effective namespace isn't the global :: namespace, and a 778 * specific namespace wasn't requested in the pattern, then add in all 779 * global :: commands that match the simple pattern. Of course, we add 780 * in only those commands that aren't hidden by a command in the 781 * effective namespace. 782 */ 783 784 if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 785 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); 786 while (entryPtr != NULL) { 787 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); 788 if ((simplePattern == NULL) 789 || Tcl_StringMatch(cmdName, simplePattern)) { 790 if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { 791 Tcl_ListObjAppendElement(interp, listPtr, 792 Tcl_NewStringObj(cmdName, -1)); 793 } 794 } 795 entryPtr = Tcl_NextHashEntry(&search); 796 } 797 } 798 } else { 799 /* 800 * The pattern is non-trivial (can match more than one command name), 801 * there is an explicit path, and there is no explicit namespace in 802 * the pattern. This means that we have to traverse the path to 803 * discover all the commands defined. 804 */ 805 806 Tcl_HashTable addedCommandsTable; 807 int isNew; 808 int foundGlobal = (nsPtr == globalNsPtr); 809 810 /* 811 * We keep a hash of the objects already added to the result list. 812 */ 813 814 Tcl_InitObjHashTable(&addedCommandsTable); 815 816 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 817 while (entryPtr != NULL) { 818 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 819 if ((simplePattern == NULL) 820 || Tcl_StringMatch(cmdName, simplePattern)) { 821 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 822 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 823 (void) Tcl_CreateHashEntry(&addedCommandsTable, 824 elemObjPtr, &isNew); 825 } 826 entryPtr = Tcl_NextHashEntry(&search); 827 } 828 829 /* 830 * Search the path next. 831 */ 832 833 for (i=0 ; i<nsPtr->commandPathLength ; i++) { 834 Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr; 835 836 if (pathNsPtr == NULL) { 837 continue; 838 } 839 if (pathNsPtr == globalNsPtr) { 840 foundGlobal = 1; 841 } 842 entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search); 843 while (entryPtr != NULL) { 844 cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr); 845 if ((simplePattern == NULL) 846 || Tcl_StringMatch(cmdName, simplePattern)) { 847 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 848 (void) Tcl_CreateHashEntry(&addedCommandsTable, 849 elemObjPtr, &isNew); 850 if (isNew) { 851 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 852 } else { 853 TclDecrRefCount(elemObjPtr); 854 } 855 } 856 entryPtr = Tcl_NextHashEntry(&search); 857 } 858 } 859 860 /* 861 * If the effective namespace isn't the global :: namespace, and a 862 * specific namespace wasn't requested in the pattern, then add in all 863 * global :: commands that match the simple pattern. Of course, we add 864 * in only those commands that aren't hidden by a command in the 865 * effective namespace. 866 */ 867 868 if (!foundGlobal) { 869 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); 870 while (entryPtr != NULL) { 871 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); 872 if ((simplePattern == NULL) 873 || Tcl_StringMatch(cmdName, simplePattern)) { 874 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 875 if (Tcl_FindHashEntry(&addedCommandsTable, 876 (char *) elemObjPtr) == NULL) { 877 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 878 } else { 879 TclDecrRefCount(elemObjPtr); 880 } 881 } 882 entryPtr = Tcl_NextHashEntry(&search); 883 } 884 } 885 886 Tcl_DeleteHashTable(&addedCommandsTable); 887 } 888 889 Tcl_SetObjResult(interp, listPtr); 890 return TCL_OK; 891 } 892 893 /* 894 *---------------------------------------------------------------------- 895 * 896 * InfoCompleteCmd -- 897 * 898 * Called to implement the "info complete" command that determines 899 * whether a string is a complete Tcl command. Handles the following 900 * syntax: 901 * 902 * info complete command 903 * 904 * Results: 905 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 906 * 907 * Side effects: 908 * Returns a result in the interpreter's result object. If there is an 909 * error, the result is an error message. 910 * 911 *---------------------------------------------------------------------- 912 */ 913 914 static int 915 InfoCompleteCmd( 916 ClientData dummy, /* Not used. */ 917 Tcl_Interp *interp, /* Current interpreter. */ 918 int objc, /* Number of arguments. */ 919 Tcl_Obj *const objv[]) /* Argument objects. */ 920 { 921 if (objc != 2) { 922 Tcl_WrongNumArgs(interp, 1, objv, "command"); 923 return TCL_ERROR; 924 } 925 926 Tcl_SetObjResult(interp, Tcl_NewBooleanObj( 927 TclObjCommandComplete(objv[1]))); 928 return TCL_OK; 929 } 930 931 /* 932 *---------------------------------------------------------------------- 933 * 934 * InfoDefaultCmd -- 935 * 936 * Called to implement the "info default" command that returns the 937 * default value for a procedure argument. Handles the following syntax: 938 * 939 * info default procName arg varName 940 * 941 * Results: 942 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 943 * 944 * Side effects: 945 * Returns a result in the interpreter's result object. If there is an 946 * error, the result is an error message. 947 * 948 *---------------------------------------------------------------------- 949 */ 950 951 static int 952 InfoDefaultCmd( 953 ClientData dummy, /* Not used. */ 954 Tcl_Interp *interp, /* Current interpreter. */ 955 int objc, /* Number of arguments. */ 956 Tcl_Obj *const objv[]) /* Argument objects. */ 957 { 958 Interp *iPtr = (Interp *) interp; 959 const char *procName, *argName; 960 Proc *procPtr; 961 CompiledLocal *localPtr; 962 Tcl_Obj *valueObjPtr; 963 964 if (objc != 4) { 965 Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname"); 966 return TCL_ERROR; 967 } 968 969 procName = TclGetString(objv[1]); 970 argName = TclGetString(objv[2]); 971 972 procPtr = TclFindProc(iPtr, procName); 973 if (procPtr == NULL) { 974 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 975 "\"%s\" isn't a procedure", procName)); 976 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, 977 NULL); 978 return TCL_ERROR; 979 } 980 981 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; 982 localPtr = localPtr->nextPtr) { 983 if (TclIsVarArgument(localPtr) 984 && (strcmp(argName, localPtr->name) == 0)) { 985 if (localPtr->defValuePtr != NULL) { 986 valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, 987 localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); 988 if (valueObjPtr == NULL) { 989 return TCL_ERROR; 990 } 991 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); 992 } else { 993 Tcl_Obj *nullObjPtr = Tcl_NewObj(); 994 995 valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, 996 nullObjPtr, TCL_LEAVE_ERR_MSG); 997 if (valueObjPtr == NULL) { 998 return TCL_ERROR; 999 } 1000 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); 1001 } 1002 return TCL_OK; 1003 } 1004 } 1005 1006 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 1007 "procedure \"%s\" doesn't have an argument \"%s\"", 1008 procName, argName)); 1009 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); 1010 return TCL_ERROR; 1011 } 1012 1013 /* 1014 *---------------------------------------------------------------------- 1015 * 1016 * InfoErrorStackCmd -- 1017 * 1018 * Called to implement the "info errorstack" command that returns information 1019 * about the last error's call stack. Handles the following syntax: 1020 * 1021 * info errorstack ?interp? 1022 * 1023 * Results: 1024 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1025 * 1026 * Side effects: 1027 * Returns a result in the interpreter's result object. If there is an 1028 * error, the result is an error message. 1029 * 1030 *---------------------------------------------------------------------- 1031 */ 1032 1033 static int 1034 InfoErrorStackCmd( 1035 ClientData dummy, /* Not used. */ 1036 Tcl_Interp *interp, /* Current interpreter. */ 1037 int objc, /* Number of arguments. */ 1038 Tcl_Obj *const objv[]) /* Argument objects. */ 1039 { 1040 Tcl_Interp *target; 1041 Interp *iPtr; 1042 1043 if ((objc != 1) && (objc != 2)) { 1044 Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); 1045 return TCL_ERROR; 1046 } 1047 1048 target = interp; 1049 if (objc == 2) { 1050 target = Tcl_GetSlave(interp, TclGetString(objv[1])); 1051 if (target == NULL) { 1052 return TCL_ERROR; 1053 } 1054 } 1055 1056 iPtr = (Interp *) target; 1057 Tcl_SetObjResult(interp, iPtr->errorStack); 1058 1059 return TCL_OK; 1060 } 1061 1062 /* 1063 *---------------------------------------------------------------------- 1064 * 1065 * TclInfoExistsCmd -- 1066 * 1067 * Called to implement the "info exists" command that determines whether 1068 * a variable exists. Handles the following syntax: 1069 * 1070 * info exists varName 1071 * 1072 * Results: 1073 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1074 * 1075 * Side effects: 1076 * Returns a result in the interpreter's result object. If there is an 1077 * error, the result is an error message. 1078 * 1079 *---------------------------------------------------------------------- 1080 */ 1081 1082 int 1083 TclInfoExistsCmd( 1084 ClientData dummy, /* Not used. */ 1085 Tcl_Interp *interp, /* Current interpreter. */ 1086 int objc, /* Number of arguments. */ 1087 Tcl_Obj *const objv[]) /* Argument objects. */ 1088 { 1089 const char *varName; 1090 Var *varPtr; 1091 1092 if (objc != 2) { 1093 Tcl_WrongNumArgs(interp, 1, objv, "varName"); 1094 return TCL_ERROR; 1095 } 1096 1097 varName = TclGetString(objv[1]); 1098 varPtr = TclVarTraceExists(interp, varName); 1099 1100 Tcl_SetObjResult(interp, 1101 Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr)); 1102 return TCL_OK; 1103 } 1104 1105 /* 1106 *---------------------------------------------------------------------- 1107 * 1108 * InfoFrameCmd -- 1109 * TIP #280 1110 * 1111 * Called to implement the "info frame" command that returns the location 1112 * of either the currently executing command, or its caller. Handles the 1113 * following syntax: 1114 * 1115 * info frame ?number? 1116 * 1117 * Results: 1118 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1119 * 1120 * Side effects: 1121 * Returns a result in the interpreter's result object. If there is an 1122 * error, the result is an error message. 1123 * 1124 *---------------------------------------------------------------------- 1125 */ 1126 1127 static int 1128 InfoFrameCmd( 1129 ClientData dummy, /* Not used. */ 1130 Tcl_Interp *interp, /* Current interpreter. */ 1131 int objc, /* Number of arguments. */ 1132 Tcl_Obj *const objv[]) /* Argument objects. */ 1133 { 1134 Interp *iPtr = (Interp *) interp; 1135 int level, code = TCL_OK; 1136 CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; 1137 CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; 1138 int topLevel = 0; 1139 1140 if (objc > 2) { 1141 Tcl_WrongNumArgs(interp, 1, objv, "?number?"); 1142 return TCL_ERROR; 1143 } 1144 1145 while (corPtr) { 1146 while (*cmdFramePtrPtr) { 1147 topLevel++; 1148 cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); 1149 } 1150 if (corPtr->caller.cmdFramePtr) { 1151 *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; 1152 } 1153 corPtr = corPtr->callerEEPtr->corPtr; 1154 } 1155 topLevel += (*cmdFramePtrPtr)->level; 1156 1157 if (topLevel != iPtr->cmdFramePtr->level) { 1158 framePtr = iPtr->cmdFramePtr; 1159 while (framePtr) { 1160 framePtr->level = topLevel--; 1161 framePtr = framePtr->nextPtr; 1162 } 1163 if (topLevel) { 1164 Tcl_Panic("Broken frame level calculation"); 1165 } 1166 topLevel = iPtr->cmdFramePtr->level; 1167 } 1168 1169 if (objc == 1) { 1170 /* 1171 * Just "info frame". 1172 */ 1173 1174 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel)); 1175 goto done; 1176 } 1177 1178 /* 1179 * We've got "info frame level" and must parse the level first. 1180 */ 1181 1182 if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { 1183 code = TCL_ERROR; 1184 goto done; 1185 } 1186 1187 if ((level > topLevel) || (level <= - topLevel)) { 1188 levelError: 1189 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 1190 "bad level \"%s\"", TclGetString(objv[1]))); 1191 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", 1192 TclGetString(objv[1]), NULL); 1193 code = TCL_ERROR; 1194 goto done; 1195 } 1196 1197 /* 1198 * Let us convert to relative so that we know how many levels to go back 1199 */ 1200 1201 if (level > 0) { 1202 level -= topLevel; 1203 } 1204 1205 framePtr = iPtr->cmdFramePtr; 1206 while (++level <= 0) { 1207 framePtr = framePtr->nextPtr; 1208 if (!framePtr) { 1209 goto levelError; 1210 } 1211 } 1212 1213 Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); 1214 1215 done: 1216 cmdFramePtrPtr = &iPtr->cmdFramePtr; 1217 corPtr = iPtr->execEnvPtr->corPtr; 1218 while (corPtr) { 1219 CmdFrame *endPtr = corPtr->caller.cmdFramePtr; 1220 1221 if (endPtr) { 1222 if (*cmdFramePtrPtr == endPtr) { 1223 *cmdFramePtrPtr = NULL; 1224 } else { 1225 CmdFrame *runPtr = *cmdFramePtrPtr; 1226 1227 while (runPtr->nextPtr != endPtr) { 1228 runPtr->level -= endPtr->level; 1229 runPtr = runPtr->nextPtr; 1230 } 1231 runPtr->level = 1; 1232 runPtr->nextPtr = NULL; 1233 } 1234 cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; 1235 } 1236 corPtr = corPtr->callerEEPtr->corPtr; 1237 } 1238 return code; 1239 } 1240 1241 /* 1242 *---------------------------------------------------------------------- 1243 * 1244 * TclInfoFrame -- 1245 * 1246 * Core of InfoFrameCmd, returns TIP280 dict for a given frame. 1247 * 1248 * Results: 1249 * Returns TIP280 dict. 1250 * 1251 * Side effects: 1252 * None. 1253 * 1254 *---------------------------------------------------------------------- 1255 */ 1256 1257 Tcl_Obj * 1258 TclInfoFrame( 1259 Tcl_Interp *interp, /* Current interpreter. */ 1260 CmdFrame *framePtr) /* Frame to get info for. */ 1261 { 1262 Interp *iPtr = (Interp *) interp; 1263 Tcl_Obj *tmpObj; 1264 Tcl_Obj *lv[20]; /* Keep uptodate when more keys are added to 1265 * the dict. */ 1266 int lc = 0; 1267 /* 1268 * This array is indexed by the TCL_LOCATION_... values, except 1269 * for _LAST. 1270 */ 1271 static const char *const typeString[TCL_LOCATION_LAST] = { 1272 "eval", "eval", "eval", "precompiled", "source", "proc" 1273 }; 1274 Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; 1275 int needsFree = -1; 1276 1277 /* 1278 * Pull the information and construct the dictionary to return, as list. 1279 * Regarding use of the CmdFrame fields see tclInt.h, and its definition. 1280 */ 1281 1282 #define ADD_PAIR(name, value) \ 1283 TclNewLiteralStringObj(tmpObj, name); \ 1284 lv[lc++] = tmpObj; \ 1285 lv[lc++] = (value) 1286 1287 switch (framePtr->type) { 1288 case TCL_LOCATION_EVAL: 1289 /* 1290 * Evaluation, dynamic script. Type, line, cmd, the latter through 1291 * str. 1292 */ 1293 1294 ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); 1295 if (framePtr->line) { 1296 ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); 1297 } else { 1298 ADD_PAIR("line", Tcl_NewWideIntObj(1)); 1299 } 1300 ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); 1301 break; 1302 1303 case TCL_LOCATION_PREBC: 1304 /* 1305 * Precompiled. Result contains the type as signal, nothing else. 1306 */ 1307 1308 ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); 1309 break; 1310 1311 case TCL_LOCATION_BC: { 1312 /* 1313 * Execution of bytecode. Talk to the BC engine to fill out the frame. 1314 */ 1315 1316 CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame)); 1317 1318 *fPtr = *framePtr; 1319 1320 /* 1321 * Note: 1322 * Type BC => f.data.eval.path is not used. 1323 * f.data.tebc.codePtr is used instead. 1324 */ 1325 1326 TclGetSrcInfoForPc(fPtr); 1327 1328 /* 1329 * Now filled: cmd.str.(cmd,len), line 1330 * Possibly modified: type, path! 1331 */ 1332 1333 ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); 1334 if (fPtr->line) { 1335 ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0])); 1336 } 1337 1338 if (fPtr->type == TCL_LOCATION_SOURCE) { 1339 ADD_PAIR("file", fPtr->data.eval.path); 1340 1341 /* 1342 * Death of reference by TclGetSrcInfoForPc. 1343 */ 1344 1345 Tcl_DecrRefCount(fPtr->data.eval.path); 1346 } 1347 1348 ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); 1349 if (fPtr->cmdObj && framePtr->cmdObj == NULL) { 1350 needsFree = lc - 1; 1351 } 1352 TclStackFree(interp, fPtr); 1353 break; 1354 } 1355 1356 case TCL_LOCATION_SOURCE: 1357 /* 1358 * Evaluation of a script file. 1359 */ 1360 1361 ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); 1362 ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); 1363 ADD_PAIR("file", framePtr->data.eval.path); 1364 1365 /* 1366 * Refcount framePtr->data.eval.path goes up when lv is converted into 1367 * the result list object. 1368 */ 1369 1370 ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); 1371 break; 1372 1373 case TCL_LOCATION_PROC: 1374 Tcl_Panic("TCL_LOCATION_PROC found in standard frame"); 1375 break; 1376 } 1377 1378 /* 1379 * 'proc'. Common to all frame types. Conditional on having an associated 1380 * Procedure CallFrame. 1381 */ 1382 1383 if (procPtr != NULL) { 1384 Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; 1385 1386 if (namePtr) { 1387 Tcl_Obj *procNameObj; 1388 1389 /* 1390 * This is a regular command. 1391 */ 1392 1393 TclNewObj(procNameObj); 1394 Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr, 1395 procNameObj); 1396 ADD_PAIR("proc", procNameObj); 1397 } else if (procPtr->cmdPtr->clientData) { 1398 ExtraFrameInfo *efiPtr = procPtr->cmdPtr->clientData; 1399 size_t i; 1400 1401 /* 1402 * This is a non-standard command. Luckily, it's told us how to 1403 * render extra information about its frame. 1404 */ 1405 1406 for (i=0 ; i<efiPtr->length ; i++) { 1407 lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1); 1408 if (efiPtr->fields[i].proc) { 1409 lv[lc++] = 1410 efiPtr->fields[i].proc(efiPtr->fields[i].clientData); 1411 } else { 1412 lv[lc++] = efiPtr->fields[i].clientData; 1413 } 1414 } 1415 } 1416 } 1417 1418 /* 1419 * 'level'. Common to all frame types. Conditional on having an associated 1420 * _visible_ CallFrame. 1421 */ 1422 1423 if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { 1424 CallFrame *current = framePtr->framePtr; 1425 CallFrame *top = iPtr->varFramePtr; 1426 CallFrame *idx; 1427 1428 for (idx=top ; idx!=NULL ; idx=idx->callerVarPtr) { 1429 if (idx == current) { 1430 int c = framePtr->framePtr->level; 1431 int t = iPtr->varFramePtr->level; 1432 1433 ADD_PAIR("level", Tcl_NewWideIntObj(t - c)); 1434 break; 1435 } 1436 } 1437 } 1438 1439 tmpObj = Tcl_NewListObj(lc, lv); 1440 if (needsFree >= 0) { 1441 Tcl_DecrRefCount(lv[needsFree]); 1442 } 1443 return tmpObj; 1444 } 1445 1446 /* 1447 *---------------------------------------------------------------------- 1448 * 1449 * InfoFunctionsCmd -- 1450 * 1451 * Called to implement the "info functions" command that returns the list 1452 * of math functions matching an optional pattern. Handles the following 1453 * syntax: 1454 * 1455 * info functions ?pattern? 1456 * 1457 * Results: 1458 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1459 * 1460 * Side effects: 1461 * Returns a result in the interpreter's result object. If there is an 1462 * error, the result is an error message. 1463 * 1464 *---------------------------------------------------------------------- 1465 */ 1466 1467 static int 1468 InfoFunctionsCmd( 1469 ClientData dummy, /* Not used. */ 1470 Tcl_Interp *interp, /* Current interpreter. */ 1471 int objc, /* Number of arguments. */ 1472 Tcl_Obj *const objv[]) /* Argument objects. */ 1473 { 1474 Tcl_Obj *script; 1475 int code; 1476 1477 if (objc > 2) { 1478 Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); 1479 return TCL_ERROR; 1480 } 1481 1482 script = Tcl_NewStringObj( 1483 " ::apply [::list {{pattern *}} {\n" 1484 " ::set cmds {}\n" 1485 " ::foreach cmd [::info commands ::tcl::mathfunc::$pattern] {\n" 1486 " ::lappend cmds [::namespace tail $cmd]\n" 1487 " }\n" 1488 " ::foreach cmd [::info commands tcl::mathfunc::$pattern] {\n" 1489 " ::set cmd [::namespace tail $cmd]\n" 1490 " ::if {$cmd ni $cmds} {\n" 1491 " ::lappend cmds $cmd\n" 1492 " }\n" 1493 " }\n" 1494 " ::return $cmds\n" 1495 " } [::namespace current]] ", -1); 1496 1497 if (objc == 2) { 1498 Tcl_Obj *arg = Tcl_NewListObj(1, &(objv[1])); 1499 1500 Tcl_AppendObjToObj(script, arg); 1501 Tcl_DecrRefCount(arg); 1502 } 1503 1504 Tcl_IncrRefCount(script); 1505 code = Tcl_EvalObjEx(interp, script, 0); 1506 1507 Tcl_DecrRefCount(script); 1508 1509 return code; 1510 } 1511 1512 /* 1513 *---------------------------------------------------------------------- 1514 * 1515 * InfoHostnameCmd -- 1516 * 1517 * Called to implement the "info hostname" command that returns the host 1518 * name. Handles the following syntax: 1519 * 1520 * info hostname 1521 * 1522 * Results: 1523 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1524 * 1525 * Side effects: 1526 * Returns a result in the interpreter's result object. If there is an 1527 * error, the result is an error message. 1528 * 1529 *---------------------------------------------------------------------- 1530 */ 1531 1532 static int 1533 InfoHostnameCmd( 1534 ClientData dummy, /* Not used. */ 1535 Tcl_Interp *interp, /* Current interpreter. */ 1536 int objc, /* Number of arguments. */ 1537 Tcl_Obj *const objv[]) /* Argument objects. */ 1538 { 1539 const char *name; 1540 1541 if (objc != 1) { 1542 Tcl_WrongNumArgs(interp, 1, objv, NULL); 1543 return TCL_ERROR; 1544 } 1545 1546 name = Tcl_GetHostName(); 1547 if (name) { 1548 Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); 1549 return TCL_OK; 1550 } 1551 1552 Tcl_SetObjResult(interp, Tcl_NewStringObj( 1553 "unable to determine name of host", -1)); 1554 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL); 1555 return TCL_ERROR; 1556 } 1557 1558 /* 1559 *---------------------------------------------------------------------- 1560 * 1561 * InfoLevelCmd -- 1562 * 1563 * Called to implement the "info level" command that returns information 1564 * about the call stack. Handles the following syntax: 1565 * 1566 * info level ?number? 1567 * 1568 * Results: 1569 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1570 * 1571 * Side effects: 1572 * Returns a result in the interpreter's result object. If there is an 1573 * error, the result is an error message. 1574 * 1575 *---------------------------------------------------------------------- 1576 */ 1577 1578 static int 1579 InfoLevelCmd( 1580 ClientData dummy, /* Not used. */ 1581 Tcl_Interp *interp, /* Current interpreter. */ 1582 int objc, /* Number of arguments. */ 1583 Tcl_Obj *const objv[]) /* Argument objects. */ 1584 { 1585 Interp *iPtr = (Interp *) interp; 1586 1587 if (objc == 1) { /* Just "info level" */ 1588 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); 1589 return TCL_OK; 1590 } 1591 1592 if (objc == 2) { 1593 int level; 1594 CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr; 1595 1596 if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { 1597 return TCL_ERROR; 1598 } 1599 if (level <= 0) { 1600 if (iPtr->varFramePtr == rootFramePtr) { 1601 goto levelError; 1602 } 1603 level += iPtr->varFramePtr->level; 1604 } 1605 for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; 1606 framePtr=framePtr->callerVarPtr) { 1607 if (framePtr->level == level) { 1608 break; 1609 } 1610 } 1611 if (framePtr == rootFramePtr) { 1612 goto levelError; 1613 } 1614 1615 Tcl_SetObjResult(interp, 1616 Tcl_NewListObj(framePtr->objc, framePtr->objv)); 1617 return TCL_OK; 1618 } 1619 1620 Tcl_WrongNumArgs(interp, 1, objv, "?number?"); 1621 return TCL_ERROR; 1622 1623 levelError: 1624 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 1625 "bad level \"%s\"", TclGetString(objv[1]))); 1626 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", 1627 TclGetString(objv[1]), NULL); 1628 return TCL_ERROR; 1629 } 1630 1631 /* 1632 *---------------------------------------------------------------------- 1633 * 1634 * InfoLibraryCmd -- 1635 * 1636 * Called to implement the "info library" command that returns the 1637 * library directory for the Tcl installation. Handles the following 1638 * syntax: 1639 * 1640 * info library 1641 * 1642 * Results: 1643 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1644 * 1645 * Side effects: 1646 * Returns a result in the interpreter's result object. If there is an 1647 * error, the result is an error message. 1648 * 1649 *---------------------------------------------------------------------- 1650 */ 1651 1652 static int 1653 InfoLibraryCmd( 1654 ClientData dummy, /* Not used. */ 1655 Tcl_Interp *interp, /* Current interpreter. */ 1656 int objc, /* Number of arguments. */ 1657 Tcl_Obj *const objv[]) /* Argument objects. */ 1658 { 1659 const char *libDirName; 1660 1661 if (objc != 1) { 1662 Tcl_WrongNumArgs(interp, 1, objv, NULL); 1663 return TCL_ERROR; 1664 } 1665 1666 libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); 1667 if (libDirName != NULL) { 1668 Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); 1669 return TCL_OK; 1670 } 1671 1672 Tcl_SetObjResult(interp, Tcl_NewStringObj( 1673 "no library has been specified for Tcl", -1)); 1674 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL); 1675 return TCL_ERROR; 1676 } 1677 1678 /* 1679 *---------------------------------------------------------------------- 1680 * 1681 * InfoLoadedCmd -- 1682 * 1683 * Called to implement the "info loaded" command that returns the 1684 * packages that have been loaded into an interpreter. Handles the 1685 * following syntax: 1686 * 1687 * info loaded ?interp? 1688 * 1689 * Results: 1690 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1691 * 1692 * Side effects: 1693 * Returns a result in the interpreter's result object. If there is an 1694 * error, the result is an error message. 1695 * 1696 *---------------------------------------------------------------------- 1697 */ 1698 1699 static int 1700 InfoLoadedCmd( 1701 ClientData dummy, /* Not used. */ 1702 Tcl_Interp *interp, /* Current interpreter. */ 1703 int objc, /* Number of arguments. */ 1704 Tcl_Obj *const objv[]) /* Argument objects. */ 1705 { 1706 const char *interpName, *packageName; 1707 1708 if (objc > 3) { 1709 Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); 1710 return TCL_ERROR; 1711 } 1712 1713 if (objc < 2) { /* Get loaded pkgs in all interpreters. */ 1714 interpName = NULL; 1715 } else { /* Get pkgs just in specified interp. */ 1716 interpName = TclGetString(objv[1]); 1717 } 1718 if (objc < 3) { /* Get loaded files in all packages. */ 1719 packageName = NULL; 1720 } else { /* Get pkgs just in specified interp. */ 1721 packageName = TclGetString(objv[2]); 1722 } 1723 return TclGetLoadedPackagesEx(interp, interpName, packageName); 1724 } 1725 1726 /* 1727 *---------------------------------------------------------------------- 1728 * 1729 * InfoNameOfExecutableCmd -- 1730 * 1731 * Called to implement the "info nameofexecutable" command that returns 1732 * the name of the binary file running this application. Handles the 1733 * following syntax: 1734 * 1735 * info nameofexecutable 1736 * 1737 * Results: 1738 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1739 * 1740 * Side effects: 1741 * Returns a result in the interpreter's result object. If there is an 1742 * error, the result is an error message. 1743 * 1744 *---------------------------------------------------------------------- 1745 */ 1746 1747 static int 1748 InfoNameOfExecutableCmd( 1749 ClientData dummy, /* Not used. */ 1750 Tcl_Interp *interp, /* Current interpreter. */ 1751 int objc, /* Number of arguments. */ 1752 Tcl_Obj *const objv[]) /* Argument objects. */ 1753 { 1754 if (objc != 1) { 1755 Tcl_WrongNumArgs(interp, 1, objv, NULL); 1756 return TCL_ERROR; 1757 } 1758 Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); 1759 return TCL_OK; 1760 } 1761 1762 /* 1763 *---------------------------------------------------------------------- 1764 * 1765 * InfoPatchLevelCmd -- 1766 * 1767 * Called to implement the "info patchlevel" command that returns the 1768 * default value for an argument to a procedure. Handles the following 1769 * syntax: 1770 * 1771 * info patchlevel 1772 * 1773 * Results: 1774 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1775 * 1776 * Side effects: 1777 * Returns a result in the interpreter's result object. If there is an 1778 * error, the result is an error message. 1779 * 1780 *---------------------------------------------------------------------- 1781 */ 1782 1783 static int 1784 InfoPatchLevelCmd( 1785 ClientData dummy, /* Not used. */ 1786 Tcl_Interp *interp, /* Current interpreter. */ 1787 int objc, /* Number of arguments. */ 1788 Tcl_Obj *const objv[]) /* Argument objects. */ 1789 { 1790 const char *patchlevel; 1791 1792 if (objc != 1) { 1793 Tcl_WrongNumArgs(interp, 1, objv, NULL); 1794 return TCL_ERROR; 1795 } 1796 1797 patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, 1798 (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 1799 if (patchlevel != NULL) { 1800 Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); 1801 return TCL_OK; 1802 } 1803 return TCL_ERROR; 1804 } 1805 1806 /* 1807 *---------------------------------------------------------------------- 1808 * 1809 * InfoProcsCmd -- 1810 * 1811 * Called to implement the "info procs" command that returns the list of 1812 * procedures in the interpreter that match an optional pattern. The 1813 * pattern, if any, consists of an optional sequence of namespace names 1814 * separated by "::" qualifiers, which is followed by a glob-style 1815 * pattern that restricts which commands are returned. Handles the 1816 * following syntax: 1817 * 1818 * info procs ?pattern? 1819 * 1820 * Results: 1821 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 1822 * 1823 * Side effects: 1824 * Returns a result in the interpreter's result object. If there is an 1825 * error, the result is an error message. 1826 * 1827 *---------------------------------------------------------------------- 1828 */ 1829 1830 static int 1831 InfoProcsCmd( 1832 ClientData dummy, /* Not used. */ 1833 Tcl_Interp *interp, /* Current interpreter. */ 1834 int objc, /* Number of arguments. */ 1835 Tcl_Obj *const objv[]) /* Argument objects. */ 1836 { 1837 const char *cmdName, *pattern; 1838 const char *simplePattern; 1839 Namespace *nsPtr; 1840 #ifdef INFO_PROCS_SEARCH_GLOBAL_NS 1841 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 1842 #endif 1843 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 1844 Tcl_Obj *listPtr, *elemObjPtr; 1845 int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ 1846 register Tcl_HashEntry *entryPtr; 1847 Tcl_HashSearch search; 1848 Command *cmdPtr, *realCmdPtr; 1849 1850 /* 1851 * Get the pattern and find the "effective namespace" in which to list 1852 * procs. 1853 */ 1854 1855 if (objc == 1) { 1856 simplePattern = NULL; 1857 nsPtr = currNsPtr; 1858 specificNsInPattern = 0; 1859 } else if (objc == 2) { 1860 /* 1861 * From the pattern, get the effective namespace and the simple 1862 * pattern (no namespace qualifiers or ::'s) at the end. If an error 1863 * was found while parsing the pattern, return it. Otherwise, if the 1864 * namespace wasn't found, just leave nsPtr NULL: we will return an 1865 * empty list since no commands there can be found. 1866 */ 1867 1868 Namespace *dummy1NsPtr, *dummy2NsPtr; 1869 1870 pattern = TclGetString(objv[1]); 1871 TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, &nsPtr, 1872 &dummy1NsPtr, &dummy2NsPtr, &simplePattern); 1873 1874 if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ 1875 specificNsInPattern = (strcmp(simplePattern, pattern) != 0); 1876 } 1877 } else { 1878 Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); 1879 return TCL_ERROR; 1880 } 1881 1882 if (nsPtr == NULL) { 1883 return TCL_OK; 1884 } 1885 1886 /* 1887 * Scan through the effective namespace's command table and create a list 1888 * with all procs that match the pattern. If a specific namespace was 1889 * requested in the pattern, qualify the command names with the namespace 1890 * name. 1891 */ 1892 1893 listPtr = Tcl_NewListObj(0, NULL); 1894 #ifndef INFO_PROCS_SEARCH_GLOBAL_NS 1895 if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { 1896 entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); 1897 if (entryPtr != NULL) { 1898 cmdPtr = Tcl_GetHashValue(entryPtr); 1899 1900 if (!TclIsProc(cmdPtr)) { 1901 realCmdPtr = (Command *) 1902 TclGetOriginalCommand((Tcl_Command) cmdPtr); 1903 if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { 1904 goto simpleProcOK; 1905 } 1906 } else { 1907 simpleProcOK: 1908 if (specificNsInPattern) { 1909 elemObjPtr = Tcl_NewObj(); 1910 Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, 1911 elemObjPtr); 1912 } else { 1913 elemObjPtr = Tcl_NewStringObj(simplePattern, -1); 1914 } 1915 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 1916 } 1917 } 1918 } else 1919 #endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ 1920 { 1921 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 1922 while (entryPtr != NULL) { 1923 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); 1924 if ((simplePattern == NULL) 1925 || Tcl_StringMatch(cmdName, simplePattern)) { 1926 cmdPtr = Tcl_GetHashValue(entryPtr); 1927 1928 if (!TclIsProc(cmdPtr)) { 1929 realCmdPtr = (Command *) 1930 TclGetOriginalCommand((Tcl_Command) cmdPtr); 1931 if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { 1932 goto procOK; 1933 } 1934 } else { 1935 procOK: 1936 if (specificNsInPattern) { 1937 elemObjPtr = Tcl_NewObj(); 1938 Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, 1939 elemObjPtr); 1940 } else { 1941 elemObjPtr = Tcl_NewStringObj(cmdName, -1); 1942 } 1943 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); 1944 } 1945 } 1946 entryPtr = Tcl_NextHashEntry(&search); 1947 } 1948 1949 /* 1950 * If the effective namespace isn't the global :: namespace, and a 1951 * specific namespace wasn't requested in the pattern, then add in all 1952 * global :: procs that match the simple pattern. Of course, we add in 1953 * only those procs that aren't hidden by a proc in the effective 1954 * namespace. 1955 */ 1956 1957 #ifdef INFO_PROCS_SEARCH_GLOBAL_NS 1958 /* 1959 * If "info procs" worked like "info commands", returning the commands 1960 * also seen in the global namespace, then you would include this 1961 * code. As this could break backwards compatibilty with 8.0-8.2, we 1962 * decided not to "fix" it in 8.3, leaving the behavior slightly 1963 * different. 1964 */ 1965 1966 if ((nsPtr != globalNsPtr) && !specificNsInPattern) { 1967 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); 1968 while (entryPtr != NULL) { 1969 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); 1970 if ((simplePattern == NULL) 1971 || Tcl_StringMatch(cmdName, simplePattern)) { 1972 if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { 1973 cmdPtr = Tcl_GetHashValue(entryPtr); 1974 realCmdPtr = (Command *) TclGetOriginalCommand( 1975 (Tcl_Command) cmdPtr); 1976 1977 if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) 1978 && TclIsProc(realCmdPtr))) { 1979 Tcl_ListObjAppendElement(interp, listPtr, 1980 Tcl_NewStringObj(cmdName, -1)); 1981 } 1982 } 1983 } 1984 entryPtr = Tcl_NextHashEntry(&search); 1985 } 1986 } 1987 #endif 1988 } 1989 1990 Tcl_SetObjResult(interp, listPtr); 1991 return TCL_OK; 1992 } 1993 1994 /* 1995 *---------------------------------------------------------------------- 1996 * 1997 * InfoScriptCmd -- 1998 * 1999 * Called to implement the "info script" command that returns the script 2000 * file that is currently being evaluated. Handles the following syntax: 2001 * 2002 * info script ?newName? 2003 * 2004 * If newName is specified, it will set that as the internal name. 2005 * 2006 * Results: 2007 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2008 * 2009 * Side effects: 2010 * Returns a result in the interpreter's result object. If there is an 2011 * error, the result is an error message. It may change the internal 2012 * script filename. 2013 * 2014 *---------------------------------------------------------------------- 2015 */ 2016 2017 static int 2018 InfoScriptCmd( 2019 ClientData dummy, /* Not used. */ 2020 Tcl_Interp *interp, /* Current interpreter. */ 2021 int objc, /* Number of arguments. */ 2022 Tcl_Obj *const objv[]) /* Argument objects. */ 2023 { 2024 Interp *iPtr = (Interp *) interp; 2025 if ((objc != 1) && (objc != 2)) { 2026 Tcl_WrongNumArgs(interp, 1, objv, "?filename?"); 2027 return TCL_ERROR; 2028 } 2029 2030 if (objc == 2) { 2031 if (iPtr->scriptFile != NULL) { 2032 Tcl_DecrRefCount(iPtr->scriptFile); 2033 } 2034 iPtr->scriptFile = objv[1]; 2035 Tcl_IncrRefCount(iPtr->scriptFile); 2036 } 2037 if (iPtr->scriptFile != NULL) { 2038 Tcl_SetObjResult(interp, iPtr->scriptFile); 2039 } 2040 return TCL_OK; 2041 } 2042 2043 /* 2044 *---------------------------------------------------------------------- 2045 * 2046 * InfoSharedlibCmd -- 2047 * 2048 * Called to implement the "info sharedlibextension" command that returns 2049 * the file extension used for shared libraries. Handles the following 2050 * syntax: 2051 * 2052 * info sharedlibextension 2053 * 2054 * Results: 2055 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2056 * 2057 * Side effects: 2058 * Returns a result in the interpreter's result object. If there is an 2059 * error, the result is an error message. 2060 * 2061 *---------------------------------------------------------------------- 2062 */ 2063 2064 static int 2065 InfoSharedlibCmd( 2066 ClientData dummy, /* Not used. */ 2067 Tcl_Interp *interp, /* Current interpreter. */ 2068 int objc, /* Number of arguments. */ 2069 Tcl_Obj *const objv[]) /* Argument objects. */ 2070 { 2071 if (objc != 1) { 2072 Tcl_WrongNumArgs(interp, 1, objv, NULL); 2073 return TCL_ERROR; 2074 } 2075 2076 #ifdef TCL_SHLIB_EXT 2077 Tcl_SetObjResult(interp, Tcl_NewStringObj(TCL_SHLIB_EXT, -1)); 2078 #endif 2079 return TCL_OK; 2080 } 2081 2082 /* 2083 *---------------------------------------------------------------------- 2084 * 2085 * InfoTclVersionCmd -- 2086 * 2087 * Called to implement the "info tclversion" command that returns the 2088 * version number for this Tcl library. Handles the following syntax: 2089 * 2090 * info tclversion 2091 * 2092 * Results: 2093 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2094 * 2095 * Side effects: 2096 * Returns a result in the interpreter's result object. If there is an 2097 * error, the result is an error message. 2098 * 2099 *---------------------------------------------------------------------- 2100 */ 2101 2102 static int 2103 InfoTclVersionCmd( 2104 ClientData dummy, /* Not used. */ 2105 Tcl_Interp *interp, /* Current interpreter. */ 2106 int objc, /* Number of arguments. */ 2107 Tcl_Obj *const objv[]) /* Argument objects. */ 2108 { 2109 Tcl_Obj *version; 2110 2111 if (objc != 1) { 2112 Tcl_WrongNumArgs(interp, 1, objv, NULL); 2113 return TCL_ERROR; 2114 } 2115 2116 version = Tcl_GetVar2Ex(interp, "tcl_version", NULL, 2117 (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 2118 if (version != NULL) { 2119 Tcl_SetObjResult(interp, version); 2120 return TCL_OK; 2121 } 2122 return TCL_ERROR; 2123 } 2124 2125 /* 2126 *---------------------------------------------------------------------- 2127 * 2128 * InfoCmdTypeCmd -- 2129 * 2130 * Called to implement the "info cmdtype" command that returns the type 2131 * of a given command. Handles the following syntax: 2132 * 2133 * info cmdtype cmdName 2134 * 2135 * Results: 2136 * Returns TCL_OK if successful and TCL_ERROR if there is an error. 2137 * 2138 * Side effects: 2139 * Returns a type name. If there is an error, the result is an error 2140 * message. 2141 * 2142 *---------------------------------------------------------------------- 2143 */ 2144 2145 static int 2146 InfoCmdTypeCmd( 2147 ClientData dummy, /* Not used. */ 2148 Tcl_Interp *interp, /* Current interpreter. */ 2149 int objc, /* Number of arguments. */ 2150 Tcl_Obj *const objv[]) /* Argument objects. */ 2151 { 2152 Tcl_Command command; 2153 2154 if (objc != 2) { 2155 Tcl_WrongNumArgs(interp, 1, objv, "commandName"); 2156 return TCL_ERROR; 2157 } 2158 command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, 2159 TCL_LEAVE_ERR_MSG); 2160 if (command == NULL) { 2161 return TCL_ERROR; 2162 } 2163 2164 /* 2165 * There's one special case: safe slave interpreters can't see aliases as 2166 * aliases as they're part of the security mechanisms. 2167 */ 2168 2169 if (Tcl_IsSafe(interp) 2170 && (((Command *) command)->objProc == TclAliasObjCmd)) { 2171 Tcl_AppendResult(interp, "native", NULL); 2172 } else { 2173 Tcl_SetObjResult(interp, 2174 Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); 2175 } 2176 return TCL_OK; 2177 } 2178 2179 /* 2180 *---------------------------------------------------------------------- 2181 * 2182 * Tcl_JoinObjCmd -- 2183 * 2184 * This procedure is invoked to process the "join" Tcl command. See the 2185 * user documentation for details on what it does. 2186 * 2187 * Results: 2188 * A standard Tcl object result. 2189 * 2190 * Side effects: 2191 * See the user documentation. 2192 * 2193 *---------------------------------------------------------------------- 2194 */ 2195 2196 int 2197 Tcl_JoinObjCmd( 2198 ClientData dummy, /* Not used. */ 2199 Tcl_Interp *interp, /* Current interpreter. */ 2200 int objc, /* Number of arguments. */ 2201 Tcl_Obj *const objv[]) /* The argument objects. */ 2202 { 2203 size_t length; 2204 int listLen; 2205 Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; 2206 2207 if ((objc < 2) || (objc > 3)) { 2208 Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); 2209 return TCL_ERROR; 2210 } 2211 2212 /* 2213 * Make sure the list argument is a list object and get its length and a 2214 * pointer to its array of element pointers. 2215 */ 2216 2217 if (TclListObjGetElements(interp, objv[1], &listLen, 2218 &elemPtrs) != TCL_OK) { 2219 return TCL_ERROR; 2220 } 2221 2222 if (listLen == 0) { 2223 /* No elements to join; default empty result is correct. */ 2224 return TCL_OK; 2225 } 2226 if (listLen == 1) { 2227 /* One element; return it */ 2228 Tcl_SetObjResult(interp, elemPtrs[0]); 2229 return TCL_OK; 2230 } 2231 2232 joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; 2233 Tcl_IncrRefCount(joinObjPtr); 2234 2235 (void) TclGetStringFromObj(joinObjPtr, &length); 2236 if (length == 0) { 2237 resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); 2238 } else { 2239 int i; 2240 2241 resObjPtr = Tcl_NewObj(); 2242 for (i = 0; i < listLen; i++) { 2243 if (i > 0) { 2244 2245 /* 2246 * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** 2247 * to shimmer joinObjPtr. If it did, then the case where 2248 * objv[1] and objv[2] are the same value would not be safe. 2249 * Accessing elemPtrs would crash. 2250 */ 2251 2252 Tcl_AppendObjToObj(resObjPtr, joinObjPtr); 2253 } 2254 Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); 2255 } 2256 } 2257 Tcl_DecrRefCount(joinObjPtr); 2258 if (resObjPtr) { 2259 Tcl_SetObjResult(interp, resObjPtr); 2260 return TCL_OK; 2261 } 2262 return TCL_ERROR; 2263 } 2264 2265 /* 2266 *---------------------------------------------------------------------- 2267 * 2268 * Tcl_LassignObjCmd -- 2269 * 2270 * This object-based procedure is invoked to process the "lassign" Tcl 2271 * command. See the user documentation for details on what it does. 2272 * 2273 * Results: 2274 * A standard Tcl object result. 2275 * 2276 * Side effects: 2277 * See the user documentation. 2278 * 2279 *---------------------------------------------------------------------- 2280 */ 2281 2282 int 2283 Tcl_LassignObjCmd( 2284 ClientData dummy, /* Not used. */ 2285 Tcl_Interp *interp, /* Current interpreter. */ 2286 int objc, /* Number of arguments. */ 2287 Tcl_Obj *const objv[]) /* Argument objects. */ 2288 { 2289 Tcl_Obj *listCopyPtr; 2290 Tcl_Obj **listObjv; /* The contents of the list. */ 2291 int listObjc; /* The length of the list. */ 2292 int code = TCL_OK; 2293 2294 if (objc < 2) { 2295 Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); 2296 return TCL_ERROR; 2297 } 2298 2299 listCopyPtr = TclListObjCopy(interp, objv[1]); 2300 if (listCopyPtr == NULL) { 2301 return TCL_ERROR; 2302 } 2303 2304 TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); 2305 2306 objc -= 2; 2307 objv += 2; 2308 while (code == TCL_OK && objc > 0 && listObjc > 0) { 2309 if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, 2310 TCL_LEAVE_ERR_MSG) == NULL) { 2311 code = TCL_ERROR; 2312 } 2313 objc--; 2314 listObjc--; 2315 } 2316 2317 if (code == TCL_OK && objc > 0) { 2318 Tcl_Obj *emptyObj; 2319 2320 TclNewObj(emptyObj); 2321 Tcl_IncrRefCount(emptyObj); 2322 while (code == TCL_OK && objc-- > 0) { 2323 if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, 2324 TCL_LEAVE_ERR_MSG) == NULL) { 2325 code = TCL_ERROR; 2326 } 2327 } 2328 Tcl_DecrRefCount(emptyObj); 2329 } 2330 2331 if (code == TCL_OK && listObjc > 0) { 2332 Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv)); 2333 } 2334 2335 Tcl_DecrRefCount(listCopyPtr); 2336 return code; 2337 } 2338 2339 /* 2340 *---------------------------------------------------------------------- 2341 * 2342 * Tcl_LindexObjCmd -- 2343 * 2344 * This object-based procedure is invoked to process the "lindex" Tcl 2345 * command. See the user documentation for details on what it does. 2346 * 2347 * Results: 2348 * A standard Tcl object result. 2349 * 2350 * Side effects: 2351 * See the user documentation. 2352 * 2353 *---------------------------------------------------------------------- 2354 */ 2355 2356 int 2357 Tcl_LindexObjCmd( 2358 ClientData dummy, /* Not used. */ 2359 Tcl_Interp *interp, /* Current interpreter. */ 2360 int objc, /* Number of arguments. */ 2361 Tcl_Obj *const objv[]) /* Argument objects. */ 2362 { 2363 2364 Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */ 2365 2366 if (objc < 2) { 2367 Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); 2368 return TCL_ERROR; 2369 } 2370 2371 /* 2372 * If objc==3, then objv[2] may be either a single index or a list of 2373 * indices: go to TclLindexList to determine which. If objc>=4, or 2374 * objc==2, then objv[2 .. objc-2] are all single indices and processed as 2375 * such in TclLindexFlat. 2376 */ 2377 2378 if (objc == 3) { 2379 elemPtr = TclLindexList(interp, objv[1], objv[2]); 2380 } else { 2381 elemPtr = TclLindexFlat(interp, objv[1], objc-2, objv+2); 2382 } 2383 2384 /* 2385 * Set the interpreter's object result to the last element extracted. 2386 */ 2387 2388 if (elemPtr == NULL) { 2389 return TCL_ERROR; 2390 } 2391 2392 Tcl_SetObjResult(interp, elemPtr); 2393 Tcl_DecrRefCount(elemPtr); 2394 return TCL_OK; 2395 } 2396 2397 /* 2398 *---------------------------------------------------------------------- 2399 * 2400 * Tcl_LinsertObjCmd -- 2401 * 2402 * This object-based procedure is invoked to process the "linsert" Tcl 2403 * command. See the user documentation for details on what it does. 2404 * 2405 * Results: 2406 * A new Tcl list object formed by inserting zero or more elements into a 2407 * list. 2408 * 2409 * Side effects: 2410 * See the user documentation. 2411 * 2412 *---------------------------------------------------------------------- 2413 */ 2414 2415 int 2416 Tcl_LinsertObjCmd( 2417 ClientData dummy, /* Not used. */ 2418 Tcl_Interp *interp, /* Current interpreter. */ 2419 register int objc, /* Number of arguments. */ 2420 Tcl_Obj *const objv[]) /* Argument objects. */ 2421 { 2422 Tcl_Obj *listPtr; 2423 size_t index; 2424 int len, result; 2425 2426 if (objc < 3) { 2427 Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); 2428 return TCL_ERROR; 2429 } 2430 2431 result = TclListObjLength(interp, objv[1], &len); 2432 if (result != TCL_OK) { 2433 return result; 2434 } 2435 2436 /* 2437 * Get the index. "end" is interpreted to be the index after the last 2438 * element, such that using it will cause any inserted elements to be 2439 * appended to the list. 2440 */ 2441 2442 result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index); 2443 if (result != TCL_OK) { 2444 return result; 2445 } 2446 if (index + 1 > (size_t)len + 1) { 2447 index = len; 2448 } 2449 2450 /* 2451 * If the list object is unshared we can modify it directly. Otherwise we 2452 * create a copy to modify: this is "copy on write". 2453 */ 2454 2455 listPtr = objv[1]; 2456 if (Tcl_IsShared(listPtr)) { 2457 listPtr = TclListObjCopy(NULL, listPtr); 2458 } 2459 2460 if ((objc == 4) && (index == (size_t)len)) { 2461 /* 2462 * Special case: insert one element at the end of the list. 2463 */ 2464 2465 Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); 2466 } else { 2467 if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0, 2468 (objc-3), &(objv[3]))) { 2469 return TCL_ERROR; 2470 } 2471 } 2472 2473 /* 2474 * Set the interpreter's object result. 2475 */ 2476 2477 Tcl_SetObjResult(interp, listPtr); 2478 return TCL_OK; 2479 } 2480 2481 /* 2482 *---------------------------------------------------------------------- 2483 * 2484 * Tcl_ListObjCmd -- 2485 * 2486 * This procedure is invoked to process the "list" Tcl command. See the 2487 * user documentation for details on what it does. 2488 * 2489 * Results: 2490 * A standard Tcl object result. 2491 * 2492 * Side effects: 2493 * See the user documentation. 2494 * 2495 *---------------------------------------------------------------------- 2496 */ 2497 2498 int 2499 Tcl_ListObjCmd( 2500 ClientData dummy, /* Not used. */ 2501 Tcl_Interp *interp, /* Current interpreter. */ 2502 register int objc, /* Number of arguments. */ 2503 register Tcl_Obj *const objv[]) 2504 /* The argument objects. */ 2505 { 2506 /* 2507 * If there are no list elements, the result is an empty object. 2508 * Otherwise set the interpreter's result object to be a list object. 2509 */ 2510 2511 if (objc > 1) { 2512 Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1])); 2513 } 2514 return TCL_OK; 2515 } 2516 2517 /* 2518 *---------------------------------------------------------------------- 2519 * 2520 * Tcl_LlengthObjCmd -- 2521 * 2522 * This object-based procedure is invoked to process the "llength" Tcl 2523 * command. See the user documentation for details on what it does. 2524 * 2525 * Results: 2526 * A standard Tcl object result. 2527 * 2528 * Side effects: 2529 * See the user documentation. 2530 * 2531 *---------------------------------------------------------------------- 2532 */ 2533 2534 int 2535 Tcl_LlengthObjCmd( 2536 ClientData dummy, /* Not used. */ 2537 Tcl_Interp *interp, /* Current interpreter. */ 2538 int objc, /* Number of arguments. */ 2539 register Tcl_Obj *const objv[]) 2540 /* Argument objects. */ 2541 { 2542 int listLen, result; 2543 2544 if (objc != 2) { 2545 Tcl_WrongNumArgs(interp, 1, objv, "list"); 2546 return TCL_ERROR; 2547 } 2548 2549 result = TclListObjLength(interp, objv[1], &listLen); 2550 if (result != TCL_OK) { 2551 return result; 2552 } 2553 2554 /* 2555 * Set the interpreter's object result to an integer object holding the 2556 * length. 2557 */ 2558 2559 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen)); 2560 return TCL_OK; 2561 } 2562 2563 /* 2564 *---------------------------------------------------------------------- 2565 * 2566 * Tcl_LpopObjCmd -- 2567 * 2568 * This procedure is invoked to process the "lpop" Tcl command. See the 2569 * user documentation for details on what it does. 2570 * 2571 * Results: 2572 * A standard Tcl object result. 2573 * 2574 * Side effects: 2575 * See the user documentation. 2576 * 2577 *---------------------------------------------------------------------- 2578 */ 2579 2580 int 2581 Tcl_LpopObjCmd( 2582 ClientData notUsed, /* Not used. */ 2583 Tcl_Interp *interp, /* Current interpreter. */ 2584 int objc, /* Number of arguments. */ 2585 register Tcl_Obj *const objv[]) 2586 /* Argument objects. */ 2587 { 2588 int listLen, result; 2589 Tcl_Obj *elemPtr; 2590 Tcl_Obj *listPtr, **elemPtrs; 2591 2592 if (objc < 2) { 2593 Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); 2594 return TCL_ERROR; 2595 } 2596 2597 listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); 2598 if (listPtr == NULL) { 2599 return TCL_ERROR; 2600 } 2601 2602 result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); 2603 if (result != TCL_OK) { 2604 return result; 2605 } 2606 2607 /* 2608 * First, extract the element to be returned. 2609 * TclLindexFlat adds a ref count which is handled. 2610 */ 2611 2612 if (objc == 2) { 2613 elemPtr = elemPtrs[listLen - 1]; 2614 Tcl_IncrRefCount(elemPtr); 2615 } else { 2616 elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); 2617 2618 if (elemPtr == NULL) { 2619 return TCL_ERROR; 2620 } 2621 } 2622 Tcl_SetObjResult(interp, elemPtr); 2623 Tcl_DecrRefCount(elemPtr); 2624 2625 /* 2626 * Second, remove the element. 2627 */ 2628 2629 if (objc == 2) { 2630 if (Tcl_IsShared(listPtr)) { 2631 listPtr = TclListObjCopy(NULL, listPtr); 2632 } 2633 result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); 2634 if (result != TCL_OK) { 2635 return result; 2636 } 2637 } else { 2638 listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); 2639 2640 if (listPtr == NULL) { 2641 return TCL_ERROR; 2642 } 2643 } 2644 2645 listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); 2646 if (listPtr == NULL) { 2647 return TCL_ERROR; 2648 } 2649 2650 return TCL_OK; 2651 } 2652 2653 /* 2654 *---------------------------------------------------------------------- 2655 * 2656 * Tcl_LrangeObjCmd -- 2657 * 2658 * This procedure is invoked to process the "lrange" Tcl command. See the 2659 * user documentation for details on what it does. 2660 * 2661 * Results: 2662 * A standard Tcl object result. 2663 * 2664 * Side effects: 2665 * See the user documentation. 2666 * 2667 *---------------------------------------------------------------------- 2668 */ 2669 2670 int 2671 Tcl_LrangeObjCmd( 2672 ClientData notUsed, /* Not used. */ 2673 Tcl_Interp *interp, /* Current interpreter. */ 2674 int objc, /* Number of arguments. */ 2675 register Tcl_Obj *const objv[]) 2676 /* Argument objects. */ 2677 { 2678 int listLen, result; 2679 size_t first, last; 2680 2681 if (objc != 4) { 2682 Tcl_WrongNumArgs(interp, 1, objv, "list first last"); 2683 return TCL_ERROR; 2684 } 2685 2686 result = TclListObjLength(interp, objv[1], &listLen); 2687 if (result != TCL_OK) { 2688 return result; 2689 } 2690 2691 result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1, 2692 &first); 2693 if (result != TCL_OK) { 2694 return result; 2695 } 2696 2697 result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, 2698 &last); 2699 if (result != TCL_OK) { 2700 return result; 2701 } 2702 2703 Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); 2704 return TCL_OK; 2705 } 2706 2707 /* 2708 *---------------------------------------------------------------------- 2709 * 2710 * Tcl_LrepeatObjCmd -- 2711 * 2712 * This procedure is invoked to process the "lrepeat" Tcl command. See 2713 * the user documentation for details on what it does. 2714 * 2715 * Results: 2716 * A standard Tcl object result. 2717 * 2718 * Side effects: 2719 * See the user documentation. 2720 * 2721 *---------------------------------------------------------------------- 2722 */ 2723 2724 int 2725 Tcl_LrepeatObjCmd( 2726 ClientData dummy, /* Not used. */ 2727 Tcl_Interp *interp, /* Current interpreter. */ 2728 register int objc, /* Number of arguments. */ 2729 register Tcl_Obj *const objv[]) 2730 /* The argument objects. */ 2731 { 2732 int elementCount, i, totalElems; 2733 Tcl_Obj *listPtr, **dataArray = NULL; 2734 2735 /* 2736 * Check arguments for legality: 2737 * lrepeat count ?value ...? 2738 */ 2739 2740 if (objc < 2) { 2741 Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); 2742 return TCL_ERROR; 2743 } 2744 if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) { 2745 return TCL_ERROR; 2746 } 2747 if (elementCount < 0) { 2748 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 2749 "bad count \"%d\": must be integer >= 0", elementCount)); 2750 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", 2751 NULL); 2752 return TCL_ERROR; 2753 } 2754 2755 /* 2756 * Skip forward to the interesting arguments now we've finished parsing. 2757 */ 2758 2759 objc -= 2; 2760 objv += 2; 2761 2762 /* Final sanity check. Do not exceed limits on max list length. */ 2763 2764 if (elementCount && objc > LIST_MAX/elementCount) { 2765 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 2766 "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); 2767 Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); 2768 return TCL_ERROR; 2769 } 2770 totalElems = objc * elementCount; 2771 2772 /* 2773 * Get an empty list object that is allocated large enough to hold each 2774 * init value elementCount times. 2775 */ 2776 2777 listPtr = Tcl_NewListObj(totalElems, NULL); 2778 if (totalElems) { 2779 List *listRepPtr = ListRepPtr(listPtr); 2780 2781 listRepPtr->elemCount = elementCount*objc; 2782 dataArray = &listRepPtr->elements; 2783 } 2784 2785 /* 2786 * Set the elements. Note that we handle the common degenerate case of a 2787 * single value being repeated separately to permit the compiler as much 2788 * room as possible to optimize a loop that might be run a very large 2789 * number of times. 2790 */ 2791 2792 CLANG_ASSERT(dataArray || totalElems == 0 ); 2793 if (objc == 1) { 2794 register Tcl_Obj *tmpPtr = objv[0]; 2795 2796 tmpPtr->refCount += elementCount; 2797 for (i=0 ; i<elementCount ; i++) { 2798 dataArray[i] = tmpPtr; 2799 } 2800 } else { 2801 int j, k = 0; 2802 2803 for (i=0 ; i<elementCount ; i++) { 2804 for (j=0 ; j<objc ; j++) { 2805 Tcl_IncrRefCount(objv[j]); 2806 dataArray[k++] = objv[j]; 2807 } 2808 } 2809 } 2810 2811 Tcl_SetObjResult(interp, listPtr); 2812 return TCL_OK; 2813 } 2814 2815 /* 2816 *---------------------------------------------------------------------- 2817 * 2818 * Tcl_LreplaceObjCmd -- 2819 * 2820 * This object-based procedure is invoked to process the "lreplace" Tcl 2821 * command. See the user documentation for details on what it does. 2822 * 2823 * Results: 2824 * A new Tcl list object formed by replacing zero or more elements of a 2825 * list. 2826 * 2827 * Side effects: 2828 * See the user documentation. 2829 * 2830 *---------------------------------------------------------------------- 2831 */ 2832 2833 int 2834 Tcl_LreplaceObjCmd( 2835 ClientData dummy, /* Not used. */ 2836 Tcl_Interp *interp, /* Current interpreter. */ 2837 int objc, /* Number of arguments. */ 2838 Tcl_Obj *const objv[]) /* Argument objects. */ 2839 { 2840 register Tcl_Obj *listPtr; 2841 size_t first, last; 2842 int listLen, numToDelete, result; 2843 2844 if (objc < 4) { 2845 Tcl_WrongNumArgs(interp, 1, objv, 2846 "list first last ?element ...?"); 2847 return TCL_ERROR; 2848 } 2849 2850 result = TclListObjLength(interp, objv[1], &listLen); 2851 if (result != TCL_OK) { 2852 return result; 2853 } 2854 2855 /* 2856 * Get the first and last indexes. "end" is interpreted to be the index 2857 * for the last element, such that using it will cause that element to be 2858 * included for deletion. 2859 */ 2860 2861 result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first); 2862 if (result != TCL_OK) { 2863 return result; 2864 } 2865 2866 result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last); 2867 if (result != TCL_OK) { 2868 return result; 2869 } 2870 2871 if (first == TCL_INDEX_NONE) { 2872 first = 0; 2873 } else if (first > (size_t)listLen) { 2874 first = listLen; 2875 } 2876 2877 if (last + 1 > (size_t)listLen) { 2878 last = listLen - 1; 2879 } 2880 if (first + 1 <= last + 1) { 2881 numToDelete = last - first + 1; 2882 } else { 2883 numToDelete = 0; 2884 } 2885 2886 /* 2887 * If the list object is unshared we can modify it directly, otherwise we 2888 * create a copy to modify: this is "copy on write". 2889 */ 2890 2891 listPtr = objv[1]; 2892 if (Tcl_IsShared(listPtr)) { 2893 listPtr = TclListObjCopy(NULL, listPtr); 2894 } 2895 2896 /* 2897 * Note that we call Tcl_ListObjReplace even when numToDelete == 0 and 2898 * objc == 4. In this case, the list value of listPtr is not changed (no 2899 * elements are removed or added), but by making the call we are assured 2900 * we end up with a list in canonical form. Resist any temptation to 2901 * optimize this case away. 2902 */ 2903 2904 if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, 2905 objc-4, objv+4)) { 2906 return TCL_ERROR; 2907 } 2908 2909 /* 2910 * Set the interpreter's object result. 2911 */ 2912 2913 Tcl_SetObjResult(interp, listPtr); 2914 return TCL_OK; 2915 } 2916 2917 /* 2918 *---------------------------------------------------------------------- 2919 * 2920 * Tcl_LreverseObjCmd -- 2921 * 2922 * This procedure is invoked to process the "lreverse" Tcl command. See 2923 * the user documentation for details on what it does. 2924 * 2925 * Results: 2926 * A standard Tcl result. 2927 * 2928 * Side effects: 2929 * See the user documentation. 2930 * 2931 *---------------------------------------------------------------------- 2932 */ 2933 2934 int 2935 Tcl_LreverseObjCmd( 2936 ClientData clientData, /* Not used. */ 2937 Tcl_Interp *interp, /* Current interpreter. */ 2938 int objc, /* Number of arguments. */ 2939 Tcl_Obj *const objv[]) /* Argument values. */ 2940 { 2941 Tcl_Obj **elemv; 2942 int elemc, i, j; 2943 2944 if (objc != 2) { 2945 Tcl_WrongNumArgs(interp, 1, objv, "list"); 2946 return TCL_ERROR; 2947 } 2948 if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { 2949 return TCL_ERROR; 2950 } 2951 2952 /* 2953 * If the list is empty, just return it. [Bug 1876793] 2954 */ 2955 2956 if (!elemc) { 2957 Tcl_SetObjResult(interp, objv[1]); 2958 return TCL_OK; 2959 } 2960 2961 if (Tcl_IsShared(objv[1]) 2962 || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ 2963 Tcl_Obj *resultObj, **dataArray; 2964 List *listRepPtr; 2965 2966 resultObj = Tcl_NewListObj(elemc, NULL); 2967 listRepPtr = ListRepPtr(resultObj); 2968 listRepPtr->elemCount = elemc; 2969 dataArray = &listRepPtr->elements; 2970 2971 for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { 2972 dataArray[j] = elemv[i]; 2973 Tcl_IncrRefCount(elemv[i]); 2974 } 2975 2976 Tcl_SetObjResult(interp, resultObj); 2977 } else { 2978 2979 /* 2980 * Not shared, so swap "in place". This relies on Tcl_LOGE above 2981 * returning a pointer to the live array of Tcl_Obj values. 2982 */ 2983 2984 for (i=0,j=elemc-1 ; i<j ; i++,j--) { 2985 Tcl_Obj *tmp = elemv[i]; 2986 2987 elemv[i] = elemv[j]; 2988 elemv[j] = tmp; 2989 } 2990 TclInvalidateStringRep(objv[1]); 2991 Tcl_SetObjResult(interp, objv[1]); 2992 } 2993 return TCL_OK; 2994 } 2995 2996 /* 2997 *---------------------------------------------------------------------- 2998 * 2999 * Tcl_LsearchObjCmd -- 3000 * 3001 * This procedure is invoked to process the "lsearch" Tcl command. See 3002 * the user documentation for details on what it does. 3003 * 3004 * Results: 3005 * A standard Tcl result. 3006 * 3007 * Side effects: 3008 * See the user documentation. 3009 * 3010 *---------------------------------------------------------------------- 3011 */ 3012 3013 int 3014 Tcl_LsearchObjCmd( 3015 ClientData clientData, /* Not used. */ 3016 Tcl_Interp *interp, /* Current interpreter. */ 3017 int objc, /* Number of arguments. */ 3018 Tcl_Obj *const objv[]) /* Argument values. */ 3019 { 3020 const char *bytes, *patternBytes; 3021 int i, match, index, result=TCL_OK, listc, bisect; 3022 size_t length = 0, elemLen, start, groupSize, groupOffset, lower, upper; 3023 int allocatedIndexVector = 0; 3024 int dataType, isIncreasing; 3025 Tcl_WideInt patWide, objWide, wide; 3026 int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; 3027 double patDouble, objDouble; 3028 SortInfo sortInfo; 3029 Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; 3030 SortStrCmpFn_t strCmpFn = TclUtfCmp; 3031 Tcl_RegExp regexp = NULL; 3032 static const char *const options[] = { 3033 "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", 3034 "-exact", "-glob", "-increasing", "-index", 3035 "-inline", "-integer", "-nocase", "-not", 3036 "-real", "-regexp", "-sorted", "-start", "-stride", 3037 "-subindices", NULL 3038 }; 3039 enum options { 3040 LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, 3041 LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, 3042 LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, 3043 LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, 3044 LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES 3045 }; 3046 enum datatypes { 3047 ASCII, DICTIONARY, INTEGER, REAL 3048 }; 3049 enum modes { 3050 EXACT, GLOB, REGEXP, SORTED 3051 }; 3052 enum modes mode; 3053 3054 mode = GLOB; 3055 dataType = ASCII; 3056 isIncreasing = 1; 3057 allMatches = 0; 3058 inlineReturn = 0; 3059 returnSubindices = 0; 3060 negatedMatch = 0; 3061 bisect = 0; 3062 listPtr = NULL; 3063 startPtr = NULL; 3064 groupSize = 1; 3065 groupOffset = 0; 3066 start = 0; 3067 noCase = 0; 3068 sortInfo.compareCmdPtr = NULL; 3069 sortInfo.isIncreasing = 1; 3070 sortInfo.sortMode = 0; 3071 sortInfo.interp = interp; 3072 sortInfo.resultCode = TCL_OK; 3073 sortInfo.indexv = NULL; 3074 sortInfo.indexc = 0; 3075 3076 if (objc < 3) { 3077 Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern"); 3078 return TCL_ERROR; 3079 } 3080 3081 for (i = 1; i < objc-2; i++) { 3082 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) 3083 != TCL_OK) { 3084 result = TCL_ERROR; 3085 goto done; 3086 } 3087 switch ((enum options) index) { 3088 case LSEARCH_ALL: /* -all */ 3089 allMatches = 1; 3090 break; 3091 case LSEARCH_ASCII: /* -ascii */ 3092 dataType = ASCII; 3093 break; 3094 case LSEARCH_BISECT: /* -bisect */ 3095 mode = SORTED; 3096 bisect = 1; 3097 break; 3098 case LSEARCH_DECREASING: /* -decreasing */ 3099 isIncreasing = 0; 3100 sortInfo.isIncreasing = 0; 3101 break; 3102 case LSEARCH_DICTIONARY: /* -dictionary */ 3103 dataType = DICTIONARY; 3104 break; 3105 case LSEARCH_EXACT: /* -increasing */ 3106 mode = EXACT; 3107 break; 3108 case LSEARCH_GLOB: /* -glob */ 3109 mode = GLOB; 3110 break; 3111 case LSEARCH_INCREASING: /* -increasing */ 3112 isIncreasing = 1; 3113 sortInfo.isIncreasing = 1; 3114 break; 3115 case LSEARCH_INLINE: /* -inline */ 3116 inlineReturn = 1; 3117 break; 3118 case LSEARCH_INTEGER: /* -integer */ 3119 dataType = INTEGER; 3120 break; 3121 case LSEARCH_NOCASE: /* -nocase */ 3122 strCmpFn = TclUtfCasecmp; 3123 noCase = 1; 3124 break; 3125 case LSEARCH_NOT: /* -not */ 3126 negatedMatch = 1; 3127 break; 3128 case LSEARCH_REAL: /* -real */ 3129 dataType = REAL; 3130 break; 3131 case LSEARCH_REGEXP: /* -regexp */ 3132 mode = REGEXP; 3133 break; 3134 case LSEARCH_SORTED: /* -sorted */ 3135 mode = SORTED; 3136 break; 3137 case LSEARCH_SUBINDICES: /* -subindices */ 3138 returnSubindices = 1; 3139 break; 3140 case LSEARCH_START: /* -start */ 3141 /* 3142 * If there was a previous -start option, release its saved index 3143 * because it will either be replaced or there will be an error. 3144 */ 3145 3146 if (startPtr != NULL) { 3147 Tcl_DecrRefCount(startPtr); 3148 startPtr = NULL; 3149 } 3150 if (i > objc-4) { 3151 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3152 "missing starting index", -1)); 3153 Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); 3154 result = TCL_ERROR; 3155 goto done; 3156 } 3157 i++; 3158 if (objv[i] == objv[objc - 2]) { 3159 /* 3160 * Take copy to prevent shimmering problems. Note that it does 3161 * not matter if the index obj is also a component of the list 3162 * being searched. We only need to copy where the list and the 3163 * index are one-and-the-same. 3164 */ 3165 3166 startPtr = Tcl_DuplicateObj(objv[i]); 3167 } else { 3168 startPtr = objv[i]; 3169 } 3170 Tcl_IncrRefCount(startPtr); 3171 break; 3172 case LSEARCH_STRIDE: /* -stride */ 3173 if (i > objc-4) { 3174 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3175 "\"-stride\" option must be " 3176 "followed by stride length", -1)); 3177 Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); 3178 result = TCL_ERROR; 3179 goto done; 3180 } 3181 if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { 3182 result = TCL_ERROR; 3183 goto done; 3184 } 3185 if (wide < 1) { 3186 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3187 "stride length must be at least 1", -1)); 3188 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", 3189 "BADSTRIDE", NULL); 3190 result = TCL_ERROR; 3191 goto done; 3192 } 3193 groupSize = wide; 3194 i++; 3195 break; 3196 case LSEARCH_INDEX: { /* -index */ 3197 Tcl_Obj **indices; 3198 int j; 3199 3200 if (allocatedIndexVector) { 3201 TclStackFree(interp, sortInfo.indexv); 3202 allocatedIndexVector = 0; 3203 } 3204 if (i > objc-4) { 3205 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3206 "\"-index\" option must be followed by list index", 3207 -1)); 3208 Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); 3209 result = TCL_ERROR; 3210 goto done; 3211 } 3212 3213 /* 3214 * Store the extracted indices for processing by sublist 3215 * extraction. Note that we don't do this using objects because 3216 * that has shimmering problems. 3217 */ 3218 3219 i++; 3220 if (TclListObjGetElements(interp, objv[i], 3221 &sortInfo.indexc, &indices) != TCL_OK) { 3222 result = TCL_ERROR; 3223 goto done; 3224 } 3225 switch (sortInfo.indexc) { 3226 case 0: 3227 sortInfo.indexv = NULL; 3228 break; 3229 case 1: 3230 sortInfo.indexv = &sortInfo.singleIndex; 3231 break; 3232 default: 3233 sortInfo.indexv = 3234 TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); 3235 allocatedIndexVector = 1; /* Cannot use indexc field, as it 3236 * might be decreased by 1 later. */ 3237 } 3238 3239 /* 3240 * Fill the array by parsing each index. We don't know whether 3241 * their scale is sensible yet, but we at least perform the 3242 * syntactic check here. 3243 */ 3244 3245 for (j=0 ; j<sortInfo.indexc ; j++) { 3246 int encoded = 0; 3247 if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE, 3248 TCL_INDEX_NONE, &encoded) != TCL_OK) { 3249 result = TCL_ERROR; 3250 } 3251 if (encoded == (int)TCL_INDEX_NONE) { 3252 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 3253 "index \"%s\" cannot select an element " 3254 "from any list", TclGetString(indices[j]))); 3255 Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" 3256 "OUTOFRANGE", NULL); 3257 result = TCL_ERROR; 3258 } 3259 if (result == TCL_ERROR) { 3260 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 3261 "\n (-index option item number %d)", j)); 3262 goto done; 3263 } 3264 sortInfo.indexv[j] = encoded; 3265 } 3266 break; 3267 } 3268 } 3269 } 3270 3271 /* 3272 * Subindices only make sense if asked for with -index option set. 3273 */ 3274 3275 if (returnSubindices && sortInfo.indexc==0) { 3276 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3277 "-subindices cannot be used without -index option", -1)); 3278 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", 3279 "BAD_OPTION_MIX", NULL); 3280 result = TCL_ERROR; 3281 goto done; 3282 } 3283 3284 if (bisect && (allMatches || negatedMatch)) { 3285 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3286 "-bisect is not compatible with -all or -not", -1)); 3287 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", 3288 "BAD_OPTION_MIX", NULL); 3289 result = TCL_ERROR; 3290 goto done; 3291 } 3292 3293 if (mode == REGEXP) { 3294 /* 3295 * We can shimmer regexp/list if listv[i] == pattern, so get the 3296 * regexp rep before the list rep. First time round, omit the interp 3297 * and hope that the compilation will succeed. If it fails, we'll 3298 * recompile in "expensive" mode with a place to put error messages. 3299 */ 3300 3301 regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1], 3302 TCL_REG_ADVANCED | TCL_REG_NOSUB | 3303 (noCase ? TCL_REG_NOCASE : 0)); 3304 if (regexp == NULL) { 3305 /* 3306 * Failed to compile the RE. Try again without the TCL_REG_NOSUB 3307 * flag in case the RE had sub-expressions in it [Bug 1366683]. If 3308 * this fails, an error message will be left in the interpreter. 3309 */ 3310 3311 regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], 3312 TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); 3313 } 3314 3315 if (regexp == NULL) { 3316 result = TCL_ERROR; 3317 goto done; 3318 } 3319 } 3320 3321 /* 3322 * Make sure the list argument is a list object and get its length and a 3323 * pointer to its array of element pointers. 3324 */ 3325 3326 result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); 3327 if (result != TCL_OK) { 3328 goto done; 3329 } 3330 3331 /* 3332 * Check for sanity when grouping elements of the overall list together 3333 * because of the -stride option. [TIP #351] 3334 */ 3335 3336 if (groupSize > 1) { 3337 if (listc % groupSize) { 3338 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3339 "list size must be a multiple of the stride length", 3340 -1)); 3341 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", 3342 NULL); 3343 result = TCL_ERROR; 3344 goto done; 3345 } 3346 if (sortInfo.indexc > 0) { 3347 /* 3348 * Use the first value in the list supplied to -index as the 3349 * offset of the element within each group by which to sort. 3350 */ 3351 3352 groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); 3353 if (groupOffset >= groupSize) { 3354 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3355 "when used with \"-stride\", the leading \"-index\"" 3356 " value must be within the group", -1)); 3357 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", 3358 "BADINDEX", NULL); 3359 result = TCL_ERROR; 3360 goto done; 3361 } 3362 if (sortInfo.indexc == 1) { 3363 sortInfo.indexc = 0; 3364 sortInfo.indexv = NULL; 3365 } else { 3366 sortInfo.indexc--; 3367 3368 for (i = 0; i < sortInfo.indexc; i++) { 3369 sortInfo.indexv[i] = sortInfo.indexv[i+1]; 3370 } 3371 } 3372 } 3373 } 3374 3375 /* 3376 * Get the user-specified start offset. 3377 */ 3378 3379 if (startPtr) { 3380 result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); 3381 if (result != TCL_OK) { 3382 goto done; 3383 } 3384 if (start == TCL_INDEX_NONE) { 3385 start = TCL_INDEX_START; 3386 } 3387 3388 /* 3389 * If the search started past the end of the list, we just return a 3390 * "did not match anything at all" result straight away. [Bug 1374778] 3391 */ 3392 3393 if (start >= (size_t)listc) { 3394 if (allMatches || inlineReturn) { 3395 Tcl_ResetResult(interp); 3396 } else { 3397 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); 3398 } 3399 goto done; 3400 } 3401 3402 /* 3403 * If start points within a group, it points to the start of the group. 3404 */ 3405 3406 if (groupSize > 1) { 3407 start -= (start % groupSize); 3408 } 3409 } 3410 3411 patObj = objv[objc - 1]; 3412 patternBytes = NULL; 3413 if (mode == EXACT || mode == SORTED) { 3414 switch ((enum datatypes) dataType) { 3415 case ASCII: 3416 case DICTIONARY: 3417 patternBytes = TclGetStringFromObj(patObj, &length); 3418 break; 3419 case INTEGER: 3420 result = TclGetWideIntFromObj(interp, patObj, &patWide); 3421 if (result != TCL_OK) { 3422 goto done; 3423 } 3424 3425 /* 3426 * List representation might have been shimmered; restore it. [Bug 3427 * 1844789] 3428 */ 3429 3430 TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); 3431 break; 3432 case REAL: 3433 result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); 3434 if (result != TCL_OK) { 3435 goto done; 3436 } 3437 3438 /* 3439 * List representation might have been shimmered; restore it. [Bug 3440 * 1844789] 3441 */ 3442 3443 TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv); 3444 break; 3445 } 3446 } else { 3447 patternBytes = TclGetStringFromObj(patObj, &length); 3448 } 3449 3450 /* 3451 * Set default index value to -1, indicating failure; if we find the item 3452 * in the course of our search, index will be set to the correct value. 3453 */ 3454 3455 index = -1; 3456 match = 0; 3457 3458 if (mode == SORTED && !allMatches && !negatedMatch) { 3459 /* 3460 * If the data is sorted, we can do a more intelligent search. Note 3461 * that there is no point in being smart when -all was specified; in 3462 * that case, we have to look at all items anyway, and there is no 3463 * sense in doing this when the match sense is inverted. 3464 */ 3465 3466 /* 3467 * With -stride, lower, upper and i are kept as multiples of groupSize. 3468 */ 3469 3470 lower = start - groupSize; 3471 upper = listc; 3472 while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { 3473 i = (lower + upper)/2; 3474 i -= i % groupSize; 3475 if (sortInfo.indexc != 0) { 3476 itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); 3477 if (sortInfo.resultCode != TCL_OK) { 3478 result = sortInfo.resultCode; 3479 goto done; 3480 } 3481 } else { 3482 itemPtr = listv[i+groupOffset]; 3483 } 3484 switch ((enum datatypes) dataType) { 3485 case ASCII: 3486 bytes = TclGetString(itemPtr); 3487 match = strCmpFn(patternBytes, bytes); 3488 break; 3489 case DICTIONARY: 3490 bytes = TclGetString(itemPtr); 3491 match = DictionaryCompare(patternBytes, bytes); 3492 break; 3493 case INTEGER: 3494 result = TclGetWideIntFromObj(interp, itemPtr, &objWide); 3495 if (result != TCL_OK) { 3496 goto done; 3497 } 3498 if (patWide == objWide) { 3499 match = 0; 3500 } else if (patWide < objWide) { 3501 match = -1; 3502 } else { 3503 match = 1; 3504 } 3505 break; 3506 case REAL: 3507 result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble); 3508 if (result != TCL_OK) { 3509 goto done; 3510 } 3511 if (patDouble == objDouble) { 3512 match = 0; 3513 } else if (patDouble < objDouble) { 3514 match = -1; 3515 } else { 3516 match = 1; 3517 } 3518 break; 3519 } 3520 if (match == 0) { 3521 /* 3522 * Normally, binary search is written to stop when it finds a 3523 * match. If there are duplicates of an element in the list, 3524 * our first match might not be the first occurance. 3525 * Consider: 0 0 0 1 1 1 2 2 2 3526 * 3527 * To maintain consistancy with standard lsearch semantics, we 3528 * must find the leftmost occurance of the pattern in the 3529 * list. Thus we don't just stop searching here. This 3530 * variation means that a search always makes log n 3531 * comparisons (normal binary search might "get lucky" with an 3532 * early comparison). 3533 * 3534 * In bisect mode though, we want the last of equals. 3535 */ 3536 3537 index = i; 3538 if (bisect) { 3539 lower = i; 3540 } else { 3541 upper = i; 3542 } 3543 } else if (match > 0) { 3544 if (isIncreasing) { 3545 lower = i; 3546 } else { 3547 upper = i; 3548 } 3549 } else { 3550 if (isIncreasing) { 3551 upper = i; 3552 } else { 3553 lower = i; 3554 } 3555 } 3556 } 3557 if (bisect && index < 0) { 3558 index = lower; 3559 } 3560 } else { 3561 /* 3562 * We need to do a linear search, because (at least one) of: 3563 * - our matcher can only tell equal vs. not equal 3564 * - our matching sense is negated 3565 * - we're building a list of all matched items 3566 */ 3567 3568 if (allMatches) { 3569 listPtr = Tcl_NewListObj(0, NULL); 3570 } 3571 for (i = start; i < listc; i += groupSize) { 3572 match = 0; 3573 if (sortInfo.indexc != 0) { 3574 itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); 3575 if (sortInfo.resultCode != TCL_OK) { 3576 if (listPtr != NULL) { 3577 Tcl_DecrRefCount(listPtr); 3578 } 3579 result = sortInfo.resultCode; 3580 goto done; 3581 } 3582 } else { 3583 itemPtr = listv[i+groupOffset]; 3584 } 3585 3586 switch (mode) { 3587 case SORTED: 3588 case EXACT: 3589 switch ((enum datatypes) dataType) { 3590 case ASCII: 3591 bytes = TclGetStringFromObj(itemPtr, &elemLen); 3592 if (length == elemLen) { 3593 /* 3594 * This split allows for more optimal compilation of 3595 * memcmp/strcasecmp. 3596 */ 3597 3598 if (noCase) { 3599 match = (TclUtfCasecmp(bytes, patternBytes) == 0); 3600 } else { 3601 match = (memcmp(bytes, patternBytes, length) == 0); 3602 } 3603 } 3604 break; 3605 3606 case DICTIONARY: 3607 bytes = TclGetString(itemPtr); 3608 match = (DictionaryCompare(bytes, patternBytes) == 0); 3609 break; 3610 3611 case INTEGER: 3612 result = TclGetWideIntFromObj(interp, itemPtr, &objWide); 3613 if (result != TCL_OK) { 3614 if (listPtr != NULL) { 3615 Tcl_DecrRefCount(listPtr); 3616 } 3617 goto done; 3618 } 3619 match = (objWide == patWide); 3620 break; 3621 3622 case REAL: 3623 result = Tcl_GetDoubleFromObj(interp,itemPtr, &objDouble); 3624 if (result != TCL_OK) { 3625 if (listPtr) { 3626 Tcl_DecrRefCount(listPtr); 3627 } 3628 goto done; 3629 } 3630 match = (objDouble == patDouble); 3631 break; 3632 } 3633 break; 3634 3635 case GLOB: 3636 match = Tcl_StringCaseMatch(TclGetString(itemPtr), 3637 patternBytes, noCase); 3638 break; 3639 3640 case REGEXP: 3641 match = Tcl_RegExpExecObj(interp, regexp, itemPtr, 0, 0, 0); 3642 if (match < 0) { 3643 Tcl_DecrRefCount(patObj); 3644 if (listPtr != NULL) { 3645 Tcl_DecrRefCount(listPtr); 3646 } 3647 result = TCL_ERROR; 3648 goto done; 3649 } 3650 break; 3651 } 3652 3653 /* 3654 * Invert match condition for -not. 3655 */ 3656 3657 if (negatedMatch) { 3658 match = !match; 3659 } 3660 if (!match) { 3661 continue; 3662 } 3663 if (!allMatches) { 3664 index = i; 3665 break; 3666 } else if (inlineReturn) { 3667 /* 3668 * Note that these appends are not expected to fail. 3669 */ 3670 3671 if (returnSubindices && (sortInfo.indexc != 0)) { 3672 itemPtr = SelectObjFromSublist(listv[i+groupOffset], 3673 &sortInfo); 3674 Tcl_ListObjAppendElement(interp, listPtr, itemPtr); 3675 } else if (groupSize > 1) { 3676 Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, 3677 groupSize, &listv[i]); 3678 } else { 3679 itemPtr = listv[i]; 3680 Tcl_ListObjAppendElement(interp, listPtr, itemPtr); 3681 } 3682 } else if (returnSubindices) { 3683 int j; 3684 3685 itemPtr = TclNewWideIntObjFromSize(i+groupOffset); 3686 for (j=0 ; j<sortInfo.indexc ; j++) { 3687 Tcl_ListObjAppendElement(interp, itemPtr, TclNewWideIntObjFromSize( 3688 TclIndexDecode(sortInfo.indexv[j], listc))); 3689 } 3690 Tcl_ListObjAppendElement(interp, listPtr, itemPtr); 3691 } else { 3692 Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i)); 3693 } 3694 } 3695 } 3696 3697 /* 3698 * Return everything or a single value. 3699 */ 3700 3701 if (allMatches) { 3702 Tcl_SetObjResult(interp, listPtr); 3703 } else if (!inlineReturn) { 3704 if (returnSubindices) { 3705 int j; 3706 3707 itemPtr = TclNewWideIntObjFromSize(index+groupOffset); 3708 for (j=0 ; j<sortInfo.indexc ; j++) { 3709 Tcl_ListObjAppendElement(interp, itemPtr, TclNewWideIntObjFromSize( 3710 TclIndexDecode(sortInfo.indexv[j], listc))); 3711 } 3712 Tcl_SetObjResult(interp, itemPtr); 3713 } else { 3714 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index)); 3715 } 3716 } else if (index < 0) { 3717 /* 3718 * Is this superfluous? The result should be a blank object by 3719 * default... 3720 */ 3721 3722 Tcl_SetObjResult(interp, Tcl_NewObj()); 3723 } else { 3724 if (returnSubindices) { 3725 Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], 3726 &sortInfo)); 3727 } else if (groupSize > 1) { 3728 Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); 3729 } else { 3730 Tcl_SetObjResult(interp, listv[index]); 3731 } 3732 } 3733 result = TCL_OK; 3734 3735 /* 3736 * Cleanup the index list array. 3737 */ 3738 3739 done: 3740 if (startPtr != NULL) { 3741 Tcl_DecrRefCount(startPtr); 3742 } 3743 if (allocatedIndexVector) { 3744 TclStackFree(interp, sortInfo.indexv); 3745 } 3746 return result; 3747 } 3748 3749 /* 3750 *---------------------------------------------------------------------- 3751 * 3752 * Tcl_LsetObjCmd -- 3753 * 3754 * This procedure is invoked to process the "lset" Tcl command. See the 3755 * user documentation for details on what it does. 3756 * 3757 * Results: 3758 * A standard Tcl result. 3759 * 3760 * Side effects: 3761 * See the user documentation. 3762 * 3763 *---------------------------------------------------------------------- 3764 */ 3765 3766 int 3767 Tcl_LsetObjCmd( 3768 ClientData clientData, /* Not used. */ 3769 Tcl_Interp *interp, /* Current interpreter. */ 3770 int objc, /* Number of arguments. */ 3771 Tcl_Obj *const objv[]) /* Argument values. */ 3772 { 3773 Tcl_Obj *listPtr; /* Pointer to the list being altered. */ 3774 Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ 3775 3776 /* 3777 * Check parameter count. 3778 */ 3779 3780 if (objc < 3) { 3781 Tcl_WrongNumArgs(interp, 1, objv, 3782 "listVar ?index? ?index ...? value"); 3783 return TCL_ERROR; 3784 } 3785 3786 /* 3787 * Look up the list variable's value. 3788 */ 3789 3790 listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); 3791 if (listPtr == NULL) { 3792 return TCL_ERROR; 3793 } 3794 3795 /* 3796 * Substitute the value in the value. Return either the value or else an 3797 * unshared copy of it. 3798 */ 3799 3800 if (objc == 4) { 3801 finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); 3802 } else { 3803 finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, 3804 objv[objc-1]); 3805 } 3806 3807 /* 3808 * If substitution has failed, bail out. 3809 */ 3810 3811 if (finalValuePtr == NULL) { 3812 return TCL_ERROR; 3813 } 3814 3815 /* 3816 * Finally, update the variable so that traces fire. 3817 */ 3818 3819 listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, 3820 TCL_LEAVE_ERR_MSG); 3821 Tcl_DecrRefCount(finalValuePtr); 3822 if (listPtr == NULL) { 3823 return TCL_ERROR; 3824 } 3825 3826 /* 3827 * Return the new value of the variable as the interpreter result. 3828 */ 3829 3830 Tcl_SetObjResult(interp, listPtr); 3831 return TCL_OK; 3832 } 3833 3834 /* 3835 *---------------------------------------------------------------------- 3836 * 3837 * Tcl_LsortObjCmd -- 3838 * 3839 * This procedure is invoked to process the "lsort" Tcl command. See the 3840 * user documentation for details on what it does. 3841 * 3842 * Results: 3843 * A standard Tcl result. 3844 * 3845 * Side effects: 3846 * See the user documentation. 3847 * 3848 *---------------------------------------------------------------------- 3849 */ 3850 3851 int 3852 Tcl_LsortObjCmd( 3853 ClientData clientData, /* Not used. */ 3854 Tcl_Interp *interp, /* Current interpreter. */ 3855 int objc, /* Number of arguments. */ 3856 Tcl_Obj *const objv[]) /* Argument values. */ 3857 { 3858 int i, index, indices, length, nocase = 0, indexc; 3859 int sortMode = SORTMODE_ASCII; 3860 int group, allocatedIndexVector = 0; 3861 size_t j, idx, groupSize, groupOffset; 3862 Tcl_WideInt wide; 3863 Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; 3864 SortElement *elementArray = NULL, *elementPtr; 3865 SortInfo sortInfo; /* Information about this sort that needs to 3866 * be passed to the comparison function. */ 3867 # define NUM_LISTS 30 3868 SortElement *subList[NUM_LISTS+1]; 3869 /* This array holds pointers to temporary 3870 * lists built during the merge sort. Element 3871 * i of the array holds a list of length 3872 * 2**i. */ 3873 static const char *const switches[] = { 3874 "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", 3875 "-index", "-indices", "-integer", "-nocase", "-real", "-stride", 3876 "-unique", NULL 3877 }; 3878 enum Lsort_Switches { 3879 LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, 3880 LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, 3881 LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE 3882 }; 3883 3884 if (objc < 2) { 3885 Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); 3886 return TCL_ERROR; 3887 } 3888 3889 /* 3890 * Parse arguments to set up the mode for the sort. 3891 */ 3892 3893 sortInfo.isIncreasing = 1; 3894 sortInfo.sortMode = SORTMODE_ASCII; 3895 sortInfo.indexv = NULL; 3896 sortInfo.indexc = 0; 3897 sortInfo.unique = 0; 3898 sortInfo.interp = interp; 3899 sortInfo.resultCode = TCL_OK; 3900 cmdPtr = NULL; 3901 indices = 0; 3902 group = 0; 3903 groupSize = 1; 3904 groupOffset = 0; 3905 indexPtr = NULL; 3906 for (i = 1; i < objc-1; i++) { 3907 if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, 3908 &index) != TCL_OK) { 3909 sortInfo.resultCode = TCL_ERROR; 3910 goto done; 3911 } 3912 switch ((enum Lsort_Switches) index) { 3913 case LSORT_ASCII: 3914 sortInfo.sortMode = SORTMODE_ASCII; 3915 break; 3916 case LSORT_COMMAND: 3917 if (i == objc-2) { 3918 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3919 "\"-command\" option must be followed " 3920 "by comparison command", -1)); 3921 Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); 3922 sortInfo.resultCode = TCL_ERROR; 3923 goto done; 3924 } 3925 sortInfo.sortMode = SORTMODE_COMMAND; 3926 cmdPtr = objv[i+1]; 3927 i++; 3928 break; 3929 case LSORT_DECREASING: 3930 sortInfo.isIncreasing = 0; 3931 break; 3932 case LSORT_DICTIONARY: 3933 sortInfo.sortMode = SORTMODE_DICTIONARY; 3934 break; 3935 case LSORT_INCREASING: 3936 sortInfo.isIncreasing = 1; 3937 break; 3938 case LSORT_INDEX: { 3939 int indexc; 3940 Tcl_Obj **indexv; 3941 3942 if (i == objc-2) { 3943 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3944 "\"-index\" option must be followed by list index", 3945 -1)); 3946 Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); 3947 sortInfo.resultCode = TCL_ERROR; 3948 goto done; 3949 } 3950 if (TclListObjGetElements(interp, objv[i+1], &indexc, 3951 &indexv) != TCL_OK) { 3952 sortInfo.resultCode = TCL_ERROR; 3953 goto done; 3954 } 3955 3956 /* 3957 * Check each of the indices for syntactic correctness. Note that 3958 * we do not store the converted values here because we do not 3959 * know if this is the only -index option yet and so we can't 3960 * allocate any space; that happens after the scan through all the 3961 * options is done. 3962 */ 3963 3964 for (j=0 ; j<(size_t)indexc ; j++) { 3965 int encoded = 0; 3966 int result = TclIndexEncode(interp, indexv[j], 3967 TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded); 3968 3969 if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) { 3970 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 3971 "index \"%s\" cannot select an element " 3972 "from any list", TclGetString(indexv[j]))); 3973 Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" 3974 "OUTOFRANGE", NULL); 3975 result = TCL_ERROR; 3976 } 3977 if (result == TCL_ERROR) { 3978 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 3979 "\n (-index option item number %" TCL_Z_MODIFIER "d)", j)); 3980 sortInfo.resultCode = TCL_ERROR; 3981 goto done; 3982 } 3983 } 3984 indexPtr = objv[i+1]; 3985 i++; 3986 break; 3987 } 3988 case LSORT_INTEGER: 3989 sortInfo.sortMode = SORTMODE_INTEGER; 3990 break; 3991 case LSORT_NOCASE: 3992 nocase = 1; 3993 break; 3994 case LSORT_REAL: 3995 sortInfo.sortMode = SORTMODE_REAL; 3996 break; 3997 case LSORT_UNIQUE: 3998 sortInfo.unique = 1; 3999 break; 4000 case LSORT_INDICES: 4001 indices = 1; 4002 break; 4003 case LSORT_STRIDE: 4004 if (i == objc-2) { 4005 Tcl_SetObjResult(interp, Tcl_NewStringObj( 4006 "\"-stride\" option must be " 4007 "followed by stride length", -1)); 4008 Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); 4009 sortInfo.resultCode = TCL_ERROR; 4010 goto done; 4011 } 4012 if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { 4013 sortInfo.resultCode = TCL_ERROR; 4014 goto done; 4015 } 4016 if (wide < 2) { 4017 Tcl_SetObjResult(interp, Tcl_NewStringObj( 4018 "stride length must be at least 2", -1)); 4019 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", 4020 "BADSTRIDE", NULL); 4021 sortInfo.resultCode = TCL_ERROR; 4022 goto done; 4023 } 4024 groupSize = wide; 4025 group = 1; 4026 i++; 4027 break; 4028 } 4029 } 4030 if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { 4031 sortInfo.sortMode = SORTMODE_ASCII_NC; 4032 } 4033 4034 /* 4035 * Now extract the -index list for real, if present. No failures are 4036 * expected here; the values are all of the right type or convertible to 4037 * it. 4038 */ 4039 4040 if (indexPtr) { 4041 Tcl_Obj **indexv; 4042 4043 TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); 4044 switch (sortInfo.indexc) { 4045 case 0: 4046 sortInfo.indexv = NULL; 4047 break; 4048 case 1: 4049 sortInfo.indexv = &sortInfo.singleIndex; 4050 break; 4051 default: 4052 sortInfo.indexv = 4053 TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); 4054 allocatedIndexVector = 1; /* Cannot use indexc field, as it 4055 * might be decreased by 1 later. */ 4056 } 4057 for (j=0 ; j<(size_t)sortInfo.indexc ; j++) { 4058 /* Prescreened values, no errors or out of range possible */ 4059 TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE, 4060 TCL_INDEX_NONE, &sortInfo.indexv[j]); 4061 } 4062 } 4063 4064 listObj = objv[objc-1]; 4065 4066 if (sortInfo.sortMode == SORTMODE_COMMAND) { 4067 Tcl_Obj *newCommandPtr, *newObjPtr; 4068 4069 /* 4070 * When sorting using a command, we are reentrant and therefore might 4071 * have the representation of the list being sorted shimmered out from 4072 * underneath our feet. Take a copy (cheap) to prevent this. [Bug 4073 * 1675116] 4074 */ 4075 4076 listObj = TclListObjCopy(interp, listObj); 4077 if (listObj == NULL) { 4078 sortInfo.resultCode = TCL_ERROR; 4079 goto done; 4080 } 4081 4082 /* 4083 * The existing command is a list. We want to flatten it, append two 4084 * dummy arguments on the end, and replace these arguments later. 4085 */ 4086 4087 newCommandPtr = Tcl_DuplicateObj(cmdPtr); 4088 TclNewObj(newObjPtr); 4089 Tcl_IncrRefCount(newCommandPtr); 4090 if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) 4091 != TCL_OK) { 4092 TclDecrRefCount(newCommandPtr); 4093 TclDecrRefCount(listObj); 4094 Tcl_IncrRefCount(newObjPtr); 4095 TclDecrRefCount(newObjPtr); 4096 sortInfo.resultCode = TCL_ERROR; 4097 goto done; 4098 } 4099 Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); 4100 sortInfo.compareCmdPtr = newCommandPtr; 4101 } 4102 4103 sortInfo.resultCode = TclListObjGetElements(interp, listObj, 4104 &length, &listObjPtrs); 4105 if (sortInfo.resultCode != TCL_OK || length <= 0) { 4106 goto done; 4107 } 4108 4109 /* 4110 * Check for sanity when grouping elements of the overall list together 4111 * because of the -stride option. [TIP #326] 4112 */ 4113 4114 if (group) { 4115 if (length % groupSize) { 4116 Tcl_SetObjResult(interp, Tcl_NewStringObj( 4117 "list size must be a multiple of the stride length", 4118 -1)); 4119 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", 4120 NULL); 4121 sortInfo.resultCode = TCL_ERROR; 4122 goto done; 4123 } 4124 length = length / groupSize; 4125 if (sortInfo.indexc > 0) { 4126 /* 4127 * Use the first value in the list supplied to -index as the 4128 * offset of the element within each group by which to sort. 4129 */ 4130 4131 groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); 4132 if (groupOffset >= groupSize) { 4133 Tcl_SetObjResult(interp, Tcl_NewStringObj( 4134 "when used with \"-stride\", the leading \"-index\"" 4135 " value must be within the group", -1)); 4136 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", 4137 "BADINDEX", NULL); 4138 sortInfo.resultCode = TCL_ERROR; 4139 goto done; 4140 } 4141 if (sortInfo.indexc == 1) { 4142 sortInfo.indexc = 0; 4143 sortInfo.indexv = NULL; 4144 } else { 4145 sortInfo.indexc--; 4146 4147 /* 4148 * Do not shrink the actual memory block used; that doesn't 4149 * work with TclStackAlloc-allocated memory. [Bug 2918962] 4150 * 4151 * TODO: Consider a pointer increment to replace this 4152 * array shift. 4153 */ 4154 4155 for (i = 0; i < sortInfo.indexc; i++) { 4156 sortInfo.indexv[i] = sortInfo.indexv[i+1]; 4157 } 4158 } 4159 } 4160 } 4161 4162 sortInfo.numElements = length; 4163 4164 indexc = sortInfo.indexc; 4165 sortMode = sortInfo.sortMode; 4166 if ((sortMode == SORTMODE_ASCII_NC) 4167 || (sortMode == SORTMODE_DICTIONARY)) { 4168 /* 4169 * For this function's purpose all string-based modes are equivalent 4170 */ 4171 4172 sortMode = SORTMODE_ASCII; 4173 } 4174 4175 /* 4176 * Initialize the sublists. After the following loop, subList[i] will 4177 * contain a sorted sublist of length 2**i. Use one extra subList at the 4178 * end, always at NULL, to indicate the end of the lists. 4179 */ 4180 4181 for (j=0 ; j<=NUM_LISTS ; j++) { 4182 subList[j] = NULL; 4183 } 4184 4185 /* 4186 * The following loop creates a SortElement for each list element and 4187 * begins sorting it into the sublists as it appears. 4188 */ 4189 4190 elementArray = Tcl_Alloc(length * sizeof(SortElement)); 4191 4192 for (i=0; i < length; i++){ 4193 idx = groupSize * i + groupOffset; 4194 if (indexc) { 4195 /* 4196 * If this is an indexed sort, retrieve the corresponding element 4197 */ 4198 indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo); 4199 if (sortInfo.resultCode != TCL_OK) { 4200 goto done; 4201 } 4202 } else { 4203 indexPtr = listObjPtrs[idx]; 4204 } 4205 4206 /* 4207 * Determine the "value" of this object for sorting purposes 4208 */ 4209 4210 if (sortMode == SORTMODE_ASCII) { 4211 elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); 4212 } else if (sortMode == SORTMODE_INTEGER) { 4213 Tcl_WideInt a; 4214 4215 if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { 4216 sortInfo.resultCode = TCL_ERROR; 4217 goto done; 4218 } 4219 elementArray[i].collationKey.wideValue = a; 4220 } else if (sortMode == SORTMODE_REAL) { 4221 double a; 4222 4223 if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, 4224 &a) != TCL_OK) { 4225 sortInfo.resultCode = TCL_ERROR; 4226 goto done; 4227 } 4228 elementArray[i].collationKey.doubleValue = a; 4229 } else { 4230 elementArray[i].collationKey.objValuePtr = indexPtr; 4231 } 4232 4233 /* 4234 * Determine the representation of this element in the result: either 4235 * the objPtr itself, or its index in the original list. 4236 */ 4237 4238 if (indices || group) { 4239 elementArray[i].payload.index = idx; 4240 } else { 4241 elementArray[i].payload.objPtr = listObjPtrs[idx]; 4242 } 4243 4244 /* 4245 * Merge this element in the pre-existing sublists (and merge together 4246 * sublists when we have two of the same size). 4247 */ 4248 4249 elementArray[i].nextPtr = NULL; 4250 elementPtr = &elementArray[i]; 4251 for (j=0 ; subList[j] ; j++) { 4252 elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); 4253 subList[j] = NULL; 4254 } 4255 if (j >= NUM_LISTS) { 4256 j = NUM_LISTS-1; 4257 } 4258 subList[j] = elementPtr; 4259 } 4260 4261 /* 4262 * Merge all sublists 4263 */ 4264 4265 elementPtr = subList[0]; 4266 for (j=1 ; j<NUM_LISTS ; j++) { 4267 elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); 4268 } 4269 4270 /* 4271 * Now store the sorted elements in the result list. 4272 */ 4273 4274 if (sortInfo.resultCode == TCL_OK) { 4275 List *listRepPtr; 4276 Tcl_Obj **newArray, *objPtr; 4277 4278 resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL); 4279 listRepPtr = ListRepPtr(resultPtr); 4280 newArray = &listRepPtr->elements; 4281 if (group) { 4282 for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { 4283 idx = elementPtr->payload.index; 4284 for (j = 0; j < groupSize; j++) { 4285 if (indices) { 4286 objPtr = TclNewWideIntObjFromSize(idx + j - groupOffset); 4287 newArray[i++] = objPtr; 4288 Tcl_IncrRefCount(objPtr); 4289 } else { 4290 objPtr = listObjPtrs[idx + j - groupOffset]; 4291 newArray[i++] = objPtr; 4292 Tcl_IncrRefCount(objPtr); 4293 } 4294 } 4295 } 4296 } else if (indices) { 4297 for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { 4298 objPtr = TclNewWideIntObjFromSize(elementPtr->payload.index); 4299 newArray[i++] = objPtr; 4300 Tcl_IncrRefCount(objPtr); 4301 } 4302 } else { 4303 for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { 4304 objPtr = elementPtr->payload.objPtr; 4305 newArray[i++] = objPtr; 4306 Tcl_IncrRefCount(objPtr); 4307 } 4308 } 4309 listRepPtr->elemCount = i; 4310 Tcl_SetObjResult(interp, resultPtr); 4311 } 4312 4313 done: 4314 if (sortMode == SORTMODE_COMMAND) { 4315 TclDecrRefCount(sortInfo.compareCmdPtr); 4316 TclDecrRefCount(listObj); 4317 sortInfo.compareCmdPtr = NULL; 4318 } 4319 if (allocatedIndexVector) { 4320 TclStackFree(interp, sortInfo.indexv); 4321 } 4322 if (elementArray) { 4323 Tcl_Free(elementArray); 4324 } 4325 return sortInfo.resultCode; 4326 } 4327 4328 /* 4329 *---------------------------------------------------------------------- 4330 * 4331 * MergeLists - 4332 * 4333 * This procedure combines two sorted lists of SortElement structures 4334 * into a single sorted list. 4335 * 4336 * Results: 4337 * The unified list of SortElement structures. 4338 * 4339 * Side effects: 4340 * If infoPtr->unique is set then infoPtr->numElements may be updated. 4341 * Possibly others, if a user-defined comparison command does something 4342 * weird. 4343 * 4344 * Note: 4345 * If infoPtr->unique is set, the merge assumes that there are no 4346 * "repeated" elements in each of the left and right lists. In that case, 4347 * if any element of the left list is equivalent to one in the right list 4348 * it is omitted from the merged list. 4349 * 4350 * This simplified mechanism works because of the special way our 4351 * MergeSort creates the sublists to be merged and will fail to eliminate 4352 * all repeats in the general case where they are already present in 4353 * either the left or right list. A general code would need to skip 4354 * adjacent initial repeats in the left and right lists before comparing 4355 * their initial elements, at each step. 4356 * 4357 *---------------------------------------------------------------------- 4358 */ 4359 4360 static SortElement * 4361 MergeLists( 4362 SortElement *leftPtr, /* First list to be merged; may be NULL. */ 4363 SortElement *rightPtr, /* Second list to be merged; may be NULL. */ 4364 SortInfo *infoPtr) /* Information needed by the comparison 4365 * operator. */ 4366 { 4367 SortElement *headPtr, *tailPtr; 4368 int cmp; 4369 4370 if (leftPtr == NULL) { 4371 return rightPtr; 4372 } 4373 if (rightPtr == NULL) { 4374 return leftPtr; 4375 } 4376 cmp = SortCompare(leftPtr, rightPtr, infoPtr); 4377 if (cmp > 0 || (cmp == 0 && infoPtr->unique)) { 4378 if (cmp == 0) { 4379 infoPtr->numElements--; 4380 leftPtr = leftPtr->nextPtr; 4381 } 4382 tailPtr = rightPtr; 4383 rightPtr = rightPtr->nextPtr; 4384 } else { 4385 tailPtr = leftPtr; 4386 leftPtr = leftPtr->nextPtr; 4387 } 4388 headPtr = tailPtr; 4389 if (!infoPtr->unique) { 4390 while ((leftPtr != NULL) && (rightPtr != NULL)) { 4391 cmp = SortCompare(leftPtr, rightPtr, infoPtr); 4392 if (cmp > 0) { 4393 tailPtr->nextPtr = rightPtr; 4394 tailPtr = rightPtr; 4395 rightPtr = rightPtr->nextPtr; 4396 } else { 4397 tailPtr->nextPtr = leftPtr; 4398 tailPtr = leftPtr; 4399 leftPtr = leftPtr->nextPtr; 4400 } 4401 } 4402 } else { 4403 while ((leftPtr != NULL) && (rightPtr != NULL)) { 4404 cmp = SortCompare(leftPtr, rightPtr, infoPtr); 4405 if (cmp >= 0) { 4406 if (cmp == 0) { 4407 infoPtr->numElements--; 4408 leftPtr = leftPtr->nextPtr; 4409 } 4410 tailPtr->nextPtr = rightPtr; 4411 tailPtr = rightPtr; 4412 rightPtr = rightPtr->nextPtr; 4413 } else { 4414 tailPtr->nextPtr = leftPtr; 4415 tailPtr = leftPtr; 4416 leftPtr = leftPtr->nextPtr; 4417 } 4418 } 4419 } 4420 if (leftPtr != NULL) { 4421 tailPtr->nextPtr = leftPtr; 4422 } else { 4423 tailPtr->nextPtr = rightPtr; 4424 } 4425 return headPtr; 4426 } 4427 4428 /* 4429 *---------------------------------------------------------------------- 4430 * 4431 * SortCompare -- 4432 * 4433 * This procedure is invoked by MergeLists to determine the proper 4434 * ordering between two elements. 4435 * 4436 * Results: 4437 * A negative results means the the first element comes before the 4438 * second, and a positive results means that the second element should 4439 * come first. A result of zero means the two elements are equal and it 4440 * doesn't matter which comes first. 4441 * 4442 * Side effects: 4443 * None, unless a user-defined comparison command does something weird. 4444 * 4445 *---------------------------------------------------------------------- 4446 */ 4447 4448 static int 4449 SortCompare( 4450 SortElement *elemPtr1, SortElement *elemPtr2, 4451 /* Values to be compared. */ 4452 SortInfo *infoPtr) /* Information passed from the top-level 4453 * "lsort" command. */ 4454 { 4455 int order = 0; 4456 4457 if (infoPtr->sortMode == SORTMODE_ASCII) { 4458 order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, 4459 elemPtr2->collationKey.strValuePtr); 4460 } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { 4461 order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, 4462 elemPtr2->collationKey.strValuePtr); 4463 } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { 4464 order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, 4465 elemPtr2->collationKey.strValuePtr); 4466 } else if (infoPtr->sortMode == SORTMODE_INTEGER) { 4467 Tcl_WideInt a, b; 4468 4469 a = elemPtr1->collationKey.wideValue; 4470 b = elemPtr2->collationKey.wideValue; 4471 order = ((a >= b) - (a <= b)); 4472 } else if (infoPtr->sortMode == SORTMODE_REAL) { 4473 double a, b; 4474 4475 a = elemPtr1->collationKey.doubleValue; 4476 b = elemPtr2->collationKey.doubleValue; 4477 order = ((a >= b) - (a <= b)); 4478 } else { 4479 Tcl_Obj **objv, *paramObjv[2]; 4480 int objc; 4481 Tcl_Obj *objPtr1, *objPtr2; 4482 4483 if (infoPtr->resultCode != TCL_OK) { 4484 /* 4485 * Once an error has occurred, skip any future comparisons so as 4486 * to preserve the error message in sortInterp->result. 4487 */ 4488 4489 return 0; 4490 } 4491 4492 4493 objPtr1 = elemPtr1->collationKey.objValuePtr; 4494 objPtr2 = elemPtr2->collationKey.objValuePtr; 4495 4496 paramObjv[0] = objPtr1; 4497 paramObjv[1] = objPtr2; 4498 4499 /* 4500 * We made space in the command list for the two things to compare. 4501 * Replace them and evaluate the result. 4502 */ 4503 4504 TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); 4505 Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, 4506 2, 2, paramObjv); 4507 TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, 4508 &objc, &objv); 4509 4510 infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); 4511 4512 if (infoPtr->resultCode != TCL_OK) { 4513 Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); 4514 return 0; 4515 } 4516 4517 /* 4518 * Parse the result of the command. 4519 */ 4520 4521 if (TclGetIntFromObj(infoPtr->interp, 4522 Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) { 4523 Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj( 4524 "-compare command returned non-integer result", -1)); 4525 Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", 4526 "COMPARISONFAILED", NULL); 4527 infoPtr->resultCode = TCL_ERROR; 4528 return 0; 4529 } 4530 } 4531 if (!infoPtr->isIncreasing) { 4532 order = -order; 4533 } 4534 return order; 4535 } 4536 4537 /* 4538 *---------------------------------------------------------------------- 4539 * 4540 * DictionaryCompare 4541 * 4542 * This function compares two strings as if they were being used in an 4543 * index or card catalog. The case of alphabetic characters is ignored, 4544 * except to break ties. Thus "B" comes before "b" but after "a". Also, 4545 * integers embedded in the strings compare in numerical order. In other 4546 * words, "x10y" comes after "x9y", not * before it as it would when 4547 * using strcmp(). 4548 * 4549 * Results: 4550 * A negative result means that the first element comes before the 4551 * second, and a positive result means that the second element should 4552 * come first. A result of zero means the two elements are equal and it 4553 * doesn't matter which comes first. 4554 * 4555 * Side effects: 4556 * None. 4557 * 4558 *---------------------------------------------------------------------- 4559 */ 4560 4561 static int 4562 DictionaryCompare( 4563 const char *left, const char *right) /* The strings to compare. */ 4564 { 4565 Tcl_UniChar uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; 4566 int diff, zeros; 4567 int secondaryDiff = 0; 4568 4569 while (1) { 4570 if (isdigit(UCHAR(*right)) /* INTL: digit */ 4571 && isdigit(UCHAR(*left))) { /* INTL: digit */ 4572 /* 4573 * There are decimal numbers embedded in the two strings. Compare 4574 * them as numbers, rather than strings. If one number has more 4575 * leading zeros than the other, the number with more leading 4576 * zeros sorts later, but only as a secondary choice. 4577 */ 4578 4579 zeros = 0; 4580 while ((*right == '0') && isdigit(UCHAR(right[1]))) { 4581 right++; 4582 zeros--; 4583 } 4584 while ((*left == '0') && isdigit(UCHAR(left[1]))) { 4585 left++; 4586 zeros++; 4587 } 4588 if (secondaryDiff == 0) { 4589 secondaryDiff = zeros; 4590 } 4591 4592 /* 4593 * The code below compares the numbers in the two strings without 4594 * ever converting them to integers. It does this by first 4595 * comparing the lengths of the numbers and then comparing the 4596 * digit values. 4597 */ 4598 4599 diff = 0; 4600 while (1) { 4601 if (diff == 0) { 4602 diff = UCHAR(*left) - UCHAR(*right); 4603 } 4604 right++; 4605 left++; 4606 if (!isdigit(UCHAR(*right))) { /* INTL: digit */ 4607 if (isdigit(UCHAR(*left))) { /* INTL: digit */ 4608 return 1; 4609 } else { 4610 /* 4611 * The two numbers have the same length. See if their 4612 * values are different. 4613 */ 4614 4615 if (diff != 0) { 4616 return diff; 4617 } 4618 break; 4619 } 4620 } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ 4621 return -1; 4622 } 4623 } 4624 continue; 4625 } 4626 4627 /* 4628 * Convert character to Unicode for comparison purposes. If either 4629 * string is at the terminating null, do a byte-wise comparison and 4630 * bail out immediately. 4631 */ 4632 4633 if ((*left != '\0') && (*right != '\0')) { 4634 left += TclUtfToUniChar(left, &uniLeft); 4635 right += TclUtfToUniChar(right, &uniRight); 4636 4637 /* 4638 * Convert both chars to lower for the comparison, because 4639 * dictionary sorts are case insensitve. Covert to lower, not 4640 * upper, so chars between Z and a will sort before A (where most 4641 * other interesting punctuations occur). 4642 */ 4643 4644 uniLeftLower = Tcl_UniCharToLower(uniLeft); 4645 uniRightLower = Tcl_UniCharToLower(uniRight); 4646 } else { 4647 diff = UCHAR(*left) - UCHAR(*right); 4648 break; 4649 } 4650 4651 diff = uniLeftLower - uniRightLower; 4652 if (diff) { 4653 return diff; 4654 } 4655 if (secondaryDiff == 0) { 4656 if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { 4657 secondaryDiff = -1; 4658 } else if (Tcl_UniCharIsUpper(uniRight) 4659 && Tcl_UniCharIsLower(uniLeft)) { 4660 secondaryDiff = 1; 4661 } 4662 } 4663 } 4664 if (diff == 0) { 4665 diff = secondaryDiff; 4666 } 4667 return diff; 4668 } 4669 4670 /* 4671 *---------------------------------------------------------------------- 4672 * 4673 * SelectObjFromSublist -- 4674 * 4675 * This procedure is invoked from lsearch and SortCompare. It is used for 4676 * implementing the -index option, for the lsort and lsearch commands. 4677 * 4678 * Results: 4679 * Returns NULL if a failure occurs, and sets the result in the infoPtr. 4680 * Otherwise returns the Tcl_Obj* to the item. 4681 * 4682 * Side effects: 4683 * None. 4684 * 4685 * Note: 4686 * No reference counting is done, as the result is only used internally 4687 * and never passed directly to user code. 4688 * 4689 *---------------------------------------------------------------------- 4690 */ 4691 4692 static Tcl_Obj * 4693 SelectObjFromSublist( 4694 Tcl_Obj *objPtr, /* Obj to select sublist from. */ 4695 SortInfo *infoPtr) /* Information passed from the top-level 4696 * "lsearch" or "lsort" command. */ 4697 { 4698 int i; 4699 4700 /* 4701 * Quick check for case when no "-index" option is there. 4702 */ 4703 4704 if (infoPtr->indexc == 0) { 4705 return objPtr; 4706 } 4707 4708 /* 4709 * Iterate over the indices, traversing through the nested sublists as we 4710 * go. 4711 */ 4712 4713 for (i=0 ; i<infoPtr->indexc ; i++) { 4714 int listLen, index; 4715 Tcl_Obj *currentObj; 4716 4717 if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { 4718 infoPtr->resultCode = TCL_ERROR; 4719 return NULL; 4720 } 4721 4722 index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); 4723 4724 if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, 4725 &currentObj) != TCL_OK) { 4726 infoPtr->resultCode = TCL_ERROR; 4727 return NULL; 4728 } 4729 if (currentObj == NULL) { 4730 if (index == (int)TCL_INDEX_NONE) { 4731 index = TCL_INDEX_END - infoPtr->indexv[i]; 4732 Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( 4733 "element end-%d missing from sublist \"%s\"", 4734 index, TclGetString(objPtr))); 4735 } else { 4736 Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( 4737 "element %d missing from sublist \"%s\"", 4738 index, TclGetString(objPtr))); 4739 } 4740 Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", 4741 "INDEXFAILED", NULL); 4742 infoPtr->resultCode = TCL_ERROR; 4743 return NULL; 4744 } 4745 objPtr = currentObj; 4746 } 4747 return objPtr; 4748 } 4749 4750 /* 4751 * Local Variables: 4752 * mode: c 4753 * c-basic-offset: 4 4754 * fill-column: 78 4755 * tab-width: 8 4756 * End: 4757 */