#include "tclInt.h"
#include "tclPort.h"
#include "tclCompile.h"
typedef struct SortElement {
Tcl_Obj *objPtr;
struct SortElement *nextPtr;
} SortElement;
typedef struct SortInfo {
int isIncreasing;
int sortMode;
Tcl_DString compareCmd;
int index;
Tcl_Interp *interp;
int resultCode;
} SortInfo;
#define SORTMODE_ASCII 0
#define SORTMODE_INTEGER 1
#define SORTMODE_REAL 2
#define SORTMODE_COMMAND 3
#define SORTMODE_DICTIONARY 4
static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *listPtr, char *pattern,
int includeLinks));
static int DictionaryCompare _ANSI_ARGS_((char *left,
char *right));
static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoNameOfExecutableCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
SortInfo *infoPtr));
static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
SortElement *rightPtr, SortInfo *infoPtr));
static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
Tcl_Obj *second, SortInfo *infoPtr));
int
Tcl_IfCmd(dummy, interp, argc, argv)
ClientData dummy;
Tcl_Interp *interp;
int argc;
char **argv;
{
int i, result, value;
i = 1;
while (1) {
if (i >= argc) {
Tcl_AppendResult(interp, "wrong # args: no expression after \"",
argv[i-1], "\" argument", (char *) NULL);
return TCL_ERROR;
}
result = Tcl_ExprBoolean(interp, argv[i], &value);
if (result != TCL_OK) {
return result;
}
i++;
if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
i++;
}
if (i >= argc) {
Tcl_AppendResult(interp, "wrong # args: no script following \"",
argv[i-1], "\" argument", (char *) NULL);
return TCL_ERROR;
}
if (value) {
return Tcl_Eval(interp, argv[i]);
}
i++;
if (i >= argc) {
return TCL_OK;
}
if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
i++;
continue;
}
break;
}
if (strcmp(argv[i], "else") == 0) {
i++;
if (i >= argc) {
Tcl_AppendResult(interp,
"wrong # args: no script following \"else\" argument",
(char *) NULL);
return TCL_ERROR;
}
}
return Tcl_Eval(interp, argv[i]);
}
int
Tcl_IncrCmd(dummy, interp, argc, argv)
ClientData dummy;
Tcl_Interp *interp;
int argc;
char **argv;
{
int value;
char *oldString, *result;
char newString[30];
if ((argc != 2) && (argc != 3)) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" varName ?increment?\"", (char *) NULL);
return TCL_ERROR;
}
oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
if (oldString == NULL) {
return TCL_ERROR;
}
if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (reading value of variable to increment)");
return TCL_ERROR;
}
if (argc == 2) {
value += 1;
} else {
int increment;
if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (reading increment)");
return TCL_ERROR;
}
value += increment;
}
TclFormatInt(newString, value);
result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
if (result == NULL) {
return TCL_ERROR;
}
Tcl_SetResult(interp, result, TCL_VOLATILE);
return TCL_OK;
}
int
Tcl_InfoObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
static char *subCmds[] = {
"args", "body", "cmdcount", "commands",
"complete", "default", "exists", "globals",
"hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
} index;
int result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
(int *) &index);
if (result != TCL_OK) {
return result;
}
switch (index) {
case IArgsIdx:
result = InfoArgsCmd(clientData, interp, objc, objv);
break;
case IBodyIdx:
result = InfoBodyCmd(clientData, interp, objc, objv);
break;
case ICmdCountIdx:
result = InfoCmdCountCmd(clientData, interp, objc, objv);
break;
case ICommandsIdx:
result = InfoCommandsCmd(clientData, interp, objc, objv);
break;
case ICompleteIdx:
result = InfoCompleteCmd(clientData, interp, objc, objv);
break;
case IDefaultIdx:
result = InfoDefaultCmd(clientData, interp, objc, objv);
break;
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
case IGlobalsIdx:
result = InfoGlobalsCmd(clientData, interp, objc, objv);
break;
case IHostnameIdx:
result = InfoHostnameCmd(clientData, interp, objc, objv);
break;
case ILevelIdx:
result = InfoLevelCmd(clientData, interp, objc, objv);
break;
case ILibraryIdx:
result = InfoLibraryCmd(clientData, interp, objc, objv);
break;
case ILoadedIdx:
result = InfoLoadedCmd(clientData, interp, objc, objv);
break;
case ILocalsIdx:
result = InfoLocalsCmd(clientData, interp, objc, objv);
break;
case INameOfExecutableIdx:
result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
break;
case IPatchLevelIdx:
result = InfoPatchLevelCmd(clientData, interp, objc, objv);
break;
case IProcsIdx:
result = InfoProcsCmd(clientData, interp, objc, objv);
break;
case IScriptIdx:
result = InfoScriptCmd(clientData, interp, objc, objv);
break;
case ISharedLibExtensionIdx:
result = InfoSharedlibCmd(clientData, interp, objc, objv);
break;
case ITclVersionIdx:
result = InfoTclVersionCmd(clientData, interp, objc, objv);
break;
case IVarsIdx:
result = InfoVarsCmd(clientData, interp, objc, objv);
break;
}
return result;
}
static int
InfoArgsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
register Interp *iPtr = (Interp *) interp;
char *name;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *listObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", name, "\" isn't a procedure", (char *) NULL);
return TCL_ERROR;
}
listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
Tcl_ListObjAppendElement(interp, listObjPtr,
Tcl_NewStringObj(localPtr->name, -1));
}
}
Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
}
static int
InfoBodyCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
register Interp *iPtr = (Interp *) interp;
char *name;
Proc *procPtr;
Tcl_Obj *bodyPtr, *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", name, "\" isn't a procedure", (char *) NULL);
return TCL_ERROR;
}
bodyPtr = procPtr->bodyPtr;
resultPtr = bodyPtr;
if (bodyPtr->typePtr == &tclByteCodeType) {
ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
}
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
static int
InfoCmdCountCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
return TCL_OK;
}
static int
InfoCommandsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *cmdName, *pattern, *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;
Tcl_Command cmd;
int result;
if (objc == 2) {
simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
} else if (objc == 3) {
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
result = TclGetNamespaceForQualName(interp, pattern,
(Namespace *) NULL, TCL_LEAVE_ERR_MSG,
&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (result != TCL_OK) {
return TCL_ERROR;
}
if (nsPtr != NULL) {
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (nsPtr != NULL) {
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
static int
InfoCompleteCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "command");
return TCL_ERROR;
}
if (TclObjCommandComplete(objv[2])) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
static int
InfoDefaultCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
char *procName, *argName, *varName;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *valueObjPtr;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
return TCL_ERROR;
}
procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"\"", procName, "\" isn't a procedure", (char *) NULL);
return TCL_ERROR;
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
localPtr = localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)
&& (strcmp(argName, localPtr->name) == 0)) {
if (localPtr->defValuePtr != NULL) {
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
localPtr->defValuePtr, 0);
if (valueObjPtr == NULL) {
defStoreError:
varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't store default value in variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
nullObjPtr, 0);
if (valueObjPtr == NULL) {
Tcl_DecrRefCount(nullObjPtr);
goto defStoreError;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
}
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"procedure \"", procName, "\" doesn't have an argument \"",
argName, "\"", (char *) NULL);
return TCL_ERROR;
}
static int
InfoExistsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *varName;
Var *varPtr, *arrayPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varName");
return TCL_ERROR;
}
varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
varPtr = TclLookupVar(interp, varName, (char *) NULL,
TCL_PARSE_PART1, "access",
0, 0, &arrayPtr);
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
static int
InfoGlobalsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *varName, *pattern;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Var *varPtr;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (TclIsVarUndefined(varPtr)) {
continue;
}
varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
static int
InfoHostnameCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *name;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
name = Tcl_GetHostName();
if (name) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
return TCL_OK;
} else {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"unable to determine name of host", -1);
return TCL_ERROR;
}
}
static int
InfoLevelCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
int level;
CallFrame *framePtr;
Tcl_Obj *listPtr;
if (objc == 2) {
if (iPtr->varFramePtr == NULL) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
}
return TCL_OK;
} else if (objc == 3) {
if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
if (iPtr->varFramePtr == NULL) {
levelError:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad level \"",
Tcl_GetStringFromObj(objv[2], (int *) NULL),
"\"", (char *) NULL);
return TCL_ERROR;
}
level += iPtr->varFramePtr->level;
}
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if (framePtr->level == level) {
break;
}
}
if (framePtr == NULL) {
goto levelError;
}
listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
static int
InfoLibraryCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *libDirName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
return TCL_OK;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"no library has been specified for Tcl", -1);
return TCL_ERROR;
}
static int
InfoLoadedCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *interpName;
int result;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
return TCL_ERROR;
}
if (objc == 2) {
interpName = NULL;
} else {
interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
}
result = TclGetLoadedPackages(interp, interpName);
return result;
}
static int
InfoLocalsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
char *pattern;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
return TCL_OK;
}
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
AppendLocals(interp, listPtr, pattern, 0);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
static void
AppendLocals(interp, listPtr, pattern, includeLinks)
Tcl_Interp *interp;
Tcl_Obj *listPtr;
char *pattern;
int includeLinks;
{
Interp *iPtr = (Interp *) interp;
CompiledLocal *localPtr;
Var *varPtr;
int i, localVarCt;
char *varName;
Tcl_HashTable *localVarTablePtr;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
localVarCt = iPtr->varFramePtr->numCompiledLocals;
varPtr = iPtr->varFramePtr->compiledLocals;
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
for (i = 0; i < localVarCt; i++) {
if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
varName = varPtr->name;
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (localVarTablePtr != NULL) {
for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
}
}
static int
InfoNameOfExecutableCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
CONST char *nameOfExecutable;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
nameOfExecutable = Tcl_GetNameOfExecutable();
if (nameOfExecutable != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
}
return TCL_OK;
}
static int
InfoPatchLevelCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *patchlevel;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
return TCL_OK;
}
return TCL_ERROR;
}
static int
InfoProcsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *cmdName, *pattern;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (TclIsProc(cmdPtr)) {
if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
static int
InfoScriptCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
if (iPtr->scriptFile != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
}
return TCL_OK;
}
static int
InfoSharedlibCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
#ifdef TCL_SHLIB_EXT
Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
#endif
return TCL_OK;
}
static int
InfoTclVersionCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *version;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
version = Tcl_GetVar(interp, "tcl_version",
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (version != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
return TCL_OK;
}
return TCL_ERROR;
}
static int
InfoVarsCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Interp *iPtr = (Interp *) interp;
char *varName, *pattern, *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Var *varPtr;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;
int result;
if (objc == 2) {
simplePattern = NULL;
nsPtr = currNsPtr;
specificNsInPattern = 0;
} else if (objc == 3) {
Namespace *dummy1NsPtr, *dummy2NsPtr;
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
result = TclGetNamespaceForQualName(interp, pattern,
(Namespace *) NULL, TCL_LEAVE_ERR_MSG,
&nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (result != TCL_OK) {
return TCL_ERROR;
}
if (nsPtr != NULL) {
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
if (nsPtr == NULL) {
return TCL_OK;
}
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if ((iPtr->varFramePtr == NULL)
|| !iPtr->varFramePtr->isProcCallFrame
|| specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(varName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
} else {
AppendLocals(interp, listPtr, simplePattern, 1);
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
int
Tcl_JoinObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
char *joinString, *bytes;
int joinLength, listLen, length, i, result;
Tcl_Obj **elemPtrs;
Tcl_Obj *resObjPtr;
if (objc == 2) {
joinString = " ";
joinLength = 1;
} else if (objc == 3) {
joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
resObjPtr = Tcl_GetObjResult(interp);
for (i = 0; i < listLen; i++) {
bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
if (i > 0) {
Tcl_AppendToObj(resObjPtr, joinString, joinLength);
}
Tcl_AppendToObj(resObjPtr, bytes, length);
}
return TCL_OK;
}
int
Tcl_LindexObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Tcl_Obj *listPtr;
Tcl_Obj **elemPtrs;
int listLen, index, result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index");
return TCL_ERROR;
}
listPtr = objv[1];
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndex(interp, objv[2], (listLen - 1),
&index);
if (result != TCL_OK) {
return result;
}
if ((index < 0) || (index >= listLen)) {
return TCL_OK;
}
if (listPtr->typePtr != &tclListType) {
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
}
Tcl_SetObjResult(interp, elemPtrs[index]);
return TCL_OK;
}
int
Tcl_LinsertObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
register int objc;
Tcl_Obj *CONST objv[];
{
Tcl_Obj *listPtr, *resultPtr;
Tcl_ObjType *typePtr;
int index, isDuplicate, len, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
return TCL_ERROR;
}
result = TclGetIntForIndex(interp, objv[2], INT_MAX,
&index);
if (result != TCL_OK) {
return result;
}
listPtr = objv[1];
isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
Tcl_ResetResult(interp);
resultPtr = Tcl_GetObjResult(interp);
typePtr = listPtr->typePtr;
if (listPtr->bytes == NULL) {
resultPtr->bytes = NULL;
} else if (listPtr->bytes != tclEmptyStringRep) {
len = listPtr->length;
TclInitStringRep(resultPtr, listPtr->bytes, len);
}
if (typePtr != NULL) {
if (typePtr->dupIntRepProc == NULL) {
resultPtr->internalRep = listPtr->internalRep;
resultPtr->typePtr = typePtr;
} else {
(*typePtr->dupIntRepProc)(listPtr, resultPtr);
}
}
listPtr = resultPtr;
isDuplicate = 1;
}
if ((objc == 4) && (index == INT_MAX)) {
result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
} else if (objc > 3) {
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]));
}
if (result != TCL_OK) {
return result;
}
if (!isDuplicate) {
Tcl_SetObjResult(interp, listPtr);
}
return TCL_OK;
}
int
Tcl_ListObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
register int objc;
register Tcl_Obj *CONST objv[];
{
if (objc > 1) {
Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
}
return TCL_OK;
}
int
Tcl_LlengthObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
register Tcl_Obj *CONST objv[];
{
int listLen, result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
result = Tcl_ListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
return TCL_OK;
}
int
Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
ClientData notUsed;
Tcl_Interp *interp;
int objc;
register Tcl_Obj *CONST objv[];
{
Tcl_Obj *listPtr;
Tcl_Obj **elemPtrs;
int listLen, first, last, numElems, result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
listPtr = objv[1];
result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndex(interp, objv[2], (listLen - 1),
&first);
if (result != TCL_OK) {
return result;
}
if (first < 0) {
first = 0;
}
result = TclGetIntForIndex(interp, objv[3], (listLen - 1),
&last);
if (result != TCL_OK) {
return result;
}
if (last >= listLen) {
last = (listLen - 1);
}
if (first > last) {
return TCL_OK;
}
if (listPtr->typePtr != &tclListType) {
result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
}
numElems = (last - first + 1);
Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
return TCL_OK;
}
int
Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
register Tcl_Obj *listPtr;
int createdNewObj, first, last, listLen, numToDelete;
int firstArgLen, result;
char *firstArg;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element element ...?");
return TCL_ERROR;
}
listPtr = objv[1];
createdNewObj = 0;
if (Tcl_IsShared(listPtr)) {
listPtr = Tcl_DuplicateObj(listPtr);
createdNewObj = 1;
}
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
errorReturn:
if (createdNewObj) {
Tcl_DecrRefCount(listPtr);
}
return result;
}
result = TclGetIntForIndex(interp, objv[2], (listLen - 1),
&first);
if (result != TCL_OK) {
goto errorReturn;
}
firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
result = TclGetIntForIndex(interp, objv[3], (listLen - 1),
&last);
if (result != TCL_OK) {
goto errorReturn;
}
if (first < 0) {
first = 0;
}
if ((first >= listLen) && (listLen > 0)
&& (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"list doesn't contain element ",
Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
result = TCL_ERROR;
goto errorReturn;
}
if (last >= listLen) {
last = (listLen - 1);
}
if (first <= last) {
numToDelete = (last - first + 1);
} else {
numToDelete = 0;
}
if (objc > 4) {
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
(objc-4), &(objv[4]));
} else {
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
0, NULL);
}
if (result != TCL_OK) {
goto errorReturn;
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
int
Tcl_LsearchObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
#define EXACT 0
#define GLOB 1
#define REGEXP 2
#define DICTIONARY 3
#define NOCASE 4
char *bytes, *patternBytes;
int i, match, mode, index, result, listLen, length, elemLen;
Tcl_Obj **elemPtrs;
static char *switches[] =
{"-exact", "-glob", "-regexp", "-dictionary", "-nocase", (char *) NULL};
mode = GLOB;
if (objc == 4) {
if (Tcl_GetIndexFromObj(interp, objv[1], switches,
"search mode", 0, &mode) != TCL_OK) {
return TCL_ERROR;
}
} else if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");
return TCL_ERROR;
}
result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
index = -1;
for (i = 0; i < listLen; i++) {
match = 0;
bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
switch (mode) {
case EXACT:
if (length == elemLen) {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
}
break;
case GLOB:
match = Tcl_StringMatch(bytes, patternBytes);
break;
case REGEXP:
match = Tcl_RegExpMatch(interp, bytes, patternBytes);
if (match < 0) {
return TCL_ERROR;
}
break;
case DICTIONARY:
case NOCASE:
#if defined(__MSVC__) || defined(_MSC_VER)
match = strnicmp (bytes, patternBytes, length) == 0;
#else
match = strncasecmp (bytes, patternBytes, length) == 0;
#endif
break;
}
if (match) {
index = i;
break;
}
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
return TCL_OK;
}
int
Tcl_LsortObjCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
int i, index, dummy;
Tcl_Obj *resultPtr;
int length;
Tcl_Obj *cmdPtr, **listObjPtrs;
SortElement *elementArray;
SortElement *elementPtr;
SortInfo sortInfo;
static char *switches[] =
{"-ascii", "-command", "-decreasing", "-dictionary",
"-increasing", "-index", "-integer", "-real", (char *) NULL};
resultPtr = Tcl_GetObjResult(interp);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
return TCL_ERROR;
}
sortInfo.isIncreasing = 1;
sortInfo.sortMode = SORTMODE_ASCII;
sortInfo.index = -1;
sortInfo.interp = interp;
sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
for (i = 1; i < objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
!= TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case 0:
sortInfo.sortMode = SORTMODE_ASCII;
break;
case 1:
if (i == (objc-2)) {
Tcl_AppendToObj(resultPtr,
"\"-command\" option must be followed by comparison command",
-1);
return TCL_ERROR;
}
sortInfo.sortMode = SORTMODE_COMMAND;
cmdPtr = objv[i+1];
i++;
break;
case 2:
sortInfo.isIncreasing = 0;
break;
case 3:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case 4:
sortInfo.isIncreasing = 1;
break;
case 5:
if (i == (objc-2)) {
Tcl_AppendToObj(resultPtr,
"\"-index\" option must be followed by list index",
-1);
return TCL_ERROR;
}
if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
!= TCL_OK) {
return TCL_ERROR;
}
cmdPtr = objv[i+1];
i++;
break;
case 6:
sortInfo.sortMode = SORTMODE_INTEGER;
break;
case 7:
sortInfo.sortMode = SORTMODE_REAL;
break;
}
}
if (sortInfo.sortMode == SORTMODE_COMMAND) {
Tcl_DStringInit(&sortInfo.compareCmd);
Tcl_DStringAppend(&sortInfo.compareCmd,
Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
}
sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
&length, &listObjPtrs);
if (sortInfo.resultCode != TCL_OK) {
goto done;
}
if (length <= 0) {
return TCL_OK;
}
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
for (i=0; i < length; i++){
elementArray[i].objPtr = listObjPtrs[i];
elementArray[i].nextPtr = &elementArray[i+1];
}
elementArray[length-1].nextPtr = NULL;
elementPtr = MergeSort(elementArray, &sortInfo);
if (sortInfo.resultCode == TCL_OK) {
Tcl_ResetResult(interp);
resultPtr = Tcl_GetObjResult(interp);
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
}
}
ckfree((char*) elementArray);
done:
if (sortInfo.sortMode == SORTMODE_COMMAND) {
Tcl_DStringFree(&sortInfo.compareCmd);
}
return sortInfo.resultCode;
}
static SortElement *
MergeSort(headPtr, infoPtr)
SortElement *headPtr;
SortInfo *infoPtr;
{
# define NUM_LISTS 30
SortElement *subList[NUM_LISTS];
SortElement *elementPtr;
int i;
for(i = 0; i < NUM_LISTS; i++){
subList[i] = NULL;
}
while (headPtr != NULL) {
elementPtr = headPtr;
headPtr = headPtr->nextPtr;
elementPtr->nextPtr = 0;
for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
subList[i] = NULL;
}
if (i >= NUM_LISTS) {
i = NUM_LISTS-1;
}
subList[i] = elementPtr;
}
elementPtr = NULL;
for (i = 0; i < NUM_LISTS; i++){
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
}
return elementPtr;
}
static SortElement *
MergeLists(leftPtr, rightPtr, infoPtr)
SortElement *leftPtr;
SortElement *rightPtr;
SortInfo *infoPtr;
{
SortElement *headPtr;
SortElement *tailPtr;
if (leftPtr == NULL) {
return rightPtr;
}
if (rightPtr == NULL) {
return leftPtr;
}
if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
tailPtr = rightPtr;
rightPtr = rightPtr->nextPtr;
} else {
tailPtr = leftPtr;
leftPtr = leftPtr->nextPtr;
}
headPtr = tailPtr;
while ((leftPtr != NULL) && (rightPtr != NULL)) {
if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
tailPtr->nextPtr = rightPtr;
tailPtr = rightPtr;
rightPtr = rightPtr->nextPtr;
} else {
tailPtr->nextPtr = leftPtr;
tailPtr = leftPtr;
leftPtr = leftPtr->nextPtr;
}
}
if (leftPtr != NULL) {
tailPtr->nextPtr = leftPtr;
} else {
tailPtr->nextPtr = rightPtr;
}
return headPtr;
}
static int
SortCompare(objPtr1, objPtr2, infoPtr)
Tcl_Obj *objPtr1, *objPtr2;
SortInfo *infoPtr;
{
int order, dummy, listLen, index;
Tcl_Obj *objPtr;
char buffer[30];
order = 0;
if (infoPtr->resultCode != TCL_OK) {
return order;
}
if (infoPtr->index != -1) {
if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (infoPtr->index < -1) {
index = listLen - 1;
} else {
index = infoPtr->index;
}
if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
!= TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (objPtr == NULL) {
objPtr = objPtr1;
missingElement:
sprintf(buffer, "%d", infoPtr->index);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
"element ", buffer, " missing from sublist \"",
Tcl_GetStringFromObj(objPtr, (int *) NULL),
"\"", (char *) NULL);
infoPtr->resultCode = TCL_ERROR;
return order;
}
objPtr1 = objPtr;
if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (infoPtr->index < -1) {
index = listLen - 1;
} else {
index = infoPtr->index;
}
if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
!= TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (objPtr == NULL) {
objPtr = objPtr2;
goto missingElement;
}
objPtr2 = objPtr;
}
if (infoPtr->sortMode == SORTMODE_ASCII) {
order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
Tcl_GetStringFromObj(objPtr2, &dummy));
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
order = DictionaryCompare(
Tcl_GetStringFromObj(objPtr1, &dummy),
Tcl_GetStringFromObj(objPtr2, &dummy));
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
int a, b;
if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|| (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
!= TCL_OK)) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (a > b) {
order = 1;
} else if (b > a) {
order = -1;
}
} else if (infoPtr->sortMode == SORTMODE_REAL) {
double a, b;
if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
|| (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
!= TCL_OK)) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
if (a > b) {
order = 1;
} else if (b > a) {
order = -1;
}
} else {
int oldLength;
oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
Tcl_DStringAppendElement(&infoPtr->compareCmd,
Tcl_GetStringFromObj(objPtr1, &dummy));
Tcl_DStringAppendElement(&infoPtr->compareCmd,
Tcl_GetStringFromObj(objPtr2, &dummy));
infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
Tcl_DStringValue(&infoPtr->compareCmd));
Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
if (infoPtr->resultCode != TCL_OK) {
Tcl_AddErrorInfo(infoPtr->interp,
"\n (-compare command)");
return order;
}
if (Tcl_GetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
"-compare command returned non-numeric result", -1);
infoPtr->resultCode = TCL_ERROR;
return order;
}
}
if (!infoPtr->isIncreasing) {
order = -order;
}
return order;
}
static int
DictionaryCompare(left, right)
char *left, *right;
{
int diff, zeros;
int secondaryDiff = 0;
while (1) {
if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
zeros = 0;
while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
right++;
zeros--;
}
while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
left++;
zeros++;
}
if (secondaryDiff == 0) {
secondaryDiff = zeros;
}
diff = 0;
while (1) {
if (diff == 0) {
diff = UCHAR(*left) - UCHAR(*right);
}
right++;
left++;
if (!isdigit(UCHAR(*right))) {
if (isdigit(UCHAR(*left))) {
return 1;
} else {
if (diff != 0) {
return diff;
}
break;
}
} else if (!isdigit(UCHAR(*left))) {
return -1;
}
}
continue;
}
diff = UCHAR(*left) - UCHAR(*right);
if (diff) {
if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
diff = UCHAR(tolower(*left)) - UCHAR(*right);
if (diff) {
return diff;
} else if (secondaryDiff == 0) {
secondaryDiff = -1;
}
} else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
if (diff) {
return diff;
} else if (secondaryDiff == 0) {
secondaryDiff = 1;
}
} else {
return diff;
}
}
if (*left == 0) {
break;
}
left++;
right++;
}
if (diff == 0) {
diff = secondaryDiff;
}
return diff;
}