/*
|
/*
|
* tclCmdIL.c --
|
* tclCmdIL.c --
|
*
|
*
|
* This file contains the top-level command routines for most of
|
* This file contains the top-level command routines for most of
|
* the Tcl built-in commands whose names begin with the letters
|
* the Tcl built-in commands whose names begin with the letters
|
* I through L. It contains only commands in the generic core
|
* I through L. It contains only commands in the generic core
|
* (i.e. those that don't depend much upon UNIX facilities).
|
* (i.e. those that don't depend much upon UNIX facilities).
|
*
|
*
|
* Copyright (c) 1987-1993 The Regents of the University of California.
|
* Copyright (c) 1987-1993 The Regents of the University of California.
|
* Copyright (c) 1993-1997 Lucent Technologies.
|
* Copyright (c) 1993-1997 Lucent Technologies.
|
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
* Copyright (c) 1998 by Scriptics Corporation.
|
* Copyright (c) 1998 by Scriptics Corporation.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclCmdIL.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $
|
* RCS: @(#) $Id: tclCmdIL.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
#include "tclCompile.h"
|
#include "tclCompile.h"
|
|
|
/*
|
/*
|
* During execution of the "lsort" command, structures of the following
|
* During execution of the "lsort" command, structures of the following
|
* type are used to arrange the objects being sorted into a collection
|
* type are used to arrange the objects being sorted into a collection
|
* of linked lists.
|
* of linked lists.
|
*/
|
*/
|
|
|
typedef struct SortElement {
|
typedef struct SortElement {
|
Tcl_Obj *objPtr; /* Object being sorted. */
|
Tcl_Obj *objPtr; /* Object being sorted. */
|
struct SortElement *nextPtr; /* Next element in the list, or
|
struct SortElement *nextPtr; /* Next element in the list, or
|
* NULL for end of list. */
|
* NULL for end of list. */
|
} SortElement;
|
} SortElement;
|
|
|
/*
|
/*
|
* The "lsort" command needs to pass certain information down to the
|
* The "lsort" command needs to pass certain information down to the
|
* function that compares two list elements, and the comparison function
|
* function that compares two list elements, and the comparison function
|
* needs to pass success or failure information back up to the top-level
|
* needs to pass success or failure information back up to the top-level
|
* "lsort" command. The following structure is used to pass this
|
* "lsort" command. The following structure is used to pass this
|
* information.
|
* information.
|
*/
|
*/
|
|
|
typedef struct SortInfo {
|
typedef struct SortInfo {
|
int isIncreasing; /* Nonzero means sort in increasing order. */
|
int isIncreasing; /* Nonzero means sort in increasing order. */
|
int sortMode; /* The sort mode. One of SORTMODE_*
|
int sortMode; /* The sort mode. One of SORTMODE_*
|
* values defined below */
|
* values defined below */
|
Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
|
Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
|
* is SORTMODE_COMMAND. Pre-initialized to
|
* is SORTMODE_COMMAND. Pre-initialized to
|
* hold base of command.*/
|
* hold base of command.*/
|
int index; /* If the -index option was specified, this
|
int index; /* If the -index option was specified, this
|
* holds the index of the list element
|
* holds the index of the list element
|
* to extract for comparison. If -index
|
* to extract for comparison. If -index
|
* wasn't specified, this is -1. */
|
* wasn't specified, this is -1. */
|
Tcl_Interp *interp; /* The interpreter in which the sortis
|
Tcl_Interp *interp; /* The interpreter in which the sortis
|
* being done. */
|
* being done. */
|
int resultCode; /* Completion code for the lsort command.
|
int resultCode; /* Completion code for the lsort command.
|
* If an error occurs during the sort this
|
* If an error occurs during the sort this
|
* is changed from TCL_OK to TCL_ERROR. */
|
* is changed from TCL_OK to TCL_ERROR. */
|
} SortInfo;
|
} SortInfo;
|
|
|
/*
|
/*
|
* The "sortMode" field of the SortInfo structure can take on any of the
|
* The "sortMode" field of the SortInfo structure can take on any of the
|
* following values.
|
* following values.
|
*/
|
*/
|
|
|
#define SORTMODE_ASCII 0
|
#define SORTMODE_ASCII 0
|
#define SORTMODE_INTEGER 1
|
#define SORTMODE_INTEGER 1
|
#define SORTMODE_REAL 2
|
#define SORTMODE_REAL 2
|
#define SORTMODE_COMMAND 3
|
#define SORTMODE_COMMAND 3
|
#define SORTMODE_DICTIONARY 4
|
#define SORTMODE_DICTIONARY 4
|
|
|
/*
|
/*
|
* Forward declarations for procedures defined in this file:
|
* Forward declarations for procedures defined in this file:
|
*/
|
*/
|
|
|
static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
|
static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
|
Tcl_Obj *listPtr, char *pattern,
|
Tcl_Obj *listPtr, char *pattern,
|
int includeLinks));
|
int includeLinks));
|
static int DictionaryCompare _ANSI_ARGS_((char *left,
|
static int DictionaryCompare _ANSI_ARGS_((char *left,
|
char *right));
|
char *right));
|
static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoNameOfExecutableCmd _ANSI_ARGS_((
|
static int InfoNameOfExecutableCmd _ANSI_ARGS_((
|
ClientData dummy, Tcl_Interp *interp, int objc,
|
ClientData dummy, Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
|
static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
|
Tcl_Interp *interp, int objc,
|
Tcl_Interp *interp, int objc,
|
Tcl_Obj *CONST objv[]));
|
Tcl_Obj *CONST objv[]));
|
static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
|
static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
|
SortInfo *infoPtr));
|
SortInfo *infoPtr));
|
static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
|
static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
|
SortElement *rightPtr, SortInfo *infoPtr));
|
SortElement *rightPtr, SortInfo *infoPtr));
|
static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
|
static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
|
Tcl_Obj *second, SortInfo *infoPtr));
|
Tcl_Obj *second, SortInfo *infoPtr));
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_IfCmd --
|
* Tcl_IfCmd --
|
*
|
*
|
* This procedure is invoked to process the "if" Tcl command.
|
* This procedure is invoked to process the "if" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* With the bytecode compiler, this procedure is only called when
|
* With the bytecode compiler, this procedure is only called when
|
* a command name is computed at runtime, and is "if" or the name
|
* a command name is computed at runtime, and is "if" or the name
|
* to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
|
* to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_IfCmd(dummy, interp, argc, argv)
|
Tcl_IfCmd(dummy, interp, argc, argv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
int i, result, value;
|
int i, result, value;
|
|
|
i = 1;
|
i = 1;
|
while (1) {
|
while (1) {
|
/*
|
/*
|
* At this point in the loop, argv and argc refer to an expression
|
* At this point in the loop, argv and argc refer to an expression
|
* to test, either for the main expression or an expression
|
* to test, either for the main expression or an expression
|
* following an "elseif". The arguments after the expression must
|
* following an "elseif". The arguments after the expression must
|
* be "then" (optional) and a script to execute if the expression is
|
* be "then" (optional) and a script to execute if the expression is
|
* true.
|
* true.
|
*/
|
*/
|
|
|
if (i >= argc) {
|
if (i >= argc) {
|
Tcl_AppendResult(interp, "wrong # args: no expression after \"",
|
Tcl_AppendResult(interp, "wrong # args: no expression after \"",
|
argv[i-1], "\" argument", (char *) NULL);
|
argv[i-1], "\" argument", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
result = Tcl_ExprBoolean(interp, argv[i], &value);
|
result = Tcl_ExprBoolean(interp, argv[i], &value);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
i++;
|
i++;
|
if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
|
if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
|
i++;
|
i++;
|
}
|
}
|
if (i >= argc) {
|
if (i >= argc) {
|
Tcl_AppendResult(interp, "wrong # args: no script following \"",
|
Tcl_AppendResult(interp, "wrong # args: no script following \"",
|
argv[i-1], "\" argument", (char *) NULL);
|
argv[i-1], "\" argument", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (value) {
|
if (value) {
|
return Tcl_Eval(interp, argv[i]);
|
return Tcl_Eval(interp, argv[i]);
|
}
|
}
|
|
|
/*
|
/*
|
* The expression evaluated to false. Skip the command, then
|
* The expression evaluated to false. Skip the command, then
|
* see if there is an "else" or "elseif" clause.
|
* see if there is an "else" or "elseif" clause.
|
*/
|
*/
|
|
|
i++;
|
i++;
|
if (i >= argc) {
|
if (i >= argc) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
|
if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
|
i++;
|
i++;
|
continue;
|
continue;
|
}
|
}
|
break;
|
break;
|
}
|
}
|
|
|
/*
|
/*
|
* Couldn't find a "then" or "elseif" clause to execute. Check now
|
* Couldn't find a "then" or "elseif" clause to execute. Check now
|
* for an "else" clause. We know that there's at least one more
|
* for an "else" clause. We know that there's at least one more
|
* argument when we get here.
|
* argument when we get here.
|
*/
|
*/
|
|
|
if (strcmp(argv[i], "else") == 0) {
|
if (strcmp(argv[i], "else") == 0) {
|
i++;
|
i++;
|
if (i >= argc) {
|
if (i >= argc) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"wrong # args: no script following \"else\" argument",
|
"wrong # args: no script following \"else\" argument",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
return Tcl_Eval(interp, argv[i]);
|
return Tcl_Eval(interp, argv[i]);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_IncrCmd --
|
* Tcl_IncrCmd --
|
*
|
*
|
* This procedure is invoked to process the "incr" Tcl command.
|
* This procedure is invoked to process the "incr" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* With the bytecode compiler, this procedure is only called when
|
* With the bytecode compiler, this procedure is only called when
|
* a command name is computed at runtime, and is "incr" or the name
|
* a command name is computed at runtime, and is "incr" or the name
|
* to which "incr" was renamed: e.g., "set z incr; $z i -1"
|
* to which "incr" was renamed: e.g., "set z incr; $z i -1"
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_IncrCmd(dummy, interp, argc, argv)
|
Tcl_IncrCmd(dummy, interp, argc, argv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
int value;
|
int value;
|
char *oldString, *result;
|
char *oldString, *result;
|
char newString[30];
|
char newString[30];
|
|
|
if ((argc != 2) && (argc != 3)) {
|
if ((argc != 2) && (argc != 3)) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" varName ?increment?\"", (char *) NULL);
|
" varName ?increment?\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
|
oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
|
if (oldString == NULL) {
|
if (oldString == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
|
if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
|
Tcl_AddErrorInfo(interp,
|
Tcl_AddErrorInfo(interp,
|
"\n (reading value of variable to increment)");
|
"\n (reading value of variable to increment)");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (argc == 2) {
|
if (argc == 2) {
|
value += 1;
|
value += 1;
|
} else {
|
} else {
|
int increment;
|
int increment;
|
|
|
if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
|
if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
|
Tcl_AddErrorInfo(interp,
|
Tcl_AddErrorInfo(interp,
|
"\n (reading increment)");
|
"\n (reading increment)");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
value += increment;
|
value += increment;
|
}
|
}
|
TclFormatInt(newString, value);
|
TclFormatInt(newString, value);
|
result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
|
result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
|
if (result == NULL) {
|
if (result == NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Copy the result since the variable's value might change.
|
* Copy the result since the variable's value might change.
|
*/
|
*/
|
|
|
Tcl_SetResult(interp, result, TCL_VOLATILE);
|
Tcl_SetResult(interp, result, TCL_VOLATILE);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_InfoObjCmd --
|
* Tcl_InfoObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "info" Tcl command.
|
* This procedure is invoked to process the "info" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_InfoObjCmd(clientData, interp, objc, objv)
|
Tcl_InfoObjCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Arbitrary value passed to the command. */
|
ClientData clientData; /* Arbitrary value passed to the command. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
static char *subCmds[] = {
|
static char *subCmds[] = {
|
"args", "body", "cmdcount", "commands",
|
"args", "body", "cmdcount", "commands",
|
"complete", "default", "exists", "globals",
|
"complete", "default", "exists", "globals",
|
"hostname", "level", "library", "loaded",
|
"hostname", "level", "library", "loaded",
|
"locals", "nameofexecutable", "patchlevel", "procs",
|
"locals", "nameofexecutable", "patchlevel", "procs",
|
"script", "sharedlibextension", "tclversion", "vars",
|
"script", "sharedlibextension", "tclversion", "vars",
|
(char *) NULL};
|
(char *) NULL};
|
enum ISubCmdIdx {
|
enum ISubCmdIdx {
|
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
|
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
|
ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
|
ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
|
IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
|
IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
|
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
|
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
|
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
|
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
|
} index;
|
} index;
|
int result;
|
int result;
|
|
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
|
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
|
(int *) &index);
|
(int *) &index);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
switch (index) {
|
switch (index) {
|
case IArgsIdx:
|
case IArgsIdx:
|
result = InfoArgsCmd(clientData, interp, objc, objv);
|
result = InfoArgsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IBodyIdx:
|
case IBodyIdx:
|
result = InfoBodyCmd(clientData, interp, objc, objv);
|
result = InfoBodyCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ICmdCountIdx:
|
case ICmdCountIdx:
|
result = InfoCmdCountCmd(clientData, interp, objc, objv);
|
result = InfoCmdCountCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ICommandsIdx:
|
case ICommandsIdx:
|
result = InfoCommandsCmd(clientData, interp, objc, objv);
|
result = InfoCommandsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ICompleteIdx:
|
case ICompleteIdx:
|
result = InfoCompleteCmd(clientData, interp, objc, objv);
|
result = InfoCompleteCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IDefaultIdx:
|
case IDefaultIdx:
|
result = InfoDefaultCmd(clientData, interp, objc, objv);
|
result = InfoDefaultCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IExistsIdx:
|
case IExistsIdx:
|
result = InfoExistsCmd(clientData, interp, objc, objv);
|
result = InfoExistsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IGlobalsIdx:
|
case IGlobalsIdx:
|
result = InfoGlobalsCmd(clientData, interp, objc, objv);
|
result = InfoGlobalsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IHostnameIdx:
|
case IHostnameIdx:
|
result = InfoHostnameCmd(clientData, interp, objc, objv);
|
result = InfoHostnameCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ILevelIdx:
|
case ILevelIdx:
|
result = InfoLevelCmd(clientData, interp, objc, objv);
|
result = InfoLevelCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ILibraryIdx:
|
case ILibraryIdx:
|
result = InfoLibraryCmd(clientData, interp, objc, objv);
|
result = InfoLibraryCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ILoadedIdx:
|
case ILoadedIdx:
|
result = InfoLoadedCmd(clientData, interp, objc, objv);
|
result = InfoLoadedCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ILocalsIdx:
|
case ILocalsIdx:
|
result = InfoLocalsCmd(clientData, interp, objc, objv);
|
result = InfoLocalsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case INameOfExecutableIdx:
|
case INameOfExecutableIdx:
|
result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
|
result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IPatchLevelIdx:
|
case IPatchLevelIdx:
|
result = InfoPatchLevelCmd(clientData, interp, objc, objv);
|
result = InfoPatchLevelCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IProcsIdx:
|
case IProcsIdx:
|
result = InfoProcsCmd(clientData, interp, objc, objv);
|
result = InfoProcsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IScriptIdx:
|
case IScriptIdx:
|
result = InfoScriptCmd(clientData, interp, objc, objv);
|
result = InfoScriptCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ISharedLibExtensionIdx:
|
case ISharedLibExtensionIdx:
|
result = InfoSharedlibCmd(clientData, interp, objc, objv);
|
result = InfoSharedlibCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case ITclVersionIdx:
|
case ITclVersionIdx:
|
result = InfoTclVersionCmd(clientData, interp, objc, objv);
|
result = InfoTclVersionCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
case IVarsIdx:
|
case IVarsIdx:
|
result = InfoVarsCmd(clientData, interp, objc, objv);
|
result = InfoVarsCmd(clientData, interp, objc, objv);
|
break;
|
break;
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoArgsCmd --
|
* InfoArgsCmd --
|
*
|
*
|
* Called to implement the "info args" command that returns the
|
* Called to implement the "info args" command that returns the
|
* argument list for a procedure. Handles the following syntax:
|
* argument list for a procedure. Handles the following syntax:
|
*
|
*
|
* info args procName
|
* info args procName
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoArgsCmd(dummy, interp, objc, objv)
|
InfoArgsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
char *name;
|
char *name;
|
Proc *procPtr;
|
Proc *procPtr;
|
CompiledLocal *localPtr;
|
CompiledLocal *localPtr;
|
Tcl_Obj *listObjPtr;
|
Tcl_Obj *listObjPtr;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "procname");
|
Tcl_WrongNumArgs(interp, 2, objv, "procname");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
procPtr = TclFindProc(iPtr, name);
|
procPtr = TclFindProc(iPtr, name);
|
if (procPtr == NULL) {
|
if (procPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" isn't a procedure", (char *) NULL);
|
"\"", name, "\" isn't a procedure", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Build a return list containing the arguments.
|
* Build a return list containing the arguments.
|
*/
|
*/
|
|
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
|
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
|
localPtr = localPtr->nextPtr) {
|
localPtr = localPtr->nextPtr) {
|
if (TclIsVarArgument(localPtr)) {
|
if (TclIsVarArgument(localPtr)) {
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_ListObjAppendElement(interp, listObjPtr,
|
Tcl_NewStringObj(localPtr->name, -1));
|
Tcl_NewStringObj(localPtr->name, -1));
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, listObjPtr);
|
Tcl_SetObjResult(interp, listObjPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoBodyCmd --
|
* InfoBodyCmd --
|
*
|
*
|
* Called to implement the "info body" command that returns the body
|
* Called to implement the "info body" command that returns the body
|
* for a procedure. Handles the following syntax:
|
* for a procedure. Handles the following syntax:
|
*
|
*
|
* info body procName
|
* info body procName
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoBodyCmd(dummy, interp, objc, objv)
|
InfoBodyCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
register Interp *iPtr = (Interp *) interp;
|
register Interp *iPtr = (Interp *) interp;
|
char *name;
|
char *name;
|
Proc *procPtr;
|
Proc *procPtr;
|
Tcl_Obj *bodyPtr, *resultPtr;
|
Tcl_Obj *bodyPtr, *resultPtr;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "procname");
|
Tcl_WrongNumArgs(interp, 2, objv, "procname");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
procPtr = TclFindProc(iPtr, name);
|
procPtr = TclFindProc(iPtr, name);
|
if (procPtr == NULL) {
|
if (procPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" isn't a procedure", (char *) NULL);
|
"\"", name, "\" isn't a procedure", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* we need to check if the body from this procedure had been generated
|
* we need to check if the body from this procedure had been generated
|
* from a precompiled body. If that is the case, then the bodyPtr's
|
* from a precompiled body. If that is the case, then the bodyPtr's
|
* string representation is bogus, since sources are not available.
|
* string representation is bogus, since sources are not available.
|
* In order to make sure that later manipulations of the object do not
|
* In order to make sure that later manipulations of the object do not
|
* invalidate the internal representation, we make a copy of the string
|
* invalidate the internal representation, we make a copy of the string
|
* representation and return that one, instead.
|
* representation and return that one, instead.
|
*/
|
*/
|
|
|
bodyPtr = procPtr->bodyPtr;
|
bodyPtr = procPtr->bodyPtr;
|
resultPtr = bodyPtr;
|
resultPtr = bodyPtr;
|
if (bodyPtr->typePtr == &tclByteCodeType) {
|
if (bodyPtr->typePtr == &tclByteCodeType) {
|
ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
|
ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
|
|
|
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
|
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
|
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
|
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
|
}
|
}
|
}
|
}
|
|
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoCmdCountCmd --
|
* InfoCmdCountCmd --
|
*
|
*
|
* Called to implement the "info cmdcount" command that returns the
|
* Called to implement the "info cmdcount" command that returns the
|
* number of commands that have been executed. Handles the following
|
* number of commands that have been executed. Handles the following
|
* syntax:
|
* syntax:
|
*
|
*
|
* info cmdcount
|
* info cmdcount
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoCmdCountCmd(dummy, interp, objc, objv)
|
InfoCmdCountCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoCommandsCmd --
|
* InfoCommandsCmd --
|
*
|
*
|
* Called to implement the "info commands" command that returns the
|
* Called to implement the "info commands" command that returns the
|
* list of commands in the interpreter that match an optional pattern.
|
* list of commands in the interpreter that match an optional pattern.
|
* The pattern, if any, consists of an optional sequence of namespace
|
* The pattern, if any, consists of an optional sequence of namespace
|
* names separated by "::" qualifiers, which is followed by a
|
* names separated by "::" qualifiers, which is followed by a
|
* glob-style pattern that restricts which commands are returned.
|
* glob-style pattern that restricts which commands are returned.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* info commands ?pattern?
|
* info commands ?pattern?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoCommandsCmd(dummy, interp, objc, objv)
|
InfoCommandsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *cmdName, *pattern, *simplePattern;
|
char *cmdName, *pattern, *simplePattern;
|
register Tcl_HashEntry *entryPtr;
|
register Tcl_HashEntry *entryPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
Namespace *nsPtr;
|
Namespace *nsPtr;
|
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
|
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
|
Tcl_Obj *listPtr, *elemObjPtr;
|
Tcl_Obj *listPtr, *elemObjPtr;
|
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
|
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
int result;
|
int result;
|
|
|
/*
|
/*
|
* Get the pattern and find the "effective namespace" in which to
|
* Get the pattern and find the "effective namespace" in which to
|
* list commands.
|
* list commands.
|
*/
|
*/
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
simplePattern = NULL;
|
simplePattern = NULL;
|
nsPtr = currNsPtr;
|
nsPtr = currNsPtr;
|
specificNsInPattern = 0;
|
specificNsInPattern = 0;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
/*
|
/*
|
* From the pattern, get the effective namespace and the simple
|
* From the pattern, get the effective namespace and the simple
|
* pattern (no namespace qualifiers or ::'s) at the end. If an
|
* pattern (no namespace qualifiers or ::'s) at the end. If an
|
* error was found while parsing the pattern, return it. Otherwise,
|
* error was found while parsing the pattern, return it. Otherwise,
|
* if the namespace wasn't found, just leave nsPtr NULL: we will
|
* if the namespace wasn't found, just leave nsPtr NULL: we will
|
* return an empty list since no commands there can be found.
|
* return an empty list since no commands there can be found.
|
*/
|
*/
|
|
|
Namespace *dummy1NsPtr, *dummy2NsPtr;
|
Namespace *dummy1NsPtr, *dummy2NsPtr;
|
|
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
result = TclGetNamespaceForQualName(interp, pattern,
|
result = TclGetNamespaceForQualName(interp, pattern,
|
(Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
|
(Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
|
&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
|
&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
|
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
|
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
|
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
|
}
|
}
|
} else {
|
} else {
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through the effective namespace's command table and create a
|
* Scan through the effective namespace's command table and create a
|
* list with all commands that match the pattern. If a specific
|
* list with all commands that match the pattern. If a specific
|
* namespace was requested in the pattern, qualify the command names
|
* namespace was requested in the pattern, qualify the command names
|
* with the namespace name.
|
* with the namespace name.
|
*/
|
*/
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
|
|
if (nsPtr != NULL) {
|
if (nsPtr != NULL) {
|
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
|
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
|
while (entryPtr != NULL) {
|
while (entryPtr != NULL) {
|
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
|
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
|
if ((simplePattern == NULL)
|
if ((simplePattern == NULL)
|
|| Tcl_StringMatch(cmdName, simplePattern)) {
|
|| Tcl_StringMatch(cmdName, simplePattern)) {
|
if (specificNsInPattern) {
|
if (specificNsInPattern) {
|
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
|
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
|
elemObjPtr = Tcl_NewObj();
|
elemObjPtr = Tcl_NewObj();
|
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
|
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
|
} else {
|
} else {
|
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
|
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
|
}
|
}
|
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
|
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
|
}
|
}
|
entryPtr = Tcl_NextHashEntry(&search);
|
entryPtr = Tcl_NextHashEntry(&search);
|
}
|
}
|
|
|
/*
|
/*
|
* If the effective namespace isn't the global :: namespace, and a
|
* If the effective namespace isn't the global :: namespace, and a
|
* specific namespace wasn't requested in the pattern, then add in
|
* specific namespace wasn't requested in the pattern, then add in
|
* all global :: commands that match the simple pattern. Of course,
|
* all global :: commands that match the simple pattern. Of course,
|
* we add in only those commands that aren't hidden by a command in
|
* we add in only those commands that aren't hidden by a command in
|
* the effective namespace.
|
* the effective namespace.
|
*/
|
*/
|
|
|
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
|
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
|
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
|
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
|
while (entryPtr != NULL) {
|
while (entryPtr != NULL) {
|
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
|
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
|
if ((simplePattern == NULL)
|
if ((simplePattern == NULL)
|
|| Tcl_StringMatch(cmdName, simplePattern)) {
|
|| Tcl_StringMatch(cmdName, simplePattern)) {
|
if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
|
if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_NewStringObj(cmdName, -1));
|
Tcl_NewStringObj(cmdName, -1));
|
}
|
}
|
}
|
}
|
entryPtr = Tcl_NextHashEntry(&search);
|
entryPtr = Tcl_NextHashEntry(&search);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoCompleteCmd --
|
* InfoCompleteCmd --
|
*
|
*
|
* Called to implement the "info complete" command that determines
|
* Called to implement the "info complete" command that determines
|
* whether a string is a complete Tcl command. Handles the following
|
* whether a string is a complete Tcl command. Handles the following
|
* syntax:
|
* syntax:
|
*
|
*
|
* info complete command
|
* info complete command
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoCompleteCmd(dummy, interp, objc, objv)
|
InfoCompleteCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "command");
|
Tcl_WrongNumArgs(interp, 2, objv, "command");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (TclObjCommandComplete(objv[2])) {
|
if (TclObjCommandComplete(objv[2])) {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
} else {
|
} else {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoDefaultCmd --
|
* InfoDefaultCmd --
|
*
|
*
|
* Called to implement the "info default" command that returns the
|
* Called to implement the "info default" command that returns the
|
* default value for a procedure argument. Handles the following
|
* default value for a procedure argument. Handles the following
|
* syntax:
|
* syntax:
|
*
|
*
|
* info default procName arg varName
|
* info default procName arg varName
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoDefaultCmd(dummy, interp, objc, objv)
|
InfoDefaultCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
char *procName, *argName, *varName;
|
char *procName, *argName, *varName;
|
Proc *procPtr;
|
Proc *procPtr;
|
CompiledLocal *localPtr;
|
CompiledLocal *localPtr;
|
Tcl_Obj *valueObjPtr;
|
Tcl_Obj *valueObjPtr;
|
|
|
if (objc != 5) {
|
if (objc != 5) {
|
Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
|
Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
|
argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
|
|
|
procPtr = TclFindProc(iPtr, procName);
|
procPtr = TclFindProc(iPtr, procName);
|
if (procPtr == NULL) {
|
if (procPtr == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", procName, "\" isn't a procedure", (char *) NULL);
|
"\"", procName, "\" isn't a procedure", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
|
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
|
localPtr = localPtr->nextPtr) {
|
localPtr = localPtr->nextPtr) {
|
if (TclIsVarArgument(localPtr)
|
if (TclIsVarArgument(localPtr)
|
&& (strcmp(argName, localPtr->name) == 0)) {
|
&& (strcmp(argName, localPtr->name) == 0)) {
|
if (localPtr->defValuePtr != NULL) {
|
if (localPtr->defValuePtr != NULL) {
|
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
|
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
|
localPtr->defValuePtr, 0);
|
localPtr->defValuePtr, 0);
|
if (valueObjPtr == NULL) {
|
if (valueObjPtr == NULL) {
|
defStoreError:
|
defStoreError:
|
varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
|
varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"couldn't store default value in variable \"",
|
"couldn't store default value in variable \"",
|
varName, "\"", (char *) NULL);
|
varName, "\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
} else {
|
} else {
|
Tcl_Obj *nullObjPtr = Tcl_NewObj();
|
Tcl_Obj *nullObjPtr = Tcl_NewObj();
|
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
|
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
|
nullObjPtr, 0);
|
nullObjPtr, 0);
|
if (valueObjPtr == NULL) {
|
if (valueObjPtr == NULL) {
|
Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
|
Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
|
goto defStoreError;
|
goto defStoreError;
|
}
|
}
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
}
|
}
|
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"procedure \"", procName, "\" doesn't have an argument \"",
|
"procedure \"", procName, "\" doesn't have an argument \"",
|
argName, "\"", (char *) NULL);
|
argName, "\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoExistsCmd --
|
* InfoExistsCmd --
|
*
|
*
|
* Called to implement the "info exists" command that determines
|
* Called to implement the "info exists" command that determines
|
* whether a variable exists. Handles the following syntax:
|
* whether a variable exists. Handles the following syntax:
|
*
|
*
|
* info exists varName
|
* info exists varName
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoExistsCmd(dummy, interp, objc, objv)
|
InfoExistsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *varName;
|
char *varName;
|
Var *varPtr, *arrayPtr;
|
Var *varPtr, *arrayPtr;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 2, objv, "varName");
|
Tcl_WrongNumArgs(interp, 2, objv, "varName");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
varPtr = TclLookupVar(interp, varName, (char *) NULL,
|
varPtr = TclLookupVar(interp, varName, (char *) NULL,
|
TCL_PARSE_PART1, "access",
|
TCL_PARSE_PART1, "access",
|
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
|
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
|
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
|
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
|
} else {
|
} else {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoGlobalsCmd --
|
* InfoGlobalsCmd --
|
*
|
*
|
* Called to implement the "info globals" command that returns the list
|
* Called to implement the "info globals" command that returns the list
|
* of global variables matching an optional pattern. Handles the
|
* of global variables matching an optional pattern. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* info globals ?pattern?
|
* info globals ?pattern?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoGlobalsCmd(dummy, interp, objc, objv)
|
InfoGlobalsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *varName, *pattern;
|
char *varName, *pattern;
|
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|
register Tcl_HashEntry *entryPtr;
|
register Tcl_HashEntry *entryPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
Var *varPtr;
|
Var *varPtr;
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
pattern = NULL;
|
pattern = NULL;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
} else {
|
} else {
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through the global :: namespace's variable table and create a
|
* Scan through the global :: namespace's variable table and create a
|
* list of all global variables that match the pattern.
|
* list of all global variables that match the pattern.
|
*/
|
*/
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
|
for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
|
entryPtr != NULL;
|
entryPtr != NULL;
|
entryPtr = Tcl_NextHashEntry(&search)) {
|
entryPtr = Tcl_NextHashEntry(&search)) {
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
if (TclIsVarUndefined(varPtr)) {
|
if (TclIsVarUndefined(varPtr)) {
|
continue;
|
continue;
|
}
|
}
|
varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
|
varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
|
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
|
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_NewStringObj(varName, -1));
|
Tcl_NewStringObj(varName, -1));
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoHostnameCmd --
|
* InfoHostnameCmd --
|
*
|
*
|
* Called to implement the "info hostname" command that returns the
|
* Called to implement the "info hostname" command that returns the
|
* host name. Handles the following syntax:
|
* host name. Handles the following syntax:
|
*
|
*
|
* info hostname
|
* info hostname
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoHostnameCmd(dummy, interp, objc, objv)
|
InfoHostnameCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *name;
|
char *name;
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetHostName();
|
name = Tcl_GetHostName();
|
if (name) {
|
if (name) {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
|
return TCL_OK;
|
return TCL_OK;
|
} else {
|
} else {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
"unable to determine name of host", -1);
|
"unable to determine name of host", -1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoLevelCmd --
|
* InfoLevelCmd --
|
*
|
*
|
* Called to implement the "info level" command that returns
|
* Called to implement the "info level" command that returns
|
* information about the call stack. Handles the following syntax:
|
* information about the call stack. Handles the following syntax:
|
*
|
*
|
* info level ?number?
|
* info level ?number?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoLevelCmd(dummy, interp, objc, objv)
|
InfoLevelCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
int level;
|
int level;
|
CallFrame *framePtr;
|
CallFrame *framePtr;
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
|
|
if (objc == 2) { /* just "info level" */
|
if (objc == 2) { /* just "info level" */
|
if (iPtr->varFramePtr == NULL) {
|
if (iPtr->varFramePtr == NULL) {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
|
} else {
|
} else {
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
|
if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (level <= 0) {
|
if (level <= 0) {
|
if (iPtr->varFramePtr == NULL) {
|
if (iPtr->varFramePtr == NULL) {
|
levelError:
|
levelError:
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad level \"",
|
"bad level \"",
|
Tcl_GetStringFromObj(objv[2], (int *) NULL),
|
Tcl_GetStringFromObj(objv[2], (int *) NULL),
|
"\"", (char *) NULL);
|
"\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
level += iPtr->varFramePtr->level;
|
level += iPtr->varFramePtr->level;
|
}
|
}
|
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
|
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
|
framePtr = framePtr->callerVarPtr) {
|
framePtr = framePtr->callerVarPtr) {
|
if (framePtr->level == level) {
|
if (framePtr->level == level) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
if (framePtr == NULL) {
|
if (framePtr == NULL) {
|
goto levelError;
|
goto levelError;
|
}
|
}
|
|
|
listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
|
listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoLibraryCmd --
|
* InfoLibraryCmd --
|
*
|
*
|
* Called to implement the "info library" command that returns the
|
* Called to implement the "info library" command that returns the
|
* library directory for the Tcl installation. Handles the following
|
* library directory for the Tcl installation. Handles the following
|
* syntax:
|
* syntax:
|
*
|
*
|
* info library
|
* info library
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoLibraryCmd(dummy, interp, objc, objv)
|
InfoLibraryCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *libDirName;
|
char *libDirName;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
|
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
|
if (libDirName != NULL) {
|
if (libDirName != NULL) {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
Tcl_SetStringObj(Tcl_GetObjResult(interp),
|
"no library has been specified for Tcl", -1);
|
"no library has been specified for Tcl", -1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoLoadedCmd --
|
* InfoLoadedCmd --
|
*
|
*
|
* Called to implement the "info loaded" command that returns the
|
* Called to implement the "info loaded" command that returns the
|
* packages that have been loaded into an interpreter. Handles the
|
* packages that have been loaded into an interpreter. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* info loaded ?interp?
|
* info loaded ?interp?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoLoadedCmd(dummy, interp, objc, objv)
|
InfoLoadedCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *interpName;
|
char *interpName;
|
int result;
|
int result;
|
|
|
if ((objc != 2) && (objc != 3)) {
|
if ((objc != 2) && (objc != 3)) {
|
Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (objc == 2) { /* get loaded pkgs in all interpreters */
|
if (objc == 2) { /* get loaded pkgs in all interpreters */
|
interpName = NULL;
|
interpName = NULL;
|
} else { /* get pkgs just in specified interp */
|
} else { /* get pkgs just in specified interp */
|
interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
}
|
}
|
result = TclGetLoadedPackages(interp, interpName);
|
result = TclGetLoadedPackages(interp, interpName);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoLocalsCmd --
|
* InfoLocalsCmd --
|
*
|
*
|
* Called to implement the "info locals" command to return a list of
|
* Called to implement the "info locals" command to return a list of
|
* local variables that match an optional pattern. Handles the
|
* local variables that match an optional pattern. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* info locals ?pattern?
|
* info locals ?pattern?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoLocalsCmd(dummy, interp, objc, objv)
|
InfoLocalsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
char *pattern;
|
char *pattern;
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
pattern = NULL;
|
pattern = NULL;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
} else {
|
} else {
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
|
if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* Return a list containing names of first the compiled locals (i.e. the
|
* Return a list containing names of first the compiled locals (i.e. the
|
* ones stored in the call frame), then the variables in the local hash
|
* ones stored in the call frame), then the variables in the local hash
|
* table (if one exists).
|
* table (if one exists).
|
*/
|
*/
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
AppendLocals(interp, listPtr, pattern, 0);
|
AppendLocals(interp, listPtr, pattern, 0);
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* AppendLocals --
|
* AppendLocals --
|
*
|
*
|
* Append the local variables for the current frame to the
|
* Append the local variables for the current frame to the
|
* specified list object.
|
* specified list object.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
AppendLocals(interp, listPtr, pattern, includeLinks)
|
AppendLocals(interp, listPtr, pattern, includeLinks)
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Obj *listPtr; /* List object to append names to. */
|
Tcl_Obj *listPtr; /* List object to append names to. */
|
char *pattern; /* Pattern to match against. */
|
char *pattern; /* Pattern to match against. */
|
int includeLinks; /* 1 if upvars should be included, else 0. */
|
int includeLinks; /* 1 if upvars should be included, else 0. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
CompiledLocal *localPtr;
|
CompiledLocal *localPtr;
|
Var *varPtr;
|
Var *varPtr;
|
int i, localVarCt;
|
int i, localVarCt;
|
char *varName;
|
char *varName;
|
Tcl_HashTable *localVarTablePtr;
|
Tcl_HashTable *localVarTablePtr;
|
register Tcl_HashEntry *entryPtr;
|
register Tcl_HashEntry *entryPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
|
|
localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
|
localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
|
localVarCt = iPtr->varFramePtr->numCompiledLocals;
|
localVarCt = iPtr->varFramePtr->numCompiledLocals;
|
varPtr = iPtr->varFramePtr->compiledLocals;
|
varPtr = iPtr->varFramePtr->compiledLocals;
|
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
|
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
|
|
|
for (i = 0; i < localVarCt; i++) {
|
for (i = 0; i < localVarCt; i++) {
|
/*
|
/*
|
* Skip nameless (temporary) variables and undefined variables
|
* Skip nameless (temporary) variables and undefined variables
|
*/
|
*/
|
|
|
if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
|
if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
|
varName = varPtr->name;
|
varName = varPtr->name;
|
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
|
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_NewStringObj(varName, -1));
|
Tcl_NewStringObj(varName, -1));
|
}
|
}
|
}
|
}
|
varPtr++;
|
varPtr++;
|
localPtr = localPtr->nextPtr;
|
localPtr = localPtr->nextPtr;
|
}
|
}
|
|
|
if (localVarTablePtr != NULL) {
|
if (localVarTablePtr != NULL) {
|
for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
|
for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
|
entryPtr != NULL;
|
entryPtr != NULL;
|
entryPtr = Tcl_NextHashEntry(&search)) {
|
entryPtr = Tcl_NextHashEntry(&search)) {
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
if (!TclIsVarUndefined(varPtr)
|
if (!TclIsVarUndefined(varPtr)
|
&& (includeLinks || !TclIsVarLink(varPtr))) {
|
&& (includeLinks || !TclIsVarLink(varPtr))) {
|
varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
|
varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
|
if ((pattern == NULL)
|
if ((pattern == NULL)
|
|| Tcl_StringMatch(varName, pattern)) {
|
|| Tcl_StringMatch(varName, pattern)) {
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_NewStringObj(varName, -1));
|
Tcl_NewStringObj(varName, -1));
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoNameOfExecutableCmd --
|
* InfoNameOfExecutableCmd --
|
*
|
*
|
* Called to implement the "info nameofexecutable" command that returns
|
* Called to implement the "info nameofexecutable" command that returns
|
* the name of the binary file running this application. Handles the
|
* the name of the binary file running this application. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* info nameofexecutable
|
* info nameofexecutable
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoNameOfExecutableCmd(dummy, interp, objc, objv)
|
InfoNameOfExecutableCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
CONST char *nameOfExecutable;
|
CONST char *nameOfExecutable;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
nameOfExecutable = Tcl_GetNameOfExecutable();
|
nameOfExecutable = Tcl_GetNameOfExecutable();
|
|
|
if (nameOfExecutable != NULL) {
|
if (nameOfExecutable != NULL) {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoPatchLevelCmd --
|
* InfoPatchLevelCmd --
|
*
|
*
|
* Called to implement the "info patchlevel" command that returns the
|
* Called to implement the "info patchlevel" command that returns the
|
* default value for an argument to a procedure. Handles the following
|
* default value for an argument to a procedure. Handles the following
|
* syntax:
|
* syntax:
|
*
|
*
|
* info patchlevel
|
* info patchlevel
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoPatchLevelCmd(dummy, interp, objc, objv)
|
InfoPatchLevelCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *patchlevel;
|
char *patchlevel;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
|
patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
|
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
|
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
|
if (patchlevel != NULL) {
|
if (patchlevel != NULL) {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoProcsCmd --
|
* InfoProcsCmd --
|
*
|
*
|
* Called to implement the "info procs" command that returns the
|
* Called to implement the "info procs" command that returns the
|
* procedures in the current namespace that match an optional pattern.
|
* procedures in the current namespace that match an optional pattern.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* info procs ?pattern?
|
* info procs ?pattern?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoProcsCmd(dummy, interp, objc, objv)
|
InfoProcsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *cmdName, *pattern;
|
char *cmdName, *pattern;
|
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
|
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
|
register Tcl_HashEntry *entryPtr;
|
register Tcl_HashEntry *entryPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
pattern = NULL;
|
pattern = NULL;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
} else {
|
} else {
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through the current namespace's command table and return a list
|
* Scan through the current namespace's command table and return a list
|
* of all procs that match the pattern.
|
* of all procs that match the pattern.
|
*/
|
*/
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
|
for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
|
entryPtr != NULL;
|
entryPtr != NULL;
|
entryPtr = Tcl_NextHashEntry(&search)) {
|
entryPtr = Tcl_NextHashEntry(&search)) {
|
cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
|
cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
|
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
|
if (TclIsProc(cmdPtr)) {
|
if (TclIsProc(cmdPtr)) {
|
if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
|
if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_NewStringObj(cmdName, -1));
|
Tcl_NewStringObj(cmdName, -1));
|
}
|
}
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoScriptCmd --
|
* InfoScriptCmd --
|
*
|
*
|
* Called to implement the "info script" command that returns the
|
* Called to implement the "info script" command that returns the
|
* script file that is currently being evaluated. Handles the
|
* script file that is currently being evaluated. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* info script
|
* info script
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoScriptCmd(dummy, interp, objc, objv)
|
InfoScriptCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (iPtr->scriptFile != NULL) {
|
if (iPtr->scriptFile != NULL) {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoSharedlibCmd --
|
* InfoSharedlibCmd --
|
*
|
*
|
* Called to implement the "info sharedlibextension" command that
|
* Called to implement the "info sharedlibextension" command that
|
* returns the file extension used for shared libraries. Handles the
|
* returns the file extension used for shared libraries. Handles the
|
* following syntax:
|
* following syntax:
|
*
|
*
|
* info sharedlibextension
|
* info sharedlibextension
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoSharedlibCmd(dummy, interp, objc, objv)
|
InfoSharedlibCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
#ifdef TCL_SHLIB_EXT
|
#ifdef TCL_SHLIB_EXT
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
|
#endif
|
#endif
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoTclVersionCmd --
|
* InfoTclVersionCmd --
|
*
|
*
|
* Called to implement the "info tclversion" command that returns the
|
* Called to implement the "info tclversion" command that returns the
|
* version number for this Tcl library. Handles the following syntax:
|
* version number for this Tcl library. Handles the following syntax:
|
*
|
*
|
* info tclversion
|
* info tclversion
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoTclVersionCmd(dummy, interp, objc, objv)
|
InfoTclVersionCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
char *version;
|
char *version;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
Tcl_WrongNumArgs(interp, 2, objv, NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
version = Tcl_GetVar(interp, "tcl_version",
|
version = Tcl_GetVar(interp, "tcl_version",
|
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
|
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
|
if (version != NULL) {
|
if (version != NULL) {
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
|
Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* InfoVarsCmd --
|
* InfoVarsCmd --
|
*
|
*
|
* Called to implement the "info vars" command that returns the
|
* Called to implement the "info vars" command that returns the
|
* list of variables in the interpreter that match an optional pattern.
|
* list of variables in the interpreter that match an optional pattern.
|
* The pattern, if any, consists of an optional sequence of namespace
|
* The pattern, if any, consists of an optional sequence of namespace
|
* names separated by "::" qualifiers, which is followed by a
|
* names separated by "::" qualifiers, which is followed by a
|
* glob-style pattern that restricts which variables are returned.
|
* glob-style pattern that restricts which variables are returned.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* info vars ?pattern?
|
* info vars ?pattern?
|
*
|
*
|
* Results:
|
* Results:
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
* Returns TCL_OK is successful and TCL_ERROR is there is an error.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Returns a result in the interpreter's result object. If there is
|
* Returns a result in the interpreter's result object. If there is
|
* an error, the result is an error message.
|
* an error, the result is an error message.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
InfoVarsCmd(dummy, interp, objc, objv)
|
InfoVarsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Interp *iPtr = (Interp *) interp;
|
Interp *iPtr = (Interp *) interp;
|
char *varName, *pattern, *simplePattern;
|
char *varName, *pattern, *simplePattern;
|
register Tcl_HashEntry *entryPtr;
|
register Tcl_HashEntry *entryPtr;
|
Tcl_HashSearch search;
|
Tcl_HashSearch search;
|
Var *varPtr;
|
Var *varPtr;
|
Namespace *nsPtr;
|
Namespace *nsPtr;
|
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
|
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
|
Tcl_Obj *listPtr, *elemObjPtr;
|
Tcl_Obj *listPtr, *elemObjPtr;
|
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
|
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
|
int result;
|
int result;
|
|
|
/*
|
/*
|
* Get the pattern and find the "effective namespace" in which to
|
* Get the pattern and find the "effective namespace" in which to
|
* list variables. We only use this effective namespace if there's
|
* list variables. We only use this effective namespace if there's
|
* no active Tcl procedure frame.
|
* no active Tcl procedure frame.
|
*/
|
*/
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
simplePattern = NULL;
|
simplePattern = NULL;
|
nsPtr = currNsPtr;
|
nsPtr = currNsPtr;
|
specificNsInPattern = 0;
|
specificNsInPattern = 0;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
/*
|
/*
|
* From the pattern, get the effective namespace and the simple
|
* From the pattern, get the effective namespace and the simple
|
* pattern (no namespace qualifiers or ::'s) at the end. If an
|
* pattern (no namespace qualifiers or ::'s) at the end. If an
|
* error was found while parsing the pattern, return it. Otherwise,
|
* error was found while parsing the pattern, return it. Otherwise,
|
* if the namespace wasn't found, just leave nsPtr NULL: we will
|
* if the namespace wasn't found, just leave nsPtr NULL: we will
|
* return an empty list since no variables there can be found.
|
* return an empty list since no variables there can be found.
|
*/
|
*/
|
|
|
Namespace *dummy1NsPtr, *dummy2NsPtr;
|
Namespace *dummy1NsPtr, *dummy2NsPtr;
|
|
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
|
result = TclGetNamespaceForQualName(interp, pattern,
|
result = TclGetNamespaceForQualName(interp, pattern,
|
(Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
|
(Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
|
&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
|
&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
|
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
|
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
|
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
|
}
|
}
|
} else {
|
} else {
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If the namespace specified in the pattern wasn't found, just return.
|
* If the namespace specified in the pattern wasn't found, just return.
|
*/
|
*/
|
|
|
if (nsPtr == NULL) {
|
if (nsPtr == NULL) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
|
|
|
if ((iPtr->varFramePtr == NULL)
|
if ((iPtr->varFramePtr == NULL)
|
|| !iPtr->varFramePtr->isProcCallFrame
|
|| !iPtr->varFramePtr->isProcCallFrame
|
|| specificNsInPattern) {
|
|| specificNsInPattern) {
|
/*
|
/*
|
* There is no frame pointer, the frame pointer was pushed only
|
* There is no frame pointer, the frame pointer was pushed only
|
* to activate a namespace, or we are in a procedure call frame
|
* to activate a namespace, or we are in a procedure call frame
|
* but a specific namespace was specified. Create a list containing
|
* but a specific namespace was specified. Create a list containing
|
* only the variables in the effective namespace's variable table.
|
* only the variables in the effective namespace's variable table.
|
*/
|
*/
|
|
|
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
|
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
|
while (entryPtr != NULL) {
|
while (entryPtr != NULL) {
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
if (!TclIsVarUndefined(varPtr)
|
if (!TclIsVarUndefined(varPtr)
|
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
|
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
|
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
|
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
|
if ((simplePattern == NULL)
|
if ((simplePattern == NULL)
|
|| Tcl_StringMatch(varName, simplePattern)) {
|
|| Tcl_StringMatch(varName, simplePattern)) {
|
if (specificNsInPattern) {
|
if (specificNsInPattern) {
|
elemObjPtr = Tcl_NewObj();
|
elemObjPtr = Tcl_NewObj();
|
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
|
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
|
elemObjPtr);
|
elemObjPtr);
|
} else {
|
} else {
|
elemObjPtr = Tcl_NewStringObj(varName, -1);
|
elemObjPtr = Tcl_NewStringObj(varName, -1);
|
}
|
}
|
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
|
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
|
}
|
}
|
}
|
}
|
entryPtr = Tcl_NextHashEntry(&search);
|
entryPtr = Tcl_NextHashEntry(&search);
|
}
|
}
|
|
|
/*
|
/*
|
* If the effective namespace isn't the global :: namespace, and a
|
* If the effective namespace isn't the global :: namespace, and a
|
* specific namespace wasn't requested in the pattern (i.e., the
|
* specific namespace wasn't requested in the pattern (i.e., the
|
* pattern only specifies variable names), then add in all global ::
|
* pattern only specifies variable names), then add in all global ::
|
* variables that match the simple pattern. Of course, add in only
|
* variables that match the simple pattern. Of course, add in only
|
* those variables that aren't hidden by a variable in the effective
|
* those variables that aren't hidden by a variable in the effective
|
* namespace.
|
* namespace.
|
*/
|
*/
|
|
|
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
|
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
|
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
|
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
|
while (entryPtr != NULL) {
|
while (entryPtr != NULL) {
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
|
if (!TclIsVarUndefined(varPtr)
|
if (!TclIsVarUndefined(varPtr)
|
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
|
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
|
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
|
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
|
entryPtr);
|
entryPtr);
|
if ((simplePattern == NULL)
|
if ((simplePattern == NULL)
|
|| Tcl_StringMatch(varName, simplePattern)) {
|
|| Tcl_StringMatch(varName, simplePattern)) {
|
if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
|
if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_ListObjAppendElement(interp, listPtr,
|
Tcl_NewStringObj(varName, -1));
|
Tcl_NewStringObj(varName, -1));
|
}
|
}
|
}
|
}
|
}
|
}
|
entryPtr = Tcl_NextHashEntry(&search);
|
entryPtr = Tcl_NextHashEntry(&search);
|
}
|
}
|
}
|
}
|
} else {
|
} else {
|
AppendLocals(interp, listPtr, simplePattern, 1);
|
AppendLocals(interp, listPtr, simplePattern, 1);
|
}
|
}
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_JoinObjCmd --
|
* Tcl_JoinObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "join" Tcl command.
|
* This procedure is invoked to process the "join" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_JoinObjCmd(dummy, interp, objc, objv)
|
Tcl_JoinObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* The argument objects. */
|
Tcl_Obj *CONST objv[]; /* The argument objects. */
|
{
|
{
|
char *joinString, *bytes;
|
char *joinString, *bytes;
|
int joinLength, listLen, length, i, result;
|
int joinLength, listLen, length, i, result;
|
Tcl_Obj **elemPtrs;
|
Tcl_Obj **elemPtrs;
|
Tcl_Obj *resObjPtr;
|
Tcl_Obj *resObjPtr;
|
|
|
if (objc == 2) {
|
if (objc == 2) {
|
joinString = " ";
|
joinString = " ";
|
joinLength = 1;
|
joinLength = 1;
|
} else if (objc == 3) {
|
} else if (objc == 3) {
|
joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
|
joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
|
} else {
|
} else {
|
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
|
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure the list argument is a list object and get its length and
|
* Make sure the list argument is a list object and get its length and
|
* a pointer to its array of element pointers.
|
* a pointer to its array of element pointers.
|
*/
|
*/
|
|
|
result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
|
result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Now concatenate strings to form the "joined" result. We append
|
* Now concatenate strings to form the "joined" result. We append
|
* directly into the interpreter's result object.
|
* directly into the interpreter's result object.
|
*/
|
*/
|
|
|
resObjPtr = Tcl_GetObjResult(interp);
|
resObjPtr = Tcl_GetObjResult(interp);
|
|
|
for (i = 0; i < listLen; i++) {
|
for (i = 0; i < listLen; i++) {
|
bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
|
bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
|
if (i > 0) {
|
if (i > 0) {
|
Tcl_AppendToObj(resObjPtr, joinString, joinLength);
|
Tcl_AppendToObj(resObjPtr, joinString, joinLength);
|
}
|
}
|
Tcl_AppendToObj(resObjPtr, bytes, length);
|
Tcl_AppendToObj(resObjPtr, bytes, length);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LindexObjCmd --
|
* Tcl_LindexObjCmd --
|
*
|
*
|
* This object-based procedure is invoked to process the "lindex" Tcl
|
* This object-based procedure is invoked to process the "lindex" Tcl
|
* command. See the user documentation for details on what it does.
|
* command. See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_LindexObjCmd(dummy, interp, objc, objv)
|
Tcl_LindexObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
Tcl_Obj **elemPtrs;
|
Tcl_Obj **elemPtrs;
|
int listLen, index, result;
|
int listLen, index, result;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 1, objv, "list index");
|
Tcl_WrongNumArgs(interp, 1, objv, "list index");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Convert the first argument to a list if necessary.
|
* Convert the first argument to a list if necessary.
|
*/
|
*/
|
|
|
listPtr = objv[1];
|
listPtr = objv[1];
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the index from objv[2].
|
* Get the index from objv[2].
|
*/
|
*/
|
|
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
|
&index);
|
&index);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
if ((index < 0) || (index >= listLen)) {
|
if ((index < 0) || (index >= listLen)) {
|
/*
|
/*
|
* The index is out of range: the result is an empty string object.
|
* The index is out of range: the result is an empty string object.
|
*/
|
*/
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure listPtr still refers to a list object. It might have been
|
* Make sure listPtr still refers to a list object. It might have been
|
* converted to an int above if the argument objects were shared.
|
* converted to an int above if the argument objects were shared.
|
*/
|
*/
|
|
|
if (listPtr->typePtr != &tclListType) {
|
if (listPtr->typePtr != &tclListType) {
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
|
&elemPtrs);
|
&elemPtrs);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Set the interpreter's object result to the index-th list element.
|
* Set the interpreter's object result to the index-th list element.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, elemPtrs[index]);
|
Tcl_SetObjResult(interp, elemPtrs[index]);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LinsertObjCmd --
|
* Tcl_LinsertObjCmd --
|
*
|
*
|
* This object-based procedure is invoked to process the "linsert" Tcl
|
* This object-based procedure is invoked to process the "linsert" Tcl
|
* command. See the user documentation for details on what it does.
|
* command. See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A new Tcl list object formed by inserting zero or more elements
|
* A new Tcl list object formed by inserting zero or more elements
|
* into a list.
|
* into a list.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_LinsertObjCmd(dummy, interp, objc, objv)
|
Tcl_LinsertObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
register int objc; /* Number of arguments. */
|
register int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Obj *listPtr, *resultPtr;
|
Tcl_Obj *listPtr, *resultPtr;
|
Tcl_ObjType *typePtr;
|
Tcl_ObjType *typePtr;
|
int index, isDuplicate, len, result;
|
int index, isDuplicate, len, result;
|
|
|
if (objc < 4) {
|
if (objc < 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the index first since, if a conversion to int is needed, it
|
* Get the index first since, if a conversion to int is needed, it
|
* will invalidate the list's internal representation.
|
* will invalidate the list's internal representation.
|
*/
|
*/
|
|
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
|
&index);
|
&index);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* If the list object is unshared we can modify it directly. Otherwise
|
* If the list object is unshared we can modify it directly. Otherwise
|
* we create a copy to modify: this is "copy on write". We create the
|
* we create a copy to modify: this is "copy on write". We create the
|
* duplicate directly in the interpreter's object result.
|
* duplicate directly in the interpreter's object result.
|
*/
|
*/
|
|
|
listPtr = objv[1];
|
listPtr = objv[1];
|
isDuplicate = 0;
|
isDuplicate = 0;
|
if (Tcl_IsShared(listPtr)) {
|
if (Tcl_IsShared(listPtr)) {
|
/*
|
/*
|
* The following code must reflect the logic in Tcl_DuplicateObj()
|
* The following code must reflect the logic in Tcl_DuplicateObj()
|
* except that it must duplicate the list object directly into the
|
* except that it must duplicate the list object directly into the
|
* interpreter's result.
|
* interpreter's result.
|
*/
|
*/
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
typePtr = listPtr->typePtr;
|
typePtr = listPtr->typePtr;
|
if (listPtr->bytes == NULL) {
|
if (listPtr->bytes == NULL) {
|
resultPtr->bytes = NULL;
|
resultPtr->bytes = NULL;
|
} else if (listPtr->bytes != tclEmptyStringRep) {
|
} else if (listPtr->bytes != tclEmptyStringRep) {
|
len = listPtr->length;
|
len = listPtr->length;
|
TclInitStringRep(resultPtr, listPtr->bytes, len);
|
TclInitStringRep(resultPtr, listPtr->bytes, len);
|
}
|
}
|
if (typePtr != NULL) {
|
if (typePtr != NULL) {
|
if (typePtr->dupIntRepProc == NULL) {
|
if (typePtr->dupIntRepProc == NULL) {
|
resultPtr->internalRep = listPtr->internalRep;
|
resultPtr->internalRep = listPtr->internalRep;
|
resultPtr->typePtr = typePtr;
|
resultPtr->typePtr = typePtr;
|
} else {
|
} else {
|
(*typePtr->dupIntRepProc)(listPtr, resultPtr);
|
(*typePtr->dupIntRepProc)(listPtr, resultPtr);
|
}
|
}
|
}
|
}
|
listPtr = resultPtr;
|
listPtr = resultPtr;
|
isDuplicate = 1;
|
isDuplicate = 1;
|
}
|
}
|
|
|
if ((objc == 4) && (index == INT_MAX)) {
|
if ((objc == 4) && (index == INT_MAX)) {
|
/*
|
/*
|
* Special case: insert one element at the end of the list.
|
* Special case: insert one element at the end of the list.
|
*/
|
*/
|
|
|
result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
|
result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
|
} else if (objc > 3) {
|
} else if (objc > 3) {
|
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
|
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
|
(objc-3), &(objv[3]));
|
(objc-3), &(objv[3]));
|
}
|
}
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Set the interpreter's object result.
|
* Set the interpreter's object result.
|
*/
|
*/
|
|
|
if (!isDuplicate) {
|
if (!isDuplicate) {
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ListObjCmd --
|
* Tcl_ListObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "list" Tcl command.
|
* This procedure is invoked to process the "list" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_ListObjCmd(dummy, interp, objc, objv)
|
Tcl_ListObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
register int objc; /* Number of arguments. */
|
register int objc; /* Number of arguments. */
|
register Tcl_Obj *CONST objv[]; /* The argument objects. */
|
register Tcl_Obj *CONST objv[]; /* The argument objects. */
|
{
|
{
|
/*
|
/*
|
* If there are no list elements, the result is an empty object.
|
* If there are no list elements, the result is an empty object.
|
* Otherwise modify the interpreter's result object to be a list object.
|
* Otherwise modify the interpreter's result object to be a list object.
|
*/
|
*/
|
|
|
if (objc > 1) {
|
if (objc > 1) {
|
Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
|
Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LlengthObjCmd --
|
* Tcl_LlengthObjCmd --
|
*
|
*
|
* This object-based procedure is invoked to process the "llength" Tcl
|
* This object-based procedure is invoked to process the "llength" Tcl
|
* command. See the user documentation for details on what it does.
|
* command. See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_LlengthObjCmd(dummy, interp, objc, objv)
|
Tcl_LlengthObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
register Tcl_Obj *CONST objv[]; /* Argument objects. */
|
register Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
int listLen, result;
|
int listLen, result;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "list");
|
Tcl_WrongNumArgs(interp, 1, objv, "list");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
result = Tcl_ListObjLength(interp, objv[1], &listLen);
|
result = Tcl_ListObjLength(interp, objv[1], &listLen);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Set the interpreter's object result to an integer object holding the
|
* Set the interpreter's object result to an integer object holding the
|
* length.
|
* length.
|
*/
|
*/
|
|
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LrangeObjCmd --
|
* Tcl_LrangeObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "lrange" Tcl command.
|
* This procedure is invoked to process the "lrange" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl object result.
|
* A standard Tcl object result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
|
Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
|
ClientData notUsed; /* Not used. */
|
ClientData notUsed; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
register Tcl_Obj *CONST objv[]; /* Argument objects. */
|
register Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Obj *listPtr;
|
Tcl_Obj *listPtr;
|
Tcl_Obj **elemPtrs;
|
Tcl_Obj **elemPtrs;
|
int listLen, first, last, numElems, result;
|
int listLen, first, last, numElems, result;
|
|
|
if (objc != 4) {
|
if (objc != 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
|
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure the list argument is a list object and get its length and
|
* Make sure the list argument is a list object and get its length and
|
* a pointer to its array of element pointers.
|
* a pointer to its array of element pointers.
|
*/
|
*/
|
|
|
listPtr = objv[1];
|
listPtr = objv[1];
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the first and last indexes.
|
* Get the first and last indexes.
|
*/
|
*/
|
|
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
|
&first);
|
&first);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
if (first < 0) {
|
if (first < 0) {
|
first = 0;
|
first = 0;
|
}
|
}
|
|
|
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
|
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
|
&last);
|
&last);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
if (last >= listLen) {
|
if (last >= listLen) {
|
last = (listLen - 1);
|
last = (listLen - 1);
|
}
|
}
|
|
|
if (first > last) {
|
if (first > last) {
|
return TCL_OK; /* the result is an empty object */
|
return TCL_OK; /* the result is an empty object */
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure listPtr still refers to a list object. It might have been
|
* Make sure listPtr still refers to a list object. It might have been
|
* converted to an int above if the argument objects were shared.
|
* converted to an int above if the argument objects were shared.
|
*/
|
*/
|
|
|
if (listPtr->typePtr != &tclListType) {
|
if (listPtr->typePtr != &tclListType) {
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
|
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
|
&elemPtrs);
|
&elemPtrs);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Extract a range of fields. We modify the interpreter's result object
|
* Extract a range of fields. We modify the interpreter's result object
|
* to be a list object containing the specified elements.
|
* to be a list object containing the specified elements.
|
*/
|
*/
|
|
|
numElems = (last - first + 1);
|
numElems = (last - first + 1);
|
Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
|
Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LreplaceObjCmd --
|
* Tcl_LreplaceObjCmd --
|
*
|
*
|
* This object-based procedure is invoked to process the "lreplace"
|
* This object-based procedure is invoked to process the "lreplace"
|
* Tcl command. See the user documentation for details on what it does.
|
* Tcl command. See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A new Tcl list object formed by replacing zero or more elements of
|
* A new Tcl list object formed by replacing zero or more elements of
|
* a list.
|
* a list.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
|
Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
register Tcl_Obj *listPtr;
|
register Tcl_Obj *listPtr;
|
int createdNewObj, first, last, listLen, numToDelete;
|
int createdNewObj, first, last, listLen, numToDelete;
|
int firstArgLen, result;
|
int firstArgLen, result;
|
char *firstArg;
|
char *firstArg;
|
|
|
if (objc < 4) {
|
if (objc < 4) {
|
Tcl_WrongNumArgs(interp, 1, objv,
|
Tcl_WrongNumArgs(interp, 1, objv,
|
"list first last ?element element ...?");
|
"list first last ?element element ...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If the list object is unshared we can modify it directly, otherwise
|
* If the list object is unshared we can modify it directly, otherwise
|
* we create a copy to modify: this is "copy on write".
|
* we create a copy to modify: this is "copy on write".
|
*/
|
*/
|
|
|
listPtr = objv[1];
|
listPtr = objv[1];
|
createdNewObj = 0;
|
createdNewObj = 0;
|
if (Tcl_IsShared(listPtr)) {
|
if (Tcl_IsShared(listPtr)) {
|
listPtr = Tcl_DuplicateObj(listPtr);
|
listPtr = Tcl_DuplicateObj(listPtr);
|
createdNewObj = 1;
|
createdNewObj = 1;
|
}
|
}
|
result = Tcl_ListObjLength(interp, listPtr, &listLen);
|
result = Tcl_ListObjLength(interp, listPtr, &listLen);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
errorReturn:
|
errorReturn:
|
if (createdNewObj) {
|
if (createdNewObj) {
|
Tcl_DecrRefCount(listPtr); /* free unneeded obj */
|
Tcl_DecrRefCount(listPtr); /* free unneeded obj */
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the first and last indexes.
|
* Get the first and last indexes.
|
*/
|
*/
|
|
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
|
result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
|
&first);
|
&first);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto errorReturn;
|
goto errorReturn;
|
}
|
}
|
firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
|
firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
|
|
|
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
|
result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
|
&last);
|
&last);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto errorReturn;
|
goto errorReturn;
|
}
|
}
|
|
|
if (first < 0) {
|
if (first < 0) {
|
first = 0;
|
first = 0;
|
}
|
}
|
if ((first >= listLen) && (listLen > 0)
|
if ((first >= listLen) && (listLen > 0)
|
&& (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
|
&& (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"list doesn't contain element ",
|
"list doesn't contain element ",
|
Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
|
Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
|
result = TCL_ERROR;
|
result = TCL_ERROR;
|
goto errorReturn;
|
goto errorReturn;
|
}
|
}
|
if (last >= listLen) {
|
if (last >= listLen) {
|
last = (listLen - 1);
|
last = (listLen - 1);
|
}
|
}
|
if (first <= last) {
|
if (first <= last) {
|
numToDelete = (last - first + 1);
|
numToDelete = (last - first + 1);
|
} else {
|
} else {
|
numToDelete = 0;
|
numToDelete = 0;
|
}
|
}
|
|
|
if (objc > 4) {
|
if (objc > 4) {
|
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
|
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
|
(objc-4), &(objv[4]));
|
(objc-4), &(objv[4]));
|
} else {
|
} else {
|
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
|
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
|
0, NULL);
|
0, NULL);
|
}
|
}
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
goto errorReturn;
|
goto errorReturn;
|
}
|
}
|
|
|
/*
|
/*
|
* Set the interpreter's object result.
|
* Set the interpreter's object result.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LsearchObjCmd --
|
* Tcl_LsearchObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "lsearch" Tcl command.
|
* This procedure is invoked to process the "lsearch" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_LsearchObjCmd(clientData, interp, objc, objv)
|
Tcl_LsearchObjCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument values. */
|
Tcl_Obj *CONST objv[]; /* Argument values. */
|
{
|
{
|
#define EXACT 0
|
#define EXACT 0
|
#define GLOB 1
|
#define GLOB 1
|
#define REGEXP 2
|
#define REGEXP 2
|
#define DICTIONARY 3
|
#define DICTIONARY 3
|
#define NOCASE 4
|
#define NOCASE 4
|
char *bytes, *patternBytes;
|
char *bytes, *patternBytes;
|
int i, match, mode, index, result, listLen, length, elemLen;
|
int i, match, mode, index, result, listLen, length, elemLen;
|
Tcl_Obj **elemPtrs;
|
Tcl_Obj **elemPtrs;
|
static char *switches[] =
|
static char *switches[] =
|
{"-exact", "-glob", "-regexp", "-dictionary", "-nocase", (char *) NULL};
|
{"-exact", "-glob", "-regexp", "-dictionary", "-nocase", (char *) NULL};
|
|
|
mode = GLOB;
|
mode = GLOB;
|
if (objc == 4) {
|
if (objc == 4) {
|
if (Tcl_GetIndexFromObj(interp, objv[1], switches,
|
if (Tcl_GetIndexFromObj(interp, objv[1], switches,
|
"search mode", 0, &mode) != TCL_OK) {
|
"search mode", 0, &mode) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else if (objc != 3) {
|
} else if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");
|
Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure the list argument is a list object and get its length and
|
* Make sure the list argument is a list object and get its length and
|
* a pointer to its array of element pointers.
|
* a pointer to its array of element pointers.
|
*/
|
*/
|
|
|
result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs);
|
result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
|
|
patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
|
patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
|
|
|
index = -1;
|
index = -1;
|
for (i = 0; i < listLen; i++) {
|
for (i = 0; i < listLen; i++) {
|
match = 0;
|
match = 0;
|
bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
|
bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
|
switch (mode) {
|
switch (mode) {
|
case EXACT:
|
case EXACT:
|
if (length == elemLen) {
|
if (length == elemLen) {
|
match = (memcmp(bytes, patternBytes,
|
match = (memcmp(bytes, patternBytes,
|
(size_t) length) == 0);
|
(size_t) length) == 0);
|
}
|
}
|
break;
|
break;
|
case GLOB:
|
case GLOB:
|
/*
|
/*
|
* WARNING: will not work with data containing NULLs.
|
* WARNING: will not work with data containing NULLs.
|
*/
|
*/
|
match = Tcl_StringMatch(bytes, patternBytes);
|
match = Tcl_StringMatch(bytes, patternBytes);
|
break;
|
break;
|
case REGEXP:
|
case REGEXP:
|
/*
|
/*
|
* WARNING: will not work with data containing NULLs.
|
* WARNING: will not work with data containing NULLs.
|
*/
|
*/
|
match = Tcl_RegExpMatch(interp, bytes, patternBytes);
|
match = Tcl_RegExpMatch(interp, bytes, patternBytes);
|
if (match < 0) {
|
if (match < 0) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
break;
|
break;
|
case DICTIONARY:
|
case DICTIONARY:
|
case NOCASE:
|
case NOCASE:
|
#if defined(__MSVC__) || defined(_MSC_VER)
|
#if defined(__MSVC__) || defined(_MSC_VER)
|
match = strnicmp (bytes, patternBytes, length) == 0;
|
match = strnicmp (bytes, patternBytes, length) == 0;
|
#else
|
#else
|
match = strncasecmp (bytes, patternBytes, length) == 0;
|
match = strncasecmp (bytes, patternBytes, length) == 0;
|
#endif
|
#endif
|
break;
|
break;
|
}
|
}
|
if (match) {
|
if (match) {
|
index = i;
|
index = i;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_LsortObjCmd --
|
* Tcl_LsortObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "lsort" Tcl command.
|
* This procedure is invoked to process the "lsort" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_LsortObjCmd(clientData, interp, objc, objv)
|
Tcl_LsortObjCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument values. */
|
Tcl_Obj *CONST objv[]; /* Argument values. */
|
{
|
{
|
int i, index, dummy;
|
int i, index, dummy;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int length;
|
int length;
|
Tcl_Obj *cmdPtr, **listObjPtrs;
|
Tcl_Obj *cmdPtr, **listObjPtrs;
|
SortElement *elementArray;
|
SortElement *elementArray;
|
SortElement *elementPtr;
|
SortElement *elementPtr;
|
SortInfo sortInfo; /* Information about this sort that
|
SortInfo sortInfo; /* Information about this sort that
|
* needs to be passed to the
|
* needs to be passed to the
|
* comparison function */
|
* comparison function */
|
static char *switches[] =
|
static char *switches[] =
|
{"-ascii", "-command", "-decreasing", "-dictionary",
|
{"-ascii", "-command", "-decreasing", "-dictionary",
|
"-increasing", "-index", "-integer", "-real", (char *) NULL};
|
"-increasing", "-index", "-integer", "-real", (char *) NULL};
|
|
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
|
Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Parse arguments to set up the mode for the sort.
|
* Parse arguments to set up the mode for the sort.
|
*/
|
*/
|
|
|
sortInfo.isIncreasing = 1;
|
sortInfo.isIncreasing = 1;
|
sortInfo.sortMode = SORTMODE_ASCII;
|
sortInfo.sortMode = SORTMODE_ASCII;
|
sortInfo.index = -1;
|
sortInfo.index = -1;
|
sortInfo.interp = interp;
|
sortInfo.interp = interp;
|
sortInfo.resultCode = TCL_OK;
|
sortInfo.resultCode = TCL_OK;
|
cmdPtr = NULL;
|
cmdPtr = NULL;
|
for (i = 1; i < objc-1; i++) {
|
for (i = 1; i < objc-1; i++) {
|
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
|
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
switch (index) {
|
switch (index) {
|
case 0: /* -ascii */
|
case 0: /* -ascii */
|
sortInfo.sortMode = SORTMODE_ASCII;
|
sortInfo.sortMode = SORTMODE_ASCII;
|
break;
|
break;
|
case 1: /* -command */
|
case 1: /* -command */
|
if (i == (objc-2)) {
|
if (i == (objc-2)) {
|
Tcl_AppendToObj(resultPtr,
|
Tcl_AppendToObj(resultPtr,
|
"\"-command\" option must be followed by comparison command",
|
"\"-command\" option must be followed by comparison command",
|
-1);
|
-1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
sortInfo.sortMode = SORTMODE_COMMAND;
|
sortInfo.sortMode = SORTMODE_COMMAND;
|
cmdPtr = objv[i+1];
|
cmdPtr = objv[i+1];
|
i++;
|
i++;
|
break;
|
break;
|
case 2: /* -decreasing */
|
case 2: /* -decreasing */
|
sortInfo.isIncreasing = 0;
|
sortInfo.isIncreasing = 0;
|
break;
|
break;
|
case 3: /* -dictionary */
|
case 3: /* -dictionary */
|
sortInfo.sortMode = SORTMODE_DICTIONARY;
|
sortInfo.sortMode = SORTMODE_DICTIONARY;
|
break;
|
break;
|
case 4: /* -increasing */
|
case 4: /* -increasing */
|
sortInfo.isIncreasing = 1;
|
sortInfo.isIncreasing = 1;
|
break;
|
break;
|
case 5: /* -index */
|
case 5: /* -index */
|
if (i == (objc-2)) {
|
if (i == (objc-2)) {
|
Tcl_AppendToObj(resultPtr,
|
Tcl_AppendToObj(resultPtr,
|
"\"-index\" option must be followed by list index",
|
"\"-index\" option must be followed by list index",
|
-1);
|
-1);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
|
if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
cmdPtr = objv[i+1];
|
cmdPtr = objv[i+1];
|
i++;
|
i++;
|
break;
|
break;
|
case 6: /* -integer */
|
case 6: /* -integer */
|
sortInfo.sortMode = SORTMODE_INTEGER;
|
sortInfo.sortMode = SORTMODE_INTEGER;
|
break;
|
break;
|
case 7: /* -real */
|
case 7: /* -real */
|
sortInfo.sortMode = SORTMODE_REAL;
|
sortInfo.sortMode = SORTMODE_REAL;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
if (sortInfo.sortMode == SORTMODE_COMMAND) {
|
if (sortInfo.sortMode == SORTMODE_COMMAND) {
|
Tcl_DStringInit(&sortInfo.compareCmd);
|
Tcl_DStringInit(&sortInfo.compareCmd);
|
Tcl_DStringAppend(&sortInfo.compareCmd,
|
Tcl_DStringAppend(&sortInfo.compareCmd,
|
Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
|
Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
|
}
|
}
|
|
|
sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
|
sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
|
&length, &listObjPtrs);
|
&length, &listObjPtrs);
|
if (sortInfo.resultCode != TCL_OK) {
|
if (sortInfo.resultCode != TCL_OK) {
|
goto done;
|
goto done;
|
}
|
}
|
if (length <= 0) {
|
if (length <= 0) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
|
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
|
for (i=0; i < length; i++){
|
for (i=0; i < length; i++){
|
elementArray[i].objPtr = listObjPtrs[i];
|
elementArray[i].objPtr = listObjPtrs[i];
|
elementArray[i].nextPtr = &elementArray[i+1];
|
elementArray[i].nextPtr = &elementArray[i+1];
|
}
|
}
|
elementArray[length-1].nextPtr = NULL;
|
elementArray[length-1].nextPtr = NULL;
|
elementPtr = MergeSort(elementArray, &sortInfo);
|
elementPtr = MergeSort(elementArray, &sortInfo);
|
if (sortInfo.resultCode == TCL_OK) {
|
if (sortInfo.resultCode == TCL_OK) {
|
/*
|
/*
|
* Note: must clear the interpreter's result object: it could
|
* Note: must clear the interpreter's result object: it could
|
* have been set by the -command script.
|
* have been set by the -command script.
|
*/
|
*/
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
|
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
|
Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
|
Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
|
}
|
}
|
}
|
}
|
ckfree((char*) elementArray);
|
ckfree((char*) elementArray);
|
|
|
done:
|
done:
|
if (sortInfo.sortMode == SORTMODE_COMMAND) {
|
if (sortInfo.sortMode == SORTMODE_COMMAND) {
|
Tcl_DStringFree(&sortInfo.compareCmd);
|
Tcl_DStringFree(&sortInfo.compareCmd);
|
}
|
}
|
return sortInfo.resultCode;
|
return sortInfo.resultCode;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* MergeSort -
|
* MergeSort -
|
*
|
*
|
* This procedure sorts a linked list of SortElement structures
|
* This procedure sorts a linked list of SortElement structures
|
* use the merge-sort algorithm.
|
* use the merge-sort algorithm.
|
*
|
*
|
* Results:
|
* Results:
|
* A pointer to the head of the list after sorting is returned.
|
* A pointer to the head of the list after sorting is returned.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None, unless a user-defined comparison command does something
|
* None, unless a user-defined comparison command does something
|
* weird.
|
* weird.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static SortElement *
|
static SortElement *
|
MergeSort(headPtr, infoPtr)
|
MergeSort(headPtr, infoPtr)
|
SortElement *headPtr; /* First element on the list */
|
SortElement *headPtr; /* First element on the list */
|
SortInfo *infoPtr; /* Information needed by the
|
SortInfo *infoPtr; /* Information needed by the
|
* comparison operator */
|
* comparison operator */
|
{
|
{
|
/*
|
/*
|
* The subList array below holds pointers to temporary lists built
|
* The subList array below holds pointers to temporary lists built
|
* during the merge sort. Element i of the array holds a list of
|
* during the merge sort. Element i of the array holds a list of
|
* length 2**i.
|
* length 2**i.
|
*/
|
*/
|
|
|
# define NUM_LISTS 30
|
# define NUM_LISTS 30
|
SortElement *subList[NUM_LISTS];
|
SortElement *subList[NUM_LISTS];
|
SortElement *elementPtr;
|
SortElement *elementPtr;
|
int i;
|
int i;
|
|
|
for(i = 0; i < NUM_LISTS; i++){
|
for(i = 0; i < NUM_LISTS; i++){
|
subList[i] = NULL;
|
subList[i] = NULL;
|
}
|
}
|
while (headPtr != NULL) {
|
while (headPtr != NULL) {
|
elementPtr = headPtr;
|
elementPtr = headPtr;
|
headPtr = headPtr->nextPtr;
|
headPtr = headPtr->nextPtr;
|
elementPtr->nextPtr = 0;
|
elementPtr->nextPtr = 0;
|
for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
|
for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
|
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
|
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
|
subList[i] = NULL;
|
subList[i] = NULL;
|
}
|
}
|
if (i >= NUM_LISTS) {
|
if (i >= NUM_LISTS) {
|
i = NUM_LISTS-1;
|
i = NUM_LISTS-1;
|
}
|
}
|
subList[i] = elementPtr;
|
subList[i] = elementPtr;
|
}
|
}
|
elementPtr = NULL;
|
elementPtr = NULL;
|
for (i = 0; i < NUM_LISTS; i++){
|
for (i = 0; i < NUM_LISTS; i++){
|
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
|
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
|
}
|
}
|
return elementPtr;
|
return elementPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* MergeLists -
|
* MergeLists -
|
*
|
*
|
* This procedure combines two sorted lists of SortElement structures
|
* This procedure combines two sorted lists of SortElement structures
|
* into a single sorted list.
|
* into a single sorted list.
|
*
|
*
|
* Results:
|
* Results:
|
* The unified list of SortElement structures.
|
* The unified list of SortElement structures.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None, unless a user-defined comparison command does something
|
* None, unless a user-defined comparison command does something
|
* weird.
|
* weird.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static SortElement *
|
static SortElement *
|
MergeLists(leftPtr, rightPtr, infoPtr)
|
MergeLists(leftPtr, rightPtr, infoPtr)
|
SortElement *leftPtr; /* First list to be merged; may be
|
SortElement *leftPtr; /* First list to be merged; may be
|
* NULL. */
|
* NULL. */
|
SortElement *rightPtr; /* Second list to be merged; may be
|
SortElement *rightPtr; /* Second list to be merged; may be
|
* NULL. */
|
* NULL. */
|
SortInfo *infoPtr; /* Information needed by the
|
SortInfo *infoPtr; /* Information needed by the
|
* comparison operator. */
|
* comparison operator. */
|
{
|
{
|
SortElement *headPtr;
|
SortElement *headPtr;
|
SortElement *tailPtr;
|
SortElement *tailPtr;
|
|
|
if (leftPtr == NULL) {
|
if (leftPtr == NULL) {
|
return rightPtr;
|
return rightPtr;
|
}
|
}
|
if (rightPtr == NULL) {
|
if (rightPtr == NULL) {
|
return leftPtr;
|
return leftPtr;
|
}
|
}
|
if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
|
if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
|
tailPtr = rightPtr;
|
tailPtr = rightPtr;
|
rightPtr = rightPtr->nextPtr;
|
rightPtr = rightPtr->nextPtr;
|
} else {
|
} else {
|
tailPtr = leftPtr;
|
tailPtr = leftPtr;
|
leftPtr = leftPtr->nextPtr;
|
leftPtr = leftPtr->nextPtr;
|
}
|
}
|
headPtr = tailPtr;
|
headPtr = tailPtr;
|
while ((leftPtr != NULL) && (rightPtr != NULL)) {
|
while ((leftPtr != NULL) && (rightPtr != NULL)) {
|
if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
|
if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
|
tailPtr->nextPtr = rightPtr;
|
tailPtr->nextPtr = rightPtr;
|
tailPtr = rightPtr;
|
tailPtr = rightPtr;
|
rightPtr = rightPtr->nextPtr;
|
rightPtr = rightPtr->nextPtr;
|
} else {
|
} else {
|
tailPtr->nextPtr = leftPtr;
|
tailPtr->nextPtr = leftPtr;
|
tailPtr = leftPtr;
|
tailPtr = leftPtr;
|
leftPtr = leftPtr->nextPtr;
|
leftPtr = leftPtr->nextPtr;
|
}
|
}
|
}
|
}
|
if (leftPtr != NULL) {
|
if (leftPtr != NULL) {
|
tailPtr->nextPtr = leftPtr;
|
tailPtr->nextPtr = leftPtr;
|
} else {
|
} else {
|
tailPtr->nextPtr = rightPtr;
|
tailPtr->nextPtr = rightPtr;
|
}
|
}
|
return headPtr;
|
return headPtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* SortCompare --
|
* SortCompare --
|
*
|
*
|
* This procedure is invoked by MergeLists to determine the proper
|
* This procedure is invoked by MergeLists to determine the proper
|
* ordering between two elements.
|
* ordering between two elements.
|
*
|
*
|
* Results:
|
* Results:
|
* A negative results means the the first element comes before the
|
* A negative results means the the first element comes before the
|
* second, and a positive results means that the second element
|
* second, and a positive results means that the second element
|
* should come first. A result of zero means the two elements
|
* should come first. A result of zero means the two elements
|
* are equal and it doesn't matter which comes first.
|
* are equal and it doesn't matter which comes first.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None, unless a user-defined comparison command does something
|
* None, unless a user-defined comparison command does something
|
* weird.
|
* weird.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
SortCompare(objPtr1, objPtr2, infoPtr)
|
SortCompare(objPtr1, objPtr2, infoPtr)
|
Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
|
Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
|
SortInfo *infoPtr; /* Information passed from the
|
SortInfo *infoPtr; /* Information passed from the
|
* top-level "lsort" command */
|
* top-level "lsort" command */
|
{
|
{
|
int order, dummy, listLen, index;
|
int order, dummy, listLen, index;
|
Tcl_Obj *objPtr;
|
Tcl_Obj *objPtr;
|
char buffer[30];
|
char buffer[30];
|
|
|
order = 0;
|
order = 0;
|
if (infoPtr->resultCode != TCL_OK) {
|
if (infoPtr->resultCode != TCL_OK) {
|
/*
|
/*
|
* Once an error has occurred, skip any future comparisons
|
* Once an error has occurred, skip any future comparisons
|
* so as to preserve the error message in sortInterp->result.
|
* so as to preserve the error message in sortInterp->result.
|
*/
|
*/
|
|
|
return order;
|
return order;
|
}
|
}
|
if (infoPtr->index != -1) {
|
if (infoPtr->index != -1) {
|
/*
|
/*
|
* The "-index" option was specified. Treat each object as a
|
* The "-index" option was specified. Treat each object as a
|
* list, extract the requested element from each list, and
|
* list, extract the requested element from each list, and
|
* compare the elements, not the lists. The special index "end"
|
* compare the elements, not the lists. The special index "end"
|
* is signaled here with a large negative index.
|
* is signaled here with a large negative index.
|
*/
|
*/
|
|
|
if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
|
if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
if (infoPtr->index < -1) {
|
if (infoPtr->index < -1) {
|
index = listLen - 1;
|
index = listLen - 1;
|
} else {
|
} else {
|
index = infoPtr->index;
|
index = infoPtr->index;
|
}
|
}
|
|
|
if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
|
if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
if (objPtr == NULL) {
|
if (objPtr == NULL) {
|
objPtr = objPtr1;
|
objPtr = objPtr1;
|
missingElement:
|
missingElement:
|
sprintf(buffer, "%d", infoPtr->index);
|
sprintf(buffer, "%d", infoPtr->index);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
|
"element ", buffer, " missing from sublist \"",
|
"element ", buffer, " missing from sublist \"",
|
Tcl_GetStringFromObj(objPtr, (int *) NULL),
|
Tcl_GetStringFromObj(objPtr, (int *) NULL),
|
"\"", (char *) NULL);
|
"\"", (char *) NULL);
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
objPtr1 = objPtr;
|
objPtr1 = objPtr;
|
|
|
if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
|
if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
if (infoPtr->index < -1) {
|
if (infoPtr->index < -1) {
|
index = listLen - 1;
|
index = listLen - 1;
|
} else {
|
} else {
|
index = infoPtr->index;
|
index = infoPtr->index;
|
}
|
}
|
|
|
if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
|
if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
if (objPtr == NULL) {
|
if (objPtr == NULL) {
|
objPtr = objPtr2;
|
objPtr = objPtr2;
|
goto missingElement;
|
goto missingElement;
|
}
|
}
|
objPtr2 = objPtr;
|
objPtr2 = objPtr;
|
}
|
}
|
if (infoPtr->sortMode == SORTMODE_ASCII) {
|
if (infoPtr->sortMode == SORTMODE_ASCII) {
|
order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
|
order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
|
Tcl_GetStringFromObj(objPtr2, &dummy));
|
Tcl_GetStringFromObj(objPtr2, &dummy));
|
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
|
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
|
order = DictionaryCompare(
|
order = DictionaryCompare(
|
Tcl_GetStringFromObj(objPtr1, &dummy),
|
Tcl_GetStringFromObj(objPtr1, &dummy),
|
Tcl_GetStringFromObj(objPtr2, &dummy));
|
Tcl_GetStringFromObj(objPtr2, &dummy));
|
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
|
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
|
int a, b;
|
int a, b;
|
|
|
if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|
if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|
|| (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
|
|| (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
|
!= TCL_OK)) {
|
!= TCL_OK)) {
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
if (a > b) {
|
if (a > b) {
|
order = 1;
|
order = 1;
|
} else if (b > a) {
|
} else if (b > a) {
|
order = -1;
|
order = -1;
|
}
|
}
|
} else if (infoPtr->sortMode == SORTMODE_REAL) {
|
} else if (infoPtr->sortMode == SORTMODE_REAL) {
|
double a, b;
|
double a, b;
|
|
|
if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|
if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|
|| (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
|
|| (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
|
!= TCL_OK)) {
|
!= TCL_OK)) {
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
if (a > b) {
|
if (a > b) {
|
order = 1;
|
order = 1;
|
} else if (b > a) {
|
} else if (b > a) {
|
order = -1;
|
order = -1;
|
}
|
}
|
} else {
|
} else {
|
int oldLength;
|
int oldLength;
|
|
|
/*
|
/*
|
* Generate and evaluate a command to determine which string comes
|
* Generate and evaluate a command to determine which string comes
|
* first.
|
* first.
|
*/
|
*/
|
|
|
oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
|
oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
|
Tcl_DStringAppendElement(&infoPtr->compareCmd,
|
Tcl_DStringAppendElement(&infoPtr->compareCmd,
|
Tcl_GetStringFromObj(objPtr1, &dummy));
|
Tcl_GetStringFromObj(objPtr1, &dummy));
|
Tcl_DStringAppendElement(&infoPtr->compareCmd,
|
Tcl_DStringAppendElement(&infoPtr->compareCmd,
|
Tcl_GetStringFromObj(objPtr2, &dummy));
|
Tcl_GetStringFromObj(objPtr2, &dummy));
|
infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
|
infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
|
Tcl_DStringValue(&infoPtr->compareCmd));
|
Tcl_DStringValue(&infoPtr->compareCmd));
|
Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
|
Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
|
if (infoPtr->resultCode != TCL_OK) {
|
if (infoPtr->resultCode != TCL_OK) {
|
Tcl_AddErrorInfo(infoPtr->interp,
|
Tcl_AddErrorInfo(infoPtr->interp,
|
"\n (-compare command)");
|
"\n (-compare command)");
|
return order;
|
return order;
|
}
|
}
|
|
|
/*
|
/*
|
* Parse the result of the command.
|
* Parse the result of the command.
|
*/
|
*/
|
|
|
if (Tcl_GetIntFromObj(infoPtr->interp,
|
if (Tcl_GetIntFromObj(infoPtr->interp,
|
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
|
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
|
Tcl_ResetResult(infoPtr->interp);
|
Tcl_ResetResult(infoPtr->interp);
|
Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
|
Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
|
"-compare command returned non-numeric result", -1);
|
"-compare command returned non-numeric result", -1);
|
infoPtr->resultCode = TCL_ERROR;
|
infoPtr->resultCode = TCL_ERROR;
|
return order;
|
return order;
|
}
|
}
|
}
|
}
|
if (!infoPtr->isIncreasing) {
|
if (!infoPtr->isIncreasing) {
|
order = -order;
|
order = -order;
|
}
|
}
|
return order;
|
return order;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* DictionaryCompare
|
* DictionaryCompare
|
*
|
*
|
* This function compares two strings as if they were being used in
|
* This function compares two strings as if they were being used in
|
* an index or card catalog. The case of alphabetic characters is
|
* an index or card catalog. The case of alphabetic characters is
|
* ignored, except to break ties. Thus "B" comes before "b" but
|
* ignored, except to break ties. Thus "B" comes before "b" but
|
* after "a". Also, integers embedded in the strings compare in
|
* after "a". Also, integers embedded in the strings compare in
|
* numerical order. In other words, "x10y" comes after "x9y", not
|
* numerical order. In other words, "x10y" comes after "x9y", not
|
* before it as it would when using strcmp().
|
* before it as it would when using strcmp().
|
*
|
*
|
* Results:
|
* Results:
|
* A negative result means that the first element comes before the
|
* A negative result means that the first element comes before the
|
* second, and a positive result means that the second element
|
* second, and a positive result means that the second element
|
* should come first. A result of zero means the two elements
|
* should come first. A result of zero means the two elements
|
* are equal and it doesn't matter which comes first.
|
* are equal and it doesn't matter which comes first.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static int
|
static int
|
DictionaryCompare(left, right)
|
DictionaryCompare(left, right)
|
char *left, *right; /* The strings to compare */
|
char *left, *right; /* The strings to compare */
|
{
|
{
|
int diff, zeros;
|
int diff, zeros;
|
int secondaryDiff = 0;
|
int secondaryDiff = 0;
|
|
|
while (1) {
|
while (1) {
|
if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
|
if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
|
/*
|
/*
|
* There are decimal numbers embedded in the two
|
* There are decimal numbers embedded in the two
|
* strings. Compare them as numbers, rather than
|
* strings. Compare them as numbers, rather than
|
* strings. If one number has more leading zeros than
|
* strings. If one number has more leading zeros than
|
* the other, the number with more leading zeros sorts
|
* the other, the number with more leading zeros sorts
|
* later, but only as a secondary choice.
|
* later, but only as a secondary choice.
|
*/
|
*/
|
|
|
zeros = 0;
|
zeros = 0;
|
while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
|
while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
|
right++;
|
right++;
|
zeros--;
|
zeros--;
|
}
|
}
|
while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
|
while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
|
left++;
|
left++;
|
zeros++;
|
zeros++;
|
}
|
}
|
if (secondaryDiff == 0) {
|
if (secondaryDiff == 0) {
|
secondaryDiff = zeros;
|
secondaryDiff = zeros;
|
}
|
}
|
|
|
/*
|
/*
|
* The code below compares the numbers in the two
|
* The code below compares the numbers in the two
|
* strings without ever converting them to integers. It
|
* strings without ever converting them to integers. It
|
* does this by first comparing the lengths of the
|
* does this by first comparing the lengths of the
|
* numbers and then comparing the digit values.
|
* numbers and then comparing the digit values.
|
*/
|
*/
|
|
|
diff = 0;
|
diff = 0;
|
while (1) {
|
while (1) {
|
if (diff == 0) {
|
if (diff == 0) {
|
diff = UCHAR(*left) - UCHAR(*right);
|
diff = UCHAR(*left) - UCHAR(*right);
|
}
|
}
|
right++;
|
right++;
|
left++;
|
left++;
|
if (!isdigit(UCHAR(*right))) {
|
if (!isdigit(UCHAR(*right))) {
|
if (isdigit(UCHAR(*left))) {
|
if (isdigit(UCHAR(*left))) {
|
return 1;
|
return 1;
|
} else {
|
} else {
|
/*
|
/*
|
* The two numbers have the same length. See
|
* The two numbers have the same length. See
|
* if their values are different.
|
* if their values are different.
|
*/
|
*/
|
|
|
if (diff != 0) {
|
if (diff != 0) {
|
return diff;
|
return diff;
|
}
|
}
|
break;
|
break;
|
}
|
}
|
} else if (!isdigit(UCHAR(*left))) {
|
} else if (!isdigit(UCHAR(*left))) {
|
return -1;
|
return -1;
|
}
|
}
|
}
|
}
|
continue;
|
continue;
|
}
|
}
|
diff = UCHAR(*left) - UCHAR(*right);
|
diff = UCHAR(*left) - UCHAR(*right);
|
if (diff) {
|
if (diff) {
|
if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
|
if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
|
diff = UCHAR(tolower(*left)) - UCHAR(*right);
|
diff = UCHAR(tolower(*left)) - UCHAR(*right);
|
if (diff) {
|
if (diff) {
|
return diff;
|
return diff;
|
} else if (secondaryDiff == 0) {
|
} else if (secondaryDiff == 0) {
|
secondaryDiff = -1;
|
secondaryDiff = -1;
|
}
|
}
|
} else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
|
} else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
|
diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
|
diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
|
if (diff) {
|
if (diff) {
|
return diff;
|
return diff;
|
} else if (secondaryDiff == 0) {
|
} else if (secondaryDiff == 0) {
|
secondaryDiff = 1;
|
secondaryDiff = 1;
|
}
|
}
|
} else {
|
} else {
|
return diff;
|
return diff;
|
}
|
}
|
}
|
}
|
if (*left == 0) {
|
if (*left == 0) {
|
break;
|
break;
|
}
|
}
|
left++;
|
left++;
|
right++;
|
right++;
|
}
|
}
|
if (diff == 0) {
|
if (diff == 0) {
|
diff = secondaryDiff;
|
diff = secondaryDiff;
|
}
|
}
|
return diff;
|
return diff;
|
}
|
}
|
|
|
