Fork me on GitHub

source: git/external/tcl/tclCmdIL.c

Last change on this file was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk
  • Property mode set to 100644
File size: 77.2 KB
Line 
1/*
2 * tclCmdIL.c --
3 *
4 * This file contains the top-level command routines for most of
5 * the Tcl built-in commands whose names begin with the letters
6 * I through L. It contains only commands in the generic core
7 * (i.e. those that don't depend much upon UNIX facilities).
8 *
9 * Copyright (c) 1987-1993 The Regents of the University of California.
10 * Copyright (c) 1993-1997 Lucent Technologies.
11 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12 * Copyright (c) 1998-1999 by Scriptics Corporation.
13 *
14 * See the file "license.terms" for information on usage and redistribution
15 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16 *
17 * RCS: @(#) $Id: tclCmdIL.c,v 1.1 2008-06-04 13:58:04 demin Exp $
18 */
19
20#include "tclInt.h"
21#include "tclPort.h"
22#include "tclCompile.h"
23
24/*
25 * During execution of the "lsort" command, structures of the following
26 * type are used to arrange the objects being sorted into a collection
27 * of linked lists.
28 */
29
30typedef struct SortElement {
31 Tcl_Obj *objPtr; /* Object being sorted. */
32 struct SortElement *nextPtr; /* Next element in the list, or
33 * NULL for end of list. */
34} SortElement;
35
36/*
37 * The "lsort" command needs to pass certain information down to the
38 * function that compares two list elements, and the comparison function
39 * needs to pass success or failure information back up to the top-level
40 * "lsort" command. The following structure is used to pass this
41 * information.
42 */
43
44typedef struct SortInfo {
45 int isIncreasing; /* Nonzero means sort in increasing order. */
46 int sortMode; /* The sort mode. One of SORTMODE_*
47 * values defined below */
48 Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
49 * is SORTMODE_COMMAND. Pre-initialized to
50 * hold base of command.*/
51 int index; /* If the -index option was specified, this
52 * holds the index of the list element
53 * to extract for comparison. If -index
54 * wasn't specified, this is -1. */
55 Tcl_Interp *interp; /* The interpreter in which the sortis
56 * being done. */
57 int resultCode; /* Completion code for the lsort command.
58 * If an error occurs during the sort this
59 * is changed from TCL_OK to TCL_ERROR. */
60} SortInfo;
61
62/*
63 * The "sortMode" field of the SortInfo structure can take on any of the
64 * following values.
65 */
66
67#define SORTMODE_ASCII 0
68#define SORTMODE_INTEGER 1
69#define SORTMODE_REAL 2
70#define SORTMODE_COMMAND 3
71#define SORTMODE_DICTIONARY 4
72
73/*
74 * Forward declarations for procedures defined in this file:
75 */
76
77static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
78 Tcl_Obj *listPtr, char *pattern,
79 int includeLinks));
80static int DictionaryCompare _ANSI_ARGS_((char *left,
81 char *right));
82static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
83 Tcl_Interp *interp, int objc,
84 Tcl_Obj *CONST objv[]));
85static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
86 Tcl_Interp *interp, int objc,
87 Tcl_Obj *CONST objv[]));
88static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
89 Tcl_Interp *interp, int objc,
90 Tcl_Obj *CONST objv[]));
91static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
92 Tcl_Interp *interp, int objc,
93 Tcl_Obj *CONST objv[]));
94static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
95 Tcl_Interp *interp, int objc,
96 Tcl_Obj *CONST objv[]));
97static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
98 Tcl_Interp *interp, int objc,
99 Tcl_Obj *CONST objv[]));
100static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
101 Tcl_Interp *interp, int objc,
102 Tcl_Obj *CONST objv[]));
103static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
104 Tcl_Interp *interp, int objc,
105 Tcl_Obj *CONST objv[]));
106static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
107 Tcl_Interp *interp, int objc,
108 Tcl_Obj *CONST objv[]));
109static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
110 Tcl_Interp *interp, int objc,
111 Tcl_Obj *CONST objv[]));
112static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
113 Tcl_Interp *interp, int objc,
114 Tcl_Obj *CONST objv[]));
115static int InfoNameOfExecutableCmd _ANSI_ARGS_((
116 ClientData dummy, Tcl_Interp *interp, int objc,
117 Tcl_Obj *CONST objv[]));
118static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
119 Tcl_Interp *interp, int objc,
120 Tcl_Obj *CONST objv[]));
121static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
122 Tcl_Interp *interp, int objc,
123 Tcl_Obj *CONST objv[]));
124static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
125 Tcl_Interp *interp, int objc,
126 Tcl_Obj *CONST objv[]));
127static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
128 Tcl_Interp *interp, int objc,
129 Tcl_Obj *CONST objv[]));
130static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
131 Tcl_Interp *interp, int objc,
132 Tcl_Obj *CONST objv[]));
133static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
134 Tcl_Interp *interp, int objc,
135 Tcl_Obj *CONST objv[]));
136static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
137 SortInfo *infoPtr));
138static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
139 SortElement *rightPtr, SortInfo *infoPtr));
140static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
141 Tcl_Obj *second, SortInfo *infoPtr));
142
143
144/*
145 *----------------------------------------------------------------------
146 *
147 * Tcl_IfCmd --
148 *
149 * This procedure is invoked to process the "if" Tcl command.
150 * See the user documentation for details on what it does.
151 *
152 * With the bytecode compiler, this procedure is only called when
153 * a command name is computed at runtime, and is "if" or the name
154 * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
155 *
156 * Results:
157 * A standard Tcl result.
158 *
159 * Side effects:
160 * See the user documentation.
161 *
162 *----------------------------------------------------------------------
163 */
164
165 /* ARGSUSED */
166int
167Tcl_IfCmd(dummy, interp, argc, argv)
168 ClientData dummy; /* Not used. */
169 Tcl_Interp *interp; /* Current interpreter. */
170 int argc; /* Number of arguments. */
171 char **argv; /* Argument strings. */
172{
173 int i, result, value;
174
175 i = 1;
176 while (1) {
177 /*
178 * At this point in the loop, argv and argc refer to an expression
179 * to test, either for the main expression or an expression
180 * following an "elseif". The arguments after the expression must
181 * be "then" (optional) and a script to execute if the expression is
182 * true.
183 */
184
185 if (i >= argc) {
186 Tcl_AppendResult(interp, "wrong # args: no expression after \"",
187 argv[i-1], "\" argument", (char *) NULL);
188 return TCL_ERROR;
189 }
190 result = Tcl_ExprBoolean(interp, argv[i], &value);
191 if (result != TCL_OK) {
192 return result;
193 }
194 i++;
195 if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
196 i++;
197 }
198 if (i >= argc) {
199 Tcl_AppendResult(interp, "wrong # args: no script following \"",
200 argv[i-1], "\" argument", (char *) NULL);
201 return TCL_ERROR;
202 }
203 if (value) {
204 return Tcl_Eval(interp, argv[i]);
205 }
206
207 /*
208 * The expression evaluated to false. Skip the command, then
209 * see if there is an "else" or "elseif" clause.
210 */
211
212 i++;
213 if (i >= argc) {
214 return TCL_OK;
215 }
216 if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
217 i++;
218 continue;
219 }
220 break;
221 }
222
223 /*
224 * Couldn't find a "then" or "elseif" clause to execute. Check now
225 * for an "else" clause. We know that there's at least one more
226 * argument when we get here.
227 */
228
229 if (strcmp(argv[i], "else") == 0) {
230 i++;
231 if (i >= argc) {
232 Tcl_AppendResult(interp,
233 "wrong # args: no script following \"else\" argument",
234 (char *) NULL);
235 return TCL_ERROR;
236 }
237 }
238 return Tcl_Eval(interp, argv[i]);
239}
240
241
242/*
243 *----------------------------------------------------------------------
244 *
245 * Tcl_IncrCmd --
246 *
247 * This procedure is invoked to process the "incr" Tcl command.
248 * See the user documentation for details on what it does.
249 *
250 * With the bytecode compiler, this procedure is only called when
251 * a command name is computed at runtime, and is "incr" or the name
252 * to which "incr" was renamed: e.g., "set z incr; $z i -1"
253 *
254 * Results:
255 * A standard Tcl result.
256 *
257 * Side effects:
258 * See the user documentation.
259 *
260 *----------------------------------------------------------------------
261 */
262
263 /* ARGSUSED */
264int
265Tcl_IncrCmd(dummy, interp, argc, argv)
266 ClientData dummy; /* Not used. */
267 Tcl_Interp *interp; /* Current interpreter. */
268 int argc; /* Number of arguments. */
269 char **argv; /* Argument strings. */
270{
271 int value;
272 char *oldString, *result;
273 char newString[30];
274
275 if ((argc != 2) && (argc != 3)) {
276 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
277 " varName ?increment?\"", (char *) NULL);
278 return TCL_ERROR;
279 }
280
281 oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
282 if (oldString == NULL) {
283 return TCL_ERROR;
284 }
285 if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
286 Tcl_AddErrorInfo(interp,
287 "\n (reading value of variable to increment)");
288 return TCL_ERROR;
289 }
290 if (argc == 2) {
291 value += 1;
292 } else {
293 int increment;
294
295 if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
296 Tcl_AddErrorInfo(interp,
297 "\n (reading increment)");
298 return TCL_ERROR;
299 }
300 value += increment;
301 }
302 TclFormatInt(newString, value);
303 result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
304 if (result == NULL) {
305 return TCL_ERROR;
306 }
307
308 /*
309 * Copy the result since the variable's value might change.
310 */
311
312 Tcl_SetResult(interp, result, TCL_VOLATILE);
313 return TCL_OK;
314}
315
316
317/*
318 *----------------------------------------------------------------------
319 *
320 * Tcl_InfoObjCmd --
321 *
322 * This procedure is invoked to process the "info" Tcl command.
323 * See the user documentation for details on what it does.
324 *
325 * Results:
326 * A standard Tcl result.
327 *
328 * Side effects:
329 * See the user documentation.
330 *
331 *----------------------------------------------------------------------
332 */
333
334 /* ARGSUSED */
335int
336Tcl_InfoObjCmd(clientData, interp, objc, objv)
337 ClientData clientData; /* Arbitrary value passed to the command. */
338 Tcl_Interp *interp; /* Current interpreter. */
339 int objc; /* Number of arguments. */
340 Tcl_Obj *CONST objv[]; /* Argument objects. */
341{
342 static char *subCmds[] = {
343 "args", "body", "cmdcount", "commands",
344 "complete", "default", "exists", "globals",
345 "level", "library",
346 "locals", "nameofexecutable", "patchlevel", "procs",
347 "script", "sharedlibextension", "tclversion", "vars",
348 (char *) NULL};
349 enum ISubCmdIdx {
350 IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
351 ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
352 ILevelIdx, ILibraryIdx,
353 ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
354 IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
355 } index;
356 int result;
357
358 if (objc < 2) {
359 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
360 return TCL_ERROR;
361 }
362
363 result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
364 (int *) &index);
365 if (result != TCL_OK) {
366 return result;
367 }
368
369 switch (index) {
370 case IArgsIdx:
371 result = InfoArgsCmd(clientData, interp, objc, objv);
372 break;
373 case IBodyIdx:
374 result = InfoBodyCmd(clientData, interp, objc, objv);
375 break;
376 case ICmdCountIdx:
377 result = InfoCmdCountCmd(clientData, interp, objc, objv);
378 break;
379 case ICommandsIdx:
380 result = InfoCommandsCmd(clientData, interp, objc, objv);
381 break;
382 case ICompleteIdx:
383 result = InfoCompleteCmd(clientData, interp, objc, objv);
384 break;
385 case IDefaultIdx:
386 result = InfoDefaultCmd(clientData, interp, objc, objv);
387 break;
388 case IExistsIdx:
389 result = InfoExistsCmd(clientData, interp, objc, objv);
390 break;
391 case IGlobalsIdx:
392 result = InfoGlobalsCmd(clientData, interp, objc, objv);
393 break;
394 case ILevelIdx:
395 result = InfoLevelCmd(clientData, interp, objc, objv);
396 break;
397 case ILibraryIdx:
398 result = InfoLibraryCmd(clientData, interp, objc, objv);
399 break;
400 case ILocalsIdx:
401 result = InfoLocalsCmd(clientData, interp, objc, objv);
402 break;
403 case INameOfExecutableIdx:
404 result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
405 break;
406 case IPatchLevelIdx:
407 result = InfoPatchLevelCmd(clientData, interp, objc, objv);
408 break;
409 case IProcsIdx:
410 result = InfoProcsCmd(clientData, interp, objc, objv);
411 break;
412 case IScriptIdx:
413 result = InfoScriptCmd(clientData, interp, objc, objv);
414 break;
415 case ISharedLibExtensionIdx:
416 result = InfoSharedlibCmd(clientData, interp, objc, objv);
417 break;
418 case ITclVersionIdx:
419 result = InfoTclVersionCmd(clientData, interp, objc, objv);
420 break;
421 case IVarsIdx:
422 result = InfoVarsCmd(clientData, interp, objc, objv);
423 break;
424 }
425 return result;
426}
427
428
429/*
430 *----------------------------------------------------------------------
431 *
432 * InfoArgsCmd --
433 *
434 * Called to implement the "info args" command that returns the
435 * argument list for a procedure. Handles the following syntax:
436 *
437 * info args procName
438 *
439 * Results:
440 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
441 *
442 * Side effects:
443 * Returns a result in the interpreter's result object. If there is
444 * an error, the result is an error message.
445 *
446 *----------------------------------------------------------------------
447 */
448
449static int
450InfoArgsCmd(dummy, interp, objc, objv)
451 ClientData dummy; /* Not used. */
452 Tcl_Interp *interp; /* Current interpreter. */
453 int objc; /* Number of arguments. */
454 Tcl_Obj *CONST objv[]; /* Argument objects. */
455{
456 register Interp *iPtr = (Interp *) interp;
457 char *name;
458 Proc *procPtr;
459 CompiledLocal *localPtr;
460 Tcl_Obj *listObjPtr;
461
462 if (objc != 3) {
463 Tcl_WrongNumArgs(interp, 2, objv, "procname");
464 return TCL_ERROR;
465 }
466
467 name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
468 procPtr = TclFindProc(iPtr, name);
469 if (procPtr == NULL) {
470 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
471 "\"", name, "\" isn't a procedure", (char *) NULL);
472 return TCL_ERROR;
473 }
474
475 /*
476 * Build a return list containing the arguments.
477 */
478
479 listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
480 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
481 localPtr = localPtr->nextPtr) {
482 if (TclIsVarArgument(localPtr)) {
483 Tcl_ListObjAppendElement(interp, listObjPtr,
484 Tcl_NewStringObj(localPtr->name, -1));
485 }
486 }
487 Tcl_SetObjResult(interp, listObjPtr);
488 return TCL_OK;
489}
490
491
492/*
493 *----------------------------------------------------------------------
494 *
495 * InfoBodyCmd --
496 *
497 * Called to implement the "info body" command that returns the body
498 * for a procedure. Handles the following syntax:
499 *
500 * info body procName
501 *
502 * Results:
503 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
504 *
505 * Side effects:
506 * Returns a result in the interpreter's result object. If there is
507 * an error, the result is an error message.
508 *
509 *----------------------------------------------------------------------
510 */
511
512static int
513InfoBodyCmd(dummy, interp, objc, objv)
514 ClientData dummy; /* Not used. */
515 Tcl_Interp *interp; /* Current interpreter. */
516 int objc; /* Number of arguments. */
517 Tcl_Obj *CONST objv[]; /* Argument objects. */
518{
519 register Interp *iPtr = (Interp *) interp;
520 char *name;
521 Proc *procPtr;
522 Tcl_Obj *bodyPtr, *resultPtr;
523
524 if (objc != 3) {
525 Tcl_WrongNumArgs(interp, 2, objv, "procname");
526 return TCL_ERROR;
527 }
528
529 name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
530 procPtr = TclFindProc(iPtr, name);
531 if (procPtr == NULL) {
532 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
533 "\"", name, "\" isn't a procedure", (char *) NULL);
534 return TCL_ERROR;
535 }
536
537 /*
538 * we need to check if the body from this procedure had been generated
539 * from a precompiled body. If that is the case, then the bodyPtr's
540 * string representation is bogus, since sources are not available.
541 * In order to make sure that later manipulations of the object do not
542 * invalidate the internal representation, we make a copy of the string
543 * representation and return that one, instead.
544 */
545
546 bodyPtr = procPtr->bodyPtr;
547 resultPtr = bodyPtr;
548 if (bodyPtr->typePtr == &tclByteCodeType) {
549 ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
550
551 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
552 resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
553 }
554 }
555
556 Tcl_SetObjResult(interp, resultPtr);
557 return TCL_OK;
558}
559
560
561/*
562 *----------------------------------------------------------------------
563 *
564 * InfoCmdCountCmd --
565 *
566 * Called to implement the "info cmdcount" command that returns the
567 * number of commands that have been executed. Handles the following
568 * syntax:
569 *
570 * info cmdcount
571 *
572 * Results:
573 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
574 *
575 * Side effects:
576 * Returns a result in the interpreter's result object. If there is
577 * an error, the result is an error message.
578 *
579 *----------------------------------------------------------------------
580 */
581
582static int
583InfoCmdCountCmd(dummy, interp, objc, objv)
584 ClientData dummy; /* Not used. */
585 Tcl_Interp *interp; /* Current interpreter. */
586 int objc; /* Number of arguments. */
587 Tcl_Obj *CONST objv[]; /* Argument objects. */
588{
589 Interp *iPtr = (Interp *) interp;
590
591 if (objc != 2) {
592 Tcl_WrongNumArgs(interp, 2, objv, NULL);
593 return TCL_ERROR;
594 }
595
596 Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
597 return TCL_OK;
598}
599
600
601/*
602 *----------------------------------------------------------------------
603 *
604 * InfoCommandsCmd --
605 *
606 * Called to implement the "info commands" command that returns the
607 * list of commands in the interpreter that match an optional pattern.
608 * The pattern, if any, consists of an optional sequence of namespace
609 * names separated by "::" qualifiers, which is followed by a
610 * glob-style pattern that restricts which commands are returned.
611 * Handles the following syntax:
612 *
613 * info commands ?pattern?
614 *
615 * Results:
616 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
617 *
618 * Side effects:
619 * Returns a result in the interpreter's result object. If there is
620 * an error, the result is an error message.
621 *
622 *----------------------------------------------------------------------
623 */
624
625static int
626InfoCommandsCmd(dummy, interp, objc, objv)
627 ClientData dummy; /* Not used. */
628 Tcl_Interp *interp; /* Current interpreter. */
629 int objc; /* Number of arguments. */
630 Tcl_Obj *CONST objv[]; /* Argument objects. */
631{
632 char *cmdName, *pattern, *simplePattern;
633 register Tcl_HashEntry *entryPtr;
634 Tcl_HashSearch search;
635 Namespace *nsPtr;
636 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
637 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
638 Tcl_Obj *listPtr, *elemObjPtr;
639 int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
640 Tcl_Command cmd;
641
642 /*
643 * Get the pattern and find the "effective namespace" in which to
644 * list commands.
645 */
646
647 if (objc == 2) {
648 simplePattern = NULL;
649 nsPtr = currNsPtr;
650 specificNsInPattern = 0;
651 } else if (objc == 3) {
652 /*
653 * From the pattern, get the effective namespace and the simple
654 * pattern (no namespace qualifiers or ::'s) at the end. If an
655 * error was found while parsing the pattern, return it. Otherwise,
656 * if the namespace wasn't found, just leave nsPtr NULL: we will
657 * return an empty list since no commands there can be found.
658 */
659
660 Namespace *dummy1NsPtr, *dummy2NsPtr;
661
662 pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
663 TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
664 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
665
666 if (nsPtr != NULL) { /* we successfully found the pattern's ns */
667 specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
668 }
669 } else {
670 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
671 return TCL_ERROR;
672 }
673
674 /*
675 * Scan through the effective namespace's command table and create a
676 * list with all commands that match the pattern. If a specific
677 * namespace was requested in the pattern, qualify the command names
678 * with the namespace name.
679 */
680
681 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
682
683 if (nsPtr != NULL) {
684 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
685 while (entryPtr != NULL) {
686 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
687 if ((simplePattern == NULL)
688 || Tcl_StringMatch(cmdName, simplePattern)) {
689 if (specificNsInPattern) {
690 cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
691 elemObjPtr = Tcl_NewObj();
692 Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
693 } else {
694 elemObjPtr = Tcl_NewStringObj(cmdName, -1);
695 }
696 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
697 }
698 entryPtr = Tcl_NextHashEntry(&search);
699 }
700
701 /*
702 * If the effective namespace isn't the global :: namespace, and a
703 * specific namespace wasn't requested in the pattern, then add in
704 * all global :: commands that match the simple pattern. Of course,
705 * we add in only those commands that aren't hidden by a command in
706 * the effective namespace.
707 */
708
709 if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
710 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
711 while (entryPtr != NULL) {
712 cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
713 if ((simplePattern == NULL)
714 || Tcl_StringMatch(cmdName, simplePattern)) {
715 if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
716 Tcl_ListObjAppendElement(interp, listPtr,
717 Tcl_NewStringObj(cmdName, -1));
718 }
719 }
720 entryPtr = Tcl_NextHashEntry(&search);
721 }
722 }
723 }
724
725 Tcl_SetObjResult(interp, listPtr);
726 return TCL_OK;
727}
728
729
730/*
731 *----------------------------------------------------------------------
732 *
733 * InfoCompleteCmd --
734 *
735 * Called to implement the "info complete" command that determines
736 * whether a string is a complete Tcl command. Handles the following
737 * syntax:
738 *
739 * info complete command
740 *
741 * Results:
742 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
743 *
744 * Side effects:
745 * Returns a result in the interpreter's result object. If there is
746 * an error, the result is an error message.
747 *
748 *----------------------------------------------------------------------
749 */
750
751static int
752InfoCompleteCmd(dummy, interp, objc, objv)
753 ClientData dummy; /* Not used. */
754 Tcl_Interp *interp; /* Current interpreter. */
755 int objc; /* Number of arguments. */
756 Tcl_Obj *CONST objv[]; /* Argument objects. */
757{
758 if (objc != 3) {
759 Tcl_WrongNumArgs(interp, 2, objv, "command");
760 return TCL_ERROR;
761 }
762
763 if (TclObjCommandComplete(objv[2])) {
764 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
765 } else {
766 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
767 }
768
769 return TCL_OK;
770}
771
772
773/*
774 *----------------------------------------------------------------------
775 *
776 * InfoDefaultCmd --
777 *
778 * Called to implement the "info default" command that returns the
779 * default value for a procedure argument. Handles the following
780 * syntax:
781 *
782 * info default procName arg varName
783 *
784 * Results:
785 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
786 *
787 * Side effects:
788 * Returns a result in the interpreter's result object. If there is
789 * an error, the result is an error message.
790 *
791 *----------------------------------------------------------------------
792 */
793
794static int
795InfoDefaultCmd(dummy, interp, objc, objv)
796 ClientData dummy; /* Not used. */
797 Tcl_Interp *interp; /* Current interpreter. */
798 int objc; /* Number of arguments. */
799 Tcl_Obj *CONST objv[]; /* Argument objects. */
800{
801 Interp *iPtr = (Interp *) interp;
802 char *procName, *argName, *varName;
803 Proc *procPtr;
804 CompiledLocal *localPtr;
805 Tcl_Obj *valueObjPtr;
806
807 if (objc != 5) {
808 Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
809 return TCL_ERROR;
810 }
811
812 procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
813 argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
814
815 procPtr = TclFindProc(iPtr, procName);
816 if (procPtr == NULL) {
817 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
818 "\"", procName, "\" isn't a procedure", (char *) NULL);
819 return TCL_ERROR;
820 }
821
822 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
823 localPtr = localPtr->nextPtr) {
824 if (TclIsVarArgument(localPtr)
825 && (strcmp(argName, localPtr->name) == 0)) {
826 if (localPtr->defValuePtr != NULL) {
827 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
828 localPtr->defValuePtr, 0);
829 if (valueObjPtr == NULL) {
830 defStoreError:
831 varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
832 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
833 "couldn't store default value in variable \"",
834 varName, "\"", (char *) NULL);
835 return TCL_ERROR;
836 }
837 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
838 } else {
839 Tcl_Obj *nullObjPtr = Tcl_NewObj();
840 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
841 nullObjPtr, 0);
842 if (valueObjPtr == NULL) {
843 Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
844 goto defStoreError;
845 }
846 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
847 }
848 return TCL_OK;
849 }
850 }
851
852 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
853 "procedure \"", procName, "\" doesn't have an argument \"",
854 argName, "\"", (char *) NULL);
855 return TCL_ERROR;
856}
857
858
859/*
860 *----------------------------------------------------------------------
861 *
862 * InfoExistsCmd --
863 *
864 * Called to implement the "info exists" command that determines
865 * whether a variable exists. Handles the following syntax:
866 *
867 * info exists varName
868 *
869 * Results:
870 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
871 *
872 * Side effects:
873 * Returns a result in the interpreter's result object. If there is
874 * an error, the result is an error message.
875 *
876 *----------------------------------------------------------------------
877 */
878
879static int
880InfoExistsCmd(dummy, interp, objc, objv)
881 ClientData dummy; /* Not used. */
882 Tcl_Interp *interp; /* Current interpreter. */
883 int objc; /* Number of arguments. */
884 Tcl_Obj *CONST objv[]; /* Argument objects. */
885{
886 char *varName;
887 Var *varPtr, *arrayPtr;
888
889 if (objc != 3) {
890 Tcl_WrongNumArgs(interp, 2, objv, "varName");
891 return TCL_ERROR;
892 }
893
894 varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
895 varPtr = TclLookupVar(interp, varName, (char *) NULL,
896 TCL_PARSE_PART1, "access",
897 /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
898 if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
899 Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
900 } else {
901 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
902 }
903 return TCL_OK;
904}
905
906
907/*
908 *----------------------------------------------------------------------
909 *
910 * InfoGlobalsCmd --
911 *
912 * Called to implement the "info globals" command that returns the list
913 * of global variables matching an optional pattern. Handles the
914 * following syntax:
915 *
916 * info globals ?pattern?
917 *
918 * Results:
919 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
920 *
921 * Side effects:
922 * Returns a result in the interpreter's result object. If there is
923 * an error, the result is an error message.
924 *
925 *----------------------------------------------------------------------
926 */
927
928static int
929InfoGlobalsCmd(dummy, interp, objc, objv)
930 ClientData dummy; /* Not used. */
931 Tcl_Interp *interp; /* Current interpreter. */
932 int objc; /* Number of arguments. */
933 Tcl_Obj *CONST objv[]; /* Argument objects. */
934{
935 char *varName, *pattern;
936 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
937 register Tcl_HashEntry *entryPtr;
938 Tcl_HashSearch search;
939 Var *varPtr;
940 Tcl_Obj *listPtr;
941
942 if (objc == 2) {
943 pattern = NULL;
944 } else if (objc == 3) {
945 pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
946 } else {
947 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
948 return TCL_ERROR;
949 }
950
951 /*
952 * Scan through the global :: namespace's variable table and create a
953 * list of all global variables that match the pattern.
954 */
955
956 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
957 for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
958 entryPtr != NULL;
959 entryPtr = Tcl_NextHashEntry(&search)) {
960 varPtr = (Var *) Tcl_GetHashValue(entryPtr);
961 if (TclIsVarUndefined(varPtr)) {
962 continue;
963 }
964 varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
965 if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
966 Tcl_ListObjAppendElement(interp, listPtr,
967 Tcl_NewStringObj(varName, -1));
968 }
969 }
970 Tcl_SetObjResult(interp, listPtr);
971 return TCL_OK;
972}
973
974/*
975 *----------------------------------------------------------------------
976 *
977 * InfoLevelCmd --
978 *
979 * Called to implement the "info level" command that returns
980 * information about the call stack. Handles the following syntax:
981 *
982 * info level ?number?
983 *
984 * Results:
985 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
986 *
987 * Side effects:
988 * Returns a result in the interpreter's result object. If there is
989 * an error, the result is an error message.
990 *
991 *----------------------------------------------------------------------
992 */
993
994static int
995InfoLevelCmd(dummy, interp, objc, objv)
996 ClientData dummy; /* Not used. */
997 Tcl_Interp *interp; /* Current interpreter. */
998 int objc; /* Number of arguments. */
999 Tcl_Obj *CONST objv[]; /* Argument objects. */
1000{
1001 Interp *iPtr = (Interp *) interp;
1002 int level;
1003 CallFrame *framePtr;
1004 Tcl_Obj *listPtr;
1005
1006 if (objc == 2) { /* just "info level" */
1007 if (iPtr->varFramePtr == NULL) {
1008 Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
1009 } else {
1010 Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
1011 }
1012 return TCL_OK;
1013 } else if (objc == 3) {
1014 if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
1015 return TCL_ERROR;
1016 }
1017 if (level <= 0) {
1018 if (iPtr->varFramePtr == NULL) {
1019 levelError:
1020 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1021 "bad level \"",
1022 Tcl_GetStringFromObj(objv[2], (int *) NULL),
1023 "\"", (char *) NULL);
1024 return TCL_ERROR;
1025 }
1026 level += iPtr->varFramePtr->level;
1027 }
1028 for (framePtr = iPtr->varFramePtr; framePtr != NULL;
1029 framePtr = framePtr->callerVarPtr) {
1030 if (framePtr->level == level) {
1031 break;
1032 }
1033 }
1034 if (framePtr == NULL) {
1035 goto levelError;
1036 }
1037
1038 listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
1039 Tcl_SetObjResult(interp, listPtr);
1040 return TCL_OK;
1041 }
1042
1043 Tcl_WrongNumArgs(interp, 2, objv, "?number?");
1044 return TCL_ERROR;
1045}
1046
1047
1048/*
1049 *----------------------------------------------------------------------
1050 *
1051 * InfoLibraryCmd --
1052 *
1053 * Called to implement the "info library" command that returns the
1054 * library directory for the Tcl installation. Handles the following
1055 * syntax:
1056 *
1057 * info library
1058 *
1059 * Results:
1060 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1061 *
1062 * Side effects:
1063 * Returns a result in the interpreter's result object. If there is
1064 * an error, the result is an error message.
1065 *
1066 *----------------------------------------------------------------------
1067 */
1068
1069static int
1070InfoLibraryCmd(dummy, interp, objc, objv)
1071 ClientData dummy; /* Not used. */
1072 Tcl_Interp *interp; /* Current interpreter. */
1073 int objc; /* Number of arguments. */
1074 Tcl_Obj *CONST objv[]; /* Argument objects. */
1075{
1076 char *libDirName;
1077
1078 if (objc != 2) {
1079 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1080 return TCL_ERROR;
1081 }
1082
1083 libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
1084 if (libDirName != NULL) {
1085 Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
1086 return TCL_OK;
1087 }
1088 Tcl_SetStringObj(Tcl_GetObjResult(interp),
1089 "no library has been specified for Tcl", -1);
1090 return TCL_ERROR;
1091}
1092
1093
1094/*
1095 *----------------------------------------------------------------------
1096 *
1097 * InfoLocalsCmd --
1098 *
1099 * Called to implement the "info locals" command to return a list of
1100 * local variables that match an optional pattern. Handles the
1101 * following syntax:
1102 *
1103 * info locals ?pattern?
1104 *
1105 * Results:
1106 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1107 *
1108 * Side effects:
1109 * Returns a result in the interpreter's result object. If there is
1110 * an error, the result is an error message.
1111 *
1112 *----------------------------------------------------------------------
1113 */
1114
1115static int
1116InfoLocalsCmd(dummy, interp, objc, objv)
1117 ClientData dummy; /* Not used. */
1118 Tcl_Interp *interp; /* Current interpreter. */
1119 int objc; /* Number of arguments. */
1120 Tcl_Obj *CONST objv[]; /* Argument objects. */
1121{
1122 Interp *iPtr = (Interp *) interp;
1123 char *pattern;
1124 Tcl_Obj *listPtr;
1125
1126 if (objc == 2) {
1127 pattern = NULL;
1128 } else if (objc == 3) {
1129 pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
1130 } else {
1131 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1132 return TCL_ERROR;
1133 }
1134
1135 if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) {
1136 return TCL_OK;
1137 }
1138
1139 /*
1140 * Return a list containing names of first the compiled locals (i.e. the
1141 * ones stored in the call frame), then the variables in the local hash
1142 * table (if one exists).
1143 */
1144
1145 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1146 AppendLocals(interp, listPtr, pattern, 0);
1147 Tcl_SetObjResult(interp, listPtr);
1148 return TCL_OK;
1149}
1150
1151
1152/*
1153 *----------------------------------------------------------------------
1154 *
1155 * AppendLocals --
1156 *
1157 * Append the local variables for the current frame to the
1158 * specified list object.
1159 *
1160 * Results:
1161 * None.
1162 *
1163 * Side effects:
1164 * None.
1165 *
1166 *----------------------------------------------------------------------
1167 */
1168
1169static void
1170AppendLocals(interp, listPtr, pattern, includeLinks)
1171 Tcl_Interp *interp; /* Current interpreter. */
1172 Tcl_Obj *listPtr; /* List object to append names to. */
1173 char *pattern; /* Pattern to match against. */
1174 int includeLinks; /* 1 if upvars should be included, else 0. */
1175{
1176 Interp *iPtr = (Interp *) interp;
1177 CompiledLocal *localPtr;
1178 Var *varPtr;
1179 int i, localVarCt;
1180 char *varName;
1181 Tcl_HashTable *localVarTablePtr;
1182 register Tcl_HashEntry *entryPtr;
1183 Tcl_HashSearch search;
1184
1185 localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr;
1186 localVarCt = iPtr->varFramePtr->numCompiledLocals;
1187 varPtr = iPtr->varFramePtr->compiledLocals;
1188 localVarTablePtr = iPtr->varFramePtr->varTablePtr;
1189
1190 for (i = 0; i < localVarCt; i++) {
1191 /*
1192 * Skip nameless (temporary) variables and undefined variables
1193 */
1194
1195 if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
1196 varName = varPtr->name;
1197 if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
1198 Tcl_ListObjAppendElement(interp, listPtr,
1199 Tcl_NewStringObj(varName, -1));
1200 }
1201 }
1202 varPtr++;
1203 localPtr = localPtr->nextPtr;
1204 }
1205
1206 if (localVarTablePtr != NULL) {
1207 for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
1208 entryPtr != NULL;
1209 entryPtr = Tcl_NextHashEntry(&search)) {
1210 varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1211 if (!TclIsVarUndefined(varPtr)
1212 && (includeLinks || !TclIsVarLink(varPtr))) {
1213 varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
1214 if ((pattern == NULL)
1215 || Tcl_StringMatch(varName, pattern)) {
1216 Tcl_ListObjAppendElement(interp, listPtr,
1217 Tcl_NewStringObj(varName, -1));
1218 }
1219 }
1220 }
1221 }
1222}
1223
1224
1225/*
1226 *----------------------------------------------------------------------
1227 *
1228 * InfoNameOfExecutableCmd --
1229 *
1230 * Called to implement the "info nameofexecutable" command that returns
1231 * the name of the binary file running this application. Handles the
1232 * following syntax:
1233 *
1234 * info nameofexecutable
1235 *
1236 * Results:
1237 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1238 *
1239 * Side effects:
1240 * Returns a result in the interpreter's result object. If there is
1241 * an error, the result is an error message.
1242 *
1243 *----------------------------------------------------------------------
1244 */
1245
1246static int
1247InfoNameOfExecutableCmd(dummy, interp, objc, objv)
1248 ClientData dummy; /* Not used. */
1249 Tcl_Interp *interp; /* Current interpreter. */
1250 int objc; /* Number of arguments. */
1251 Tcl_Obj *CONST objv[]; /* Argument objects. */
1252{
1253 CONST char *nameOfExecutable;
1254
1255 if (objc != 2) {
1256 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1257 return TCL_ERROR;
1258 }
1259
1260 nameOfExecutable = Tcl_GetNameOfExecutable();
1261
1262 if (nameOfExecutable != NULL) {
1263 Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
1264 }
1265 return TCL_OK;
1266}
1267
1268
1269/*
1270 *----------------------------------------------------------------------
1271 *
1272 * InfoPatchLevelCmd --
1273 *
1274 * Called to implement the "info patchlevel" command that returns the
1275 * default value for an argument to a procedure. Handles the following
1276 * syntax:
1277 *
1278 * info patchlevel
1279 *
1280 * Results:
1281 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1282 *
1283 * Side effects:
1284 * Returns a result in the interpreter's result object. If there is
1285 * an error, the result is an error message.
1286 *
1287 *----------------------------------------------------------------------
1288 */
1289
1290static int
1291InfoPatchLevelCmd(dummy, interp, objc, objv)
1292 ClientData dummy; /* Not used. */
1293 Tcl_Interp *interp; /* Current interpreter. */
1294 int objc; /* Number of arguments. */
1295 Tcl_Obj *CONST objv[]; /* Argument objects. */
1296{
1297 char *patchlevel;
1298
1299 if (objc != 2) {
1300 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1301 return TCL_ERROR;
1302 }
1303
1304 patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
1305 (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1306 if (patchlevel != NULL) {
1307 Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
1308 return TCL_OK;
1309 }
1310 return TCL_ERROR;
1311}
1312
1313
1314/*
1315 *----------------------------------------------------------------------
1316 *
1317 * InfoProcsCmd --
1318 *
1319 * Called to implement the "info procs" command that returns the
1320 * procedures in the current namespace that match an optional pattern.
1321 * Handles the following syntax:
1322 *
1323 * info procs ?pattern?
1324 *
1325 * Results:
1326 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1327 *
1328 * Side effects:
1329 * Returns a result in the interpreter's result object. If there is
1330 * an error, the result is an error message.
1331 *
1332 *----------------------------------------------------------------------
1333 */
1334
1335static int
1336InfoProcsCmd(dummy, interp, objc, objv)
1337 ClientData dummy; /* Not used. */
1338 Tcl_Interp *interp; /* Current interpreter. */
1339 int objc; /* Number of arguments. */
1340 Tcl_Obj *CONST objv[]; /* Argument objects. */
1341{
1342 char *cmdName, *pattern;
1343 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1344 register Tcl_HashEntry *entryPtr;
1345 Tcl_HashSearch search;
1346 Command *cmdPtr;
1347 Tcl_Obj *listPtr;
1348
1349 if (objc == 2) {
1350 pattern = NULL;
1351 } else if (objc == 3) {
1352 pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
1353 } else {
1354 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1355 return TCL_ERROR;
1356 }
1357
1358 /*
1359 * Scan through the current namespace's command table and return a list
1360 * of all procs that match the pattern.
1361 */
1362
1363 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1364 for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
1365 entryPtr != NULL;
1366 entryPtr = Tcl_NextHashEntry(&search)) {
1367 cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
1368 cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1369 if (TclIsProc(cmdPtr)) {
1370 if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
1371 Tcl_ListObjAppendElement(interp, listPtr,
1372 Tcl_NewStringObj(cmdName, -1));
1373 }
1374 }
1375 }
1376 Tcl_SetObjResult(interp, listPtr);
1377 return TCL_OK;
1378}
1379
1380
1381/*
1382 *----------------------------------------------------------------------
1383 *
1384 * InfoScriptCmd --
1385 *
1386 * Called to implement the "info script" command that returns the
1387 * script file that is currently being evaluated. Handles the
1388 * following syntax:
1389 *
1390 * info script
1391 *
1392 * Results:
1393 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1394 *
1395 * Side effects:
1396 * Returns a result in the interpreter's result object. If there is
1397 * an error, the result is an error message.
1398 *
1399 *----------------------------------------------------------------------
1400 */
1401
1402static int
1403InfoScriptCmd(dummy, interp, objc, objv)
1404 ClientData dummy; /* Not used. */
1405 Tcl_Interp *interp; /* Current interpreter. */
1406 int objc; /* Number of arguments. */
1407 Tcl_Obj *CONST objv[]; /* Argument objects. */
1408{
1409 Interp *iPtr = (Interp *) interp;
1410 if (objc != 2) {
1411 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1412 return TCL_ERROR;
1413 }
1414
1415 if (iPtr->scriptFile != NULL) {
1416 Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
1417 }
1418 return TCL_OK;
1419}
1420
1421
1422/*
1423 *----------------------------------------------------------------------
1424 *
1425 * InfoSharedlibCmd --
1426 *
1427 * Called to implement the "info sharedlibextension" command that
1428 * returns the file extension used for shared libraries. Handles the
1429 * following syntax:
1430 *
1431 * info sharedlibextension
1432 *
1433 * Results:
1434 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1435 *
1436 * Side effects:
1437 * Returns a result in the interpreter's result object. If there is
1438 * an error, the result is an error message.
1439 *
1440 *----------------------------------------------------------------------
1441 */
1442
1443static int
1444InfoSharedlibCmd(dummy, interp, objc, objv)
1445 ClientData dummy; /* Not used. */
1446 Tcl_Interp *interp; /* Current interpreter. */
1447 int objc; /* Number of arguments. */
1448 Tcl_Obj *CONST objv[]; /* Argument objects. */
1449{
1450 if (objc != 2) {
1451 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1452 return TCL_ERROR;
1453 }
1454
1455#ifdef TCL_SHLIB_EXT
1456 Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
1457#endif
1458 return TCL_OK;
1459}
1460
1461
1462/*
1463 *----------------------------------------------------------------------
1464 *
1465 * InfoTclVersionCmd --
1466 *
1467 * Called to implement the "info tclversion" command that returns the
1468 * version number for this Tcl library. Handles the following syntax:
1469 *
1470 * info tclversion
1471 *
1472 * Results:
1473 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1474 *
1475 * Side effects:
1476 * Returns a result in the interpreter's result object. If there is
1477 * an error, the result is an error message.
1478 *
1479 *----------------------------------------------------------------------
1480 */
1481
1482static int
1483InfoTclVersionCmd(dummy, interp, objc, objv)
1484 ClientData dummy; /* Not used. */
1485 Tcl_Interp *interp; /* Current interpreter. */
1486 int objc; /* Number of arguments. */
1487 Tcl_Obj *CONST objv[]; /* Argument objects. */
1488{
1489 char *version;
1490
1491 if (objc != 2) {
1492 Tcl_WrongNumArgs(interp, 2, objv, NULL);
1493 return TCL_ERROR;
1494 }
1495
1496 version = Tcl_GetVar(interp, "tcl_version",
1497 (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
1498 if (version != NULL) {
1499 Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
1500 return TCL_OK;
1501 }
1502 return TCL_ERROR;
1503}
1504
1505
1506/*
1507 *----------------------------------------------------------------------
1508 *
1509 * InfoVarsCmd --
1510 *
1511 * Called to implement the "info vars" command that returns the
1512 * list of variables in the interpreter that match an optional pattern.
1513 * The pattern, if any, consists of an optional sequence of namespace
1514 * names separated by "::" qualifiers, which is followed by a
1515 * glob-style pattern that restricts which variables are returned.
1516 * Handles the following syntax:
1517 *
1518 * info vars ?pattern?
1519 *
1520 * Results:
1521 * Returns TCL_OK is successful and TCL_ERROR is there is an error.
1522 *
1523 * Side effects:
1524 * Returns a result in the interpreter's result object. If there is
1525 * an error, the result is an error message.
1526 *
1527 *----------------------------------------------------------------------
1528 */
1529
1530static int
1531InfoVarsCmd(dummy, interp, objc, objv)
1532 ClientData dummy; /* Not used. */
1533 Tcl_Interp *interp; /* Current interpreter. */
1534 int objc; /* Number of arguments. */
1535 Tcl_Obj *CONST objv[]; /* Argument objects. */
1536{
1537 Interp *iPtr = (Interp *) interp;
1538 char *varName, *pattern, *simplePattern;
1539 register Tcl_HashEntry *entryPtr;
1540 Tcl_HashSearch search;
1541 Var *varPtr;
1542 Namespace *nsPtr;
1543 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1544 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1545 Tcl_Obj *listPtr, *elemObjPtr;
1546 int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
1547
1548 /*
1549 * Get the pattern and find the "effective namespace" in which to
1550 * list variables. We only use this effective namespace if there's
1551 * no active Tcl procedure frame.
1552 */
1553
1554 if (objc == 2) {
1555 simplePattern = NULL;
1556 nsPtr = currNsPtr;
1557 specificNsInPattern = 0;
1558 } else if (objc == 3) {
1559 /*
1560 * From the pattern, get the effective namespace and the simple
1561 * pattern (no namespace qualifiers or ::'s) at the end. If an
1562 * error was found while parsing the pattern, return it. Otherwise,
1563 * if the namespace wasn't found, just leave nsPtr NULL: we will
1564 * return an empty list since no variables there can be found.
1565 */
1566
1567 Namespace *dummy1NsPtr, *dummy2NsPtr;
1568
1569 pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
1570 TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
1571 /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
1572
1573 if (nsPtr != NULL) { /* we successfully found the pattern's ns */
1574 specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
1575 }
1576 } else {
1577 Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
1578 return TCL_ERROR;
1579 }
1580
1581 /*
1582 * If the namespace specified in the pattern wasn't found, just return.
1583 */
1584
1585 if (nsPtr == NULL) {
1586 return TCL_OK;
1587 }
1588
1589 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1590
1591 if ((iPtr->varFramePtr == NULL)
1592 || !iPtr->varFramePtr->isProcCallFrame
1593 || specificNsInPattern) {
1594 /*
1595 * There is no frame pointer, the frame pointer was pushed only
1596 * to activate a namespace, or we are in a procedure call frame
1597 * but a specific namespace was specified. Create a list containing
1598 * only the variables in the effective namespace's variable table.
1599 */
1600
1601 entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
1602 while (entryPtr != NULL) {
1603 varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1604 if (!TclIsVarUndefined(varPtr)
1605 || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1606 varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
1607 if ((simplePattern == NULL)
1608 || Tcl_StringMatch(varName, simplePattern)) {
1609 if (specificNsInPattern) {
1610 elemObjPtr = Tcl_NewObj();
1611 Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
1612 elemObjPtr);
1613 } else {
1614 elemObjPtr = Tcl_NewStringObj(varName, -1);
1615 }
1616 Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
1617 }
1618 }
1619 entryPtr = Tcl_NextHashEntry(&search);
1620 }
1621
1622 /*
1623 * If the effective namespace isn't the global :: namespace, and a
1624 * specific namespace wasn't requested in the pattern (i.e., the
1625 * pattern only specifies variable names), then add in all global ::
1626 * variables that match the simple pattern. Of course, add in only
1627 * those variables that aren't hidden by a variable in the effective
1628 * namespace.
1629 */
1630
1631 if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
1632 entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
1633 while (entryPtr != NULL) {
1634 varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1635 if (!TclIsVarUndefined(varPtr)
1636 || (varPtr->flags & VAR_NAMESPACE_VAR)) {
1637 varName = Tcl_GetHashKey(&globalNsPtr->varTable,
1638 entryPtr);
1639 if ((simplePattern == NULL)
1640 || Tcl_StringMatch(varName, simplePattern)) {
1641 if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
1642 Tcl_ListObjAppendElement(interp, listPtr,
1643 Tcl_NewStringObj(varName, -1));
1644 }
1645 }
1646 }
1647 entryPtr = Tcl_NextHashEntry(&search);
1648 }
1649 }
1650 } else {
1651 AppendLocals(interp, listPtr, simplePattern, 1);
1652 }
1653
1654 Tcl_SetObjResult(interp, listPtr);
1655 return TCL_OK;
1656}
1657
1658
1659/*
1660 *----------------------------------------------------------------------
1661 *
1662 * Tcl_JoinObjCmd --
1663 *
1664 * This procedure is invoked to process the "join" Tcl command.
1665 * See the user documentation for details on what it does.
1666 *
1667 * Results:
1668 * A standard Tcl object result.
1669 *
1670 * Side effects:
1671 * See the user documentation.
1672 *
1673 *----------------------------------------------------------------------
1674 */
1675
1676 /* ARGSUSED */
1677int
1678Tcl_JoinObjCmd(dummy, interp, objc, objv)
1679 ClientData dummy; /* Not used. */
1680 Tcl_Interp *interp; /* Current interpreter. */
1681 int objc; /* Number of arguments. */
1682 Tcl_Obj *CONST objv[]; /* The argument objects. */
1683{
1684 char *joinString, *bytes;
1685 int joinLength, listLen, length, i, result;
1686 Tcl_Obj **elemPtrs;
1687 Tcl_Obj *resObjPtr;
1688
1689 if (objc == 2) {
1690 joinString = " ";
1691 joinLength = 1;
1692 } else if (objc == 3) {
1693 joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
1694 } else {
1695 Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
1696 return TCL_ERROR;
1697 }
1698
1699 /*
1700 * Make sure the list argument is a list object and get its length and
1701 * a pointer to its array of element pointers.
1702 */
1703
1704 result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
1705 if (result != TCL_OK) {
1706 return result;
1707 }
1708
1709 /*
1710 * Now concatenate strings to form the "joined" result. We append
1711 * directly into the interpreter's result object.
1712 */
1713
1714 resObjPtr = Tcl_GetObjResult(interp);
1715
1716 for (i = 0; i < listLen; i++) {
1717 bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
1718 if (i > 0) {
1719 Tcl_AppendToObj(resObjPtr, joinString, joinLength);
1720 }
1721 Tcl_AppendToObj(resObjPtr, bytes, length);
1722 }
1723 return TCL_OK;
1724}
1725
1726
1727/*
1728 *----------------------------------------------------------------------
1729 *
1730 * Tcl_LindexObjCmd --
1731 *
1732 * This object-based procedure is invoked to process the "lindex" Tcl
1733 * command. See the user documentation for details on what it does.
1734 *
1735 * Results:
1736 * A standard Tcl object result.
1737 *
1738 * Side effects:
1739 * See the user documentation.
1740 *
1741 *----------------------------------------------------------------------
1742 */
1743
1744 /* ARGSUSED */
1745int
1746Tcl_LindexObjCmd(dummy, interp, objc, objv)
1747 ClientData dummy; /* Not used. */
1748 Tcl_Interp *interp; /* Current interpreter. */
1749 int objc; /* Number of arguments. */
1750 Tcl_Obj *CONST objv[]; /* Argument objects. */
1751{
1752 Tcl_Obj *listPtr;
1753 Tcl_Obj **elemPtrs;
1754 int listLen, index, result;
1755
1756 if (objc != 3) {
1757 Tcl_WrongNumArgs(interp, 1, objv, "list index");
1758 return TCL_ERROR;
1759 }
1760
1761 /*
1762 * Convert the first argument to a list if necessary.
1763 */
1764
1765 listPtr = objv[1];
1766 result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
1767 if (result != TCL_OK) {
1768 return result;
1769 }
1770
1771 /*
1772 * Get the index from objv[2].
1773 */
1774
1775 result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
1776 &index);
1777 if (result != TCL_OK) {
1778 return result;
1779 }
1780 if ((index < 0) || (index >= listLen)) {
1781 /*
1782 * The index is out of range: the result is an empty string object.
1783 */
1784
1785 return TCL_OK;
1786 }
1787
1788 /*
1789 * Make sure listPtr still refers to a list object. It might have been
1790 * converted to an int above if the argument objects were shared.
1791 */
1792
1793 if (listPtr->typePtr != &tclListType) {
1794 result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
1795 &elemPtrs);
1796 if (result != TCL_OK) {
1797 return result;
1798 }
1799 }
1800
1801 /*
1802 * Set the interpreter's object result to the index-th list element.
1803 */
1804
1805 Tcl_SetObjResult(interp, elemPtrs[index]);
1806 return TCL_OK;
1807}
1808
1809
1810/*
1811 *----------------------------------------------------------------------
1812 *
1813 * Tcl_LinsertObjCmd --
1814 *
1815 * This object-based procedure is invoked to process the "linsert" Tcl
1816 * command. See the user documentation for details on what it does.
1817 *
1818 * Results:
1819 * A new Tcl list object formed by inserting zero or more elements
1820 * into a list.
1821 *
1822 * Side effects:
1823 * See the user documentation.
1824 *
1825 *----------------------------------------------------------------------
1826 */
1827
1828 /* ARGSUSED */
1829int
1830Tcl_LinsertObjCmd(dummy, interp, objc, objv)
1831 ClientData dummy; /* Not used. */
1832 Tcl_Interp *interp; /* Current interpreter. */
1833 register int objc; /* Number of arguments. */
1834 Tcl_Obj *CONST objv[]; /* Argument objects. */
1835{
1836 Tcl_Obj *listPtr, *resultPtr;
1837 Tcl_ObjType *typePtr;
1838 int index, isDuplicate, len, result;
1839
1840 if (objc < 4) {
1841 Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
1842 return TCL_ERROR;
1843 }
1844
1845 /*
1846 * Get the index first since, if a conversion to int is needed, it
1847 * will invalidate the list's internal representation.
1848 */
1849
1850 result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
1851 &index);
1852 if (result != TCL_OK) {
1853 return result;
1854 }
1855
1856 /*
1857 * If the list object is unshared we can modify it directly. Otherwise
1858 * we create a copy to modify: this is "copy on write". We create the
1859 * duplicate directly in the interpreter's object result.
1860 */
1861
1862 listPtr = objv[1];
1863 isDuplicate = 0;
1864 if (Tcl_IsShared(listPtr)) {
1865 /*
1866 * The following code must reflect the logic in Tcl_DuplicateObj()
1867 * except that it must duplicate the list object directly into the
1868 * interpreter's result.
1869 */
1870
1871 Tcl_ResetResult(interp);
1872 resultPtr = Tcl_GetObjResult(interp);
1873 typePtr = listPtr->typePtr;
1874 if (listPtr->bytes == NULL) {
1875 resultPtr->bytes = NULL;
1876 } else if (listPtr->bytes != tclEmptyStringRep) {
1877 len = listPtr->length;
1878 TclInitStringRep(resultPtr, listPtr->bytes, len);
1879 }
1880 if (typePtr != NULL) {
1881 if (typePtr->dupIntRepProc == NULL) {
1882 resultPtr->internalRep = listPtr->internalRep;
1883 resultPtr->typePtr = typePtr;
1884 } else {
1885 (*typePtr->dupIntRepProc)(listPtr, resultPtr);
1886 }
1887 }
1888 listPtr = resultPtr;
1889 isDuplicate = 1;
1890 }
1891
1892 if ((objc == 4) && (index == INT_MAX)) {
1893 /*
1894 * Special case: insert one element at the end of the list.
1895 */
1896
1897 result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
1898 } else if (objc > 3) {
1899 result = Tcl_ListObjReplace(interp, listPtr, index, 0,
1900 (objc-3), &(objv[3]));
1901 }
1902 if (result != TCL_OK) {
1903 return result;
1904 }
1905
1906 /*
1907 * Set the interpreter's object result.
1908 */
1909
1910 if (!isDuplicate) {
1911 Tcl_SetObjResult(interp, listPtr);
1912 }
1913 return TCL_OK;
1914}
1915
1916
1917/*
1918 *----------------------------------------------------------------------
1919 *
1920 * Tcl_ListObjCmd --
1921 *
1922 * This procedure is invoked to process the "list" Tcl command.
1923 * See the user documentation for details on what it does.
1924 *
1925 * Results:
1926 * A standard Tcl object result.
1927 *
1928 * Side effects:
1929 * See the user documentation.
1930 *
1931 *----------------------------------------------------------------------
1932 */
1933
1934 /* ARGSUSED */
1935int
1936Tcl_ListObjCmd(dummy, interp, objc, objv)
1937 ClientData dummy; /* Not used. */
1938 Tcl_Interp *interp; /* Current interpreter. */
1939 register int objc; /* Number of arguments. */
1940 register Tcl_Obj *CONST objv[]; /* The argument objects. */
1941{
1942 /*
1943 * If there are no list elements, the result is an empty object.
1944 * Otherwise modify the interpreter's result object to be a list object.
1945 */
1946
1947 if (objc > 1) {
1948 Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
1949 }
1950 return TCL_OK;
1951}
1952
1953
1954/*
1955 *----------------------------------------------------------------------
1956 *
1957 * Tcl_LlengthObjCmd --
1958 *
1959 * This object-based procedure is invoked to process the "llength" Tcl
1960 * command. See the user documentation for details on what it does.
1961 *
1962 * Results:
1963 * A standard Tcl object result.
1964 *
1965 * Side effects:
1966 * See the user documentation.
1967 *
1968 *----------------------------------------------------------------------
1969 */
1970
1971 /* ARGSUSED */
1972int
1973Tcl_LlengthObjCmd(dummy, interp, objc, objv)
1974 ClientData dummy; /* Not used. */
1975 Tcl_Interp *interp; /* Current interpreter. */
1976 int objc; /* Number of arguments. */
1977 register Tcl_Obj *CONST objv[]; /* Argument objects. */
1978{
1979 int listLen, result;
1980
1981 if (objc != 2) {
1982 Tcl_WrongNumArgs(interp, 1, objv, "list");
1983 return TCL_ERROR;
1984 }
1985
1986 result = Tcl_ListObjLength(interp, objv[1], &listLen);
1987 if (result != TCL_OK) {
1988 return result;
1989 }
1990
1991 /*
1992 * Set the interpreter's object result to an integer object holding the
1993 * length.
1994 */
1995
1996 Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
1997 return TCL_OK;
1998}
1999
2000
2001/*
2002 *----------------------------------------------------------------------
2003 *
2004 * Tcl_LrangeObjCmd --
2005 *
2006 * This procedure is invoked to process the "lrange" Tcl command.
2007 * See the user documentation for details on what it does.
2008 *
2009 * Results:
2010 * A standard Tcl object result.
2011 *
2012 * Side effects:
2013 * See the user documentation.
2014 *
2015 *----------------------------------------------------------------------
2016 */
2017
2018 /* ARGSUSED */
2019int
2020Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
2021 ClientData notUsed; /* Not used. */
2022 Tcl_Interp *interp; /* Current interpreter. */
2023 int objc; /* Number of arguments. */
2024 register Tcl_Obj *CONST objv[]; /* Argument objects. */
2025{
2026 Tcl_Obj *listPtr;
2027 Tcl_Obj **elemPtrs;
2028 int listLen, first, last, numElems, result;
2029
2030 if (objc != 4) {
2031 Tcl_WrongNumArgs(interp, 1, objv, "list first last");
2032 return TCL_ERROR;
2033 }
2034
2035 /*
2036 * Make sure the list argument is a list object and get its length and
2037 * a pointer to its array of element pointers.
2038 */
2039
2040 listPtr = objv[1];
2041 result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
2042 if (result != TCL_OK) {
2043 return result;
2044 }
2045
2046 /*
2047 * Get the first and last indexes.
2048 */
2049
2050 result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
2051 &first);
2052 if (result != TCL_OK) {
2053 return result;
2054 }
2055 if (first < 0) {
2056 first = 0;
2057 }
2058
2059 result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
2060 &last);
2061 if (result != TCL_OK) {
2062 return result;
2063 }
2064 if (last >= listLen) {
2065 last = (listLen - 1);
2066 }
2067
2068 if (first > last) {
2069 return TCL_OK; /* the result is an empty object */
2070 }
2071
2072 /*
2073 * Make sure listPtr still refers to a list object. It might have been
2074 * converted to an int above if the argument objects were shared.
2075 */
2076
2077 if (listPtr->typePtr != &tclListType) {
2078 result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
2079 &elemPtrs);
2080 if (result != TCL_OK) {
2081 return result;
2082 }
2083 }
2084
2085 /*
2086 * Extract a range of fields. We modify the interpreter's result object
2087 * to be a list object containing the specified elements.
2088 */
2089
2090 numElems = (last - first + 1);
2091 Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
2092 return TCL_OK;
2093}
2094
2095
2096/*
2097 *----------------------------------------------------------------------
2098 *
2099 * Tcl_LreplaceObjCmd --
2100 *
2101 * This object-based procedure is invoked to process the "lreplace"
2102 * Tcl command. See the user documentation for details on what it does.
2103 *
2104 * Results:
2105 * A new Tcl list object formed by replacing zero or more elements of
2106 * a list.
2107 *
2108 * Side effects:
2109 * See the user documentation.
2110 *
2111 *----------------------------------------------------------------------
2112 */
2113
2114 /* ARGSUSED */
2115int
2116Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
2117 ClientData dummy; /* Not used. */
2118 Tcl_Interp *interp; /* Current interpreter. */
2119 int objc; /* Number of arguments. */
2120 Tcl_Obj *CONST objv[]; /* Argument objects. */
2121{
2122 register Tcl_Obj *listPtr;
2123 int createdNewObj, first, last, listLen, numToDelete;
2124 int firstArgLen, result;
2125 char *firstArg;
2126
2127 if (objc < 4) {
2128 Tcl_WrongNumArgs(interp, 1, objv,
2129 "list first last ?element element ...?");
2130 return TCL_ERROR;
2131 }
2132
2133 /*
2134 * If the list object is unshared we can modify it directly, otherwise
2135 * we create a copy to modify: this is "copy on write".
2136 */
2137
2138 listPtr = objv[1];
2139 createdNewObj = 0;
2140 if (Tcl_IsShared(listPtr)) {
2141 listPtr = Tcl_DuplicateObj(listPtr);
2142 createdNewObj = 1;
2143 }
2144 result = Tcl_ListObjLength(interp, listPtr, &listLen);
2145 if (result != TCL_OK) {
2146 errorReturn:
2147 if (createdNewObj) {
2148 Tcl_DecrRefCount(listPtr); /* free unneeded obj */
2149 }
2150 return result;
2151 }
2152
2153 /*
2154 * Get the first and last indexes.
2155 */
2156
2157 result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
2158 &first);
2159 if (result != TCL_OK) {
2160 goto errorReturn;
2161 }
2162 firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
2163
2164 result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
2165 &last);
2166 if (result != TCL_OK) {
2167 goto errorReturn;
2168 }
2169
2170 if (first < 0) {
2171 first = 0;
2172 }
2173 if ((first >= listLen) && (listLen > 0)
2174 && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
2175 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2176 "list doesn't contain element ",
2177 Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
2178 result = TCL_ERROR;
2179 goto errorReturn;
2180 }
2181 if (last >= listLen) {
2182 last = (listLen - 1);
2183 }
2184 if (first <= last) {
2185 numToDelete = (last - first + 1);
2186 } else {
2187 numToDelete = 0;
2188 }
2189
2190 if (objc > 4) {
2191 result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
2192 (objc-4), &(objv[4]));
2193 } else {
2194 result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
2195 0, NULL);
2196 }
2197 if (result != TCL_OK) {
2198 goto errorReturn;
2199 }
2200
2201 /*
2202 * Set the interpreter's object result.
2203 */
2204
2205 Tcl_SetObjResult(interp, listPtr);
2206 return TCL_OK;
2207}
2208
2209/*
2210 *----------------------------------------------------------------------
2211 *
2212 * Tcl_LsortObjCmd --
2213 *
2214 * This procedure is invoked to process the "lsort" Tcl command.
2215 * See the user documentation for details on what it does.
2216 *
2217 * Results:
2218 * A standard Tcl result.
2219 *
2220 * Side effects:
2221 * See the user documentation.
2222 *
2223 *----------------------------------------------------------------------
2224 */
2225
2226int
2227Tcl_LsortObjCmd(clientData, interp, objc, objv)
2228 ClientData clientData; /* Not used. */
2229 Tcl_Interp *interp; /* Current interpreter. */
2230 int objc; /* Number of arguments. */
2231 Tcl_Obj *CONST objv[]; /* Argument values. */
2232{
2233 int i, index, dummy;
2234 Tcl_Obj *resultPtr;
2235 int length;
2236 Tcl_Obj *cmdPtr, **listObjPtrs;
2237 SortElement *elementArray;
2238 SortElement *elementPtr;
2239 SortInfo sortInfo; /* Information about this sort that
2240 * needs to be passed to the
2241 * comparison function */
2242 static char *switches[] =
2243 {"-ascii", "-command", "-decreasing", "-dictionary",
2244 "-increasing", "-index", "-integer", "-real", (char *) NULL};
2245
2246 resultPtr = Tcl_GetObjResult(interp);
2247 if (objc < 2) {
2248 Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
2249 return TCL_ERROR;
2250 }
2251
2252 /*
2253 * Parse arguments to set up the mode for the sort.
2254 */
2255
2256 sortInfo.isIncreasing = 1;
2257 sortInfo.sortMode = SORTMODE_ASCII;
2258 sortInfo.index = -1;
2259 sortInfo.interp = interp;
2260 sortInfo.resultCode = TCL_OK;
2261 cmdPtr = NULL;
2262 for (i = 1; i < objc-1; i++) {
2263 if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
2264 != TCL_OK) {
2265 return TCL_ERROR;
2266 }
2267 switch (index) {
2268 case 0: /* -ascii */
2269 sortInfo.sortMode = SORTMODE_ASCII;
2270 break;
2271 case 1: /* -command */
2272 if (i == (objc-2)) {
2273 Tcl_AppendToObj(resultPtr,
2274 "\"-command\" option must be followed by comparison command",
2275 -1);
2276 return TCL_ERROR;
2277 }
2278 sortInfo.sortMode = SORTMODE_COMMAND;
2279 cmdPtr = objv[i+1];
2280 i++;
2281 break;
2282 case 2: /* -decreasing */
2283 sortInfo.isIncreasing = 0;
2284 break;
2285 case 3: /* -dictionary */
2286 sortInfo.sortMode = SORTMODE_DICTIONARY;
2287 break;
2288 case 4: /* -increasing */
2289 sortInfo.isIncreasing = 1;
2290 break;
2291 case 5: /* -index */
2292 if (i == (objc-2)) {
2293 Tcl_AppendToObj(resultPtr,
2294 "\"-index\" option must be followed by list index",
2295 -1);
2296 return TCL_ERROR;
2297 }
2298 if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
2299 != TCL_OK) {
2300 return TCL_ERROR;
2301 }
2302 cmdPtr = objv[i+1];
2303 i++;
2304 break;
2305 case 6: /* -integer */
2306 sortInfo.sortMode = SORTMODE_INTEGER;
2307 break;
2308 case 7: /* -real */
2309 sortInfo.sortMode = SORTMODE_REAL;
2310 break;
2311 }
2312 }
2313 if (sortInfo.sortMode == SORTMODE_COMMAND) {
2314 Tcl_DStringInit(&sortInfo.compareCmd);
2315 Tcl_DStringAppend(&sortInfo.compareCmd,
2316 Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
2317 }
2318
2319 sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
2320 &length, &listObjPtrs);
2321 if (sortInfo.resultCode != TCL_OK) {
2322 goto done;
2323 }
2324 if (length <= 0) {
2325 return TCL_OK;
2326 }
2327 elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
2328 for (i=0; i < length; i++){
2329 elementArray[i].objPtr = listObjPtrs[i];
2330 elementArray[i].nextPtr = &elementArray[i+1];
2331 }
2332 elementArray[length-1].nextPtr = NULL;
2333 elementPtr = MergeSort(elementArray, &sortInfo);
2334 if (sortInfo.resultCode == TCL_OK) {
2335 /*
2336 * Note: must clear the interpreter's result object: it could
2337 * have been set by the -command script.
2338 */
2339
2340 Tcl_ResetResult(interp);
2341 resultPtr = Tcl_GetObjResult(interp);
2342 for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
2343 Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
2344 }
2345 }
2346 ckfree((char*) elementArray);
2347
2348 done:
2349 if (sortInfo.sortMode == SORTMODE_COMMAND) {
2350 Tcl_DStringFree(&sortInfo.compareCmd);
2351 }
2352 return sortInfo.resultCode;
2353}
2354
2355
2356/*
2357 *----------------------------------------------------------------------
2358 *
2359 * MergeSort -
2360 *
2361 * This procedure sorts a linked list of SortElement structures
2362 * use the merge-sort algorithm.
2363 *
2364 * Results:
2365 * A pointer to the head of the list after sorting is returned.
2366 *
2367 * Side effects:
2368 * None, unless a user-defined comparison command does something
2369 * weird.
2370 *
2371 *----------------------------------------------------------------------
2372 */
2373
2374static SortElement *
2375MergeSort(headPtr, infoPtr)
2376 SortElement *headPtr; /* First element on the list */
2377 SortInfo *infoPtr; /* Information needed by the
2378 * comparison operator */
2379{
2380 /*
2381 * The subList array below holds pointers to temporary lists built
2382 * during the merge sort. Element i of the array holds a list of
2383 * length 2**i.
2384 */
2385
2386# define NUM_LISTS 30
2387 SortElement *subList[NUM_LISTS];
2388 SortElement *elementPtr;
2389 int i;
2390
2391 for(i = 0; i < NUM_LISTS; i++){
2392 subList[i] = NULL;
2393 }
2394 while (headPtr != NULL) {
2395 elementPtr = headPtr;
2396 headPtr = headPtr->nextPtr;
2397 elementPtr->nextPtr = 0;
2398 for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
2399 elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
2400 subList[i] = NULL;
2401 }
2402 if (i >= NUM_LISTS) {
2403 i = NUM_LISTS-1;
2404 }
2405 subList[i] = elementPtr;
2406 }
2407 elementPtr = NULL;
2408 for (i = 0; i < NUM_LISTS; i++){
2409 elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
2410 }
2411 return elementPtr;
2412}
2413
2414
2415/*
2416 *----------------------------------------------------------------------
2417 *
2418 * MergeLists -
2419 *
2420 * This procedure combines two sorted lists of SortElement structures
2421 * into a single sorted list.
2422 *
2423 * Results:
2424 * The unified list of SortElement structures.
2425 *
2426 * Side effects:
2427 * None, unless a user-defined comparison command does something
2428 * weird.
2429 *
2430 *----------------------------------------------------------------------
2431 */
2432
2433static SortElement *
2434MergeLists(leftPtr, rightPtr, infoPtr)
2435 SortElement *leftPtr; /* First list to be merged; may be
2436 * NULL. */
2437 SortElement *rightPtr; /* Second list to be merged; may be
2438 * NULL. */
2439 SortInfo *infoPtr; /* Information needed by the
2440 * comparison operator. */
2441{
2442 SortElement *headPtr;
2443 SortElement *tailPtr;
2444
2445 if (leftPtr == NULL) {
2446 return rightPtr;
2447 }
2448 if (rightPtr == NULL) {
2449 return leftPtr;
2450 }
2451 if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
2452 tailPtr = rightPtr;
2453 rightPtr = rightPtr->nextPtr;
2454 } else {
2455 tailPtr = leftPtr;
2456 leftPtr = leftPtr->nextPtr;
2457 }
2458 headPtr = tailPtr;
2459 while ((leftPtr != NULL) && (rightPtr != NULL)) {
2460 if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
2461 tailPtr->nextPtr = rightPtr;
2462 tailPtr = rightPtr;
2463 rightPtr = rightPtr->nextPtr;
2464 } else {
2465 tailPtr->nextPtr = leftPtr;
2466 tailPtr = leftPtr;
2467 leftPtr = leftPtr->nextPtr;
2468 }
2469 }
2470 if (leftPtr != NULL) {
2471 tailPtr->nextPtr = leftPtr;
2472 } else {
2473 tailPtr->nextPtr = rightPtr;
2474 }
2475 return headPtr;
2476}
2477
2478
2479/*
2480 *----------------------------------------------------------------------
2481 *
2482 * SortCompare --
2483 *
2484 * This procedure is invoked by MergeLists to determine the proper
2485 * ordering between two elements.
2486 *
2487 * Results:
2488 * A negative results means the the first element comes before the
2489 * second, and a positive results means that the second element
2490 * should come first. A result of zero means the two elements
2491 * are equal and it doesn't matter which comes first.
2492 *
2493 * Side effects:
2494 * None, unless a user-defined comparison command does something
2495 * weird.
2496 *
2497 *----------------------------------------------------------------------
2498 */
2499
2500static int
2501SortCompare(objPtr1, objPtr2, infoPtr)
2502 Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
2503 SortInfo *infoPtr; /* Information passed from the
2504 * top-level "lsort" command */
2505{
2506 int order, dummy, listLen, index;
2507 Tcl_Obj *objPtr;
2508 char buffer[30];
2509
2510 order = 0;
2511 if (infoPtr->resultCode != TCL_OK) {
2512 /*
2513 * Once an error has occurred, skip any future comparisons
2514 * so as to preserve the error message in sortInterp->result.
2515 */
2516
2517 return order;
2518 }
2519 if (infoPtr->index != -1) {
2520 /*
2521 * The "-index" option was specified. Treat each object as a
2522 * list, extract the requested element from each list, and
2523 * compare the elements, not the lists. The special index "end"
2524 * is signaled here with a large negative index.
2525 */
2526
2527 if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
2528 infoPtr->resultCode = TCL_ERROR;
2529 return order;
2530 }
2531 if (infoPtr->index < -1) {
2532 index = listLen - 1;
2533 } else {
2534 index = infoPtr->index;
2535 }
2536
2537 if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
2538 != TCL_OK) {
2539 infoPtr->resultCode = TCL_ERROR;
2540 return order;
2541 }
2542 if (objPtr == NULL) {
2543 objPtr = objPtr1;
2544 missingElement:
2545 sprintf(buffer, "%d", infoPtr->index);
2546 Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
2547 "element ", buffer, " missing from sublist \"",
2548 Tcl_GetStringFromObj(objPtr, (int *) NULL),
2549 "\"", (char *) NULL);
2550 infoPtr->resultCode = TCL_ERROR;
2551 return order;
2552 }
2553 objPtr1 = objPtr;
2554
2555 if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
2556 infoPtr->resultCode = TCL_ERROR;
2557 return order;
2558 }
2559 if (infoPtr->index < -1) {
2560 index = listLen - 1;
2561 } else {
2562 index = infoPtr->index;
2563 }
2564
2565 if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
2566 != TCL_OK) {
2567 infoPtr->resultCode = TCL_ERROR;
2568 return order;
2569 }
2570 if (objPtr == NULL) {
2571 objPtr = objPtr2;
2572 goto missingElement;
2573 }
2574 objPtr2 = objPtr;
2575 }
2576 if (infoPtr->sortMode == SORTMODE_ASCII) {
2577 order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
2578 Tcl_GetStringFromObj(objPtr2, &dummy));
2579 } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
2580 order = DictionaryCompare(
2581 Tcl_GetStringFromObj(objPtr1, &dummy),
2582 Tcl_GetStringFromObj(objPtr2, &dummy));
2583 } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
2584 int a, b;
2585
2586 if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
2587 || (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
2588 != TCL_OK)) {
2589 infoPtr->resultCode = TCL_ERROR;
2590 return order;
2591 }
2592 if (a > b) {
2593 order = 1;
2594 } else if (b > a) {
2595 order = -1;
2596 }
2597 } else if (infoPtr->sortMode == SORTMODE_REAL) {
2598 double a, b;
2599
2600 if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
2601 || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
2602 != TCL_OK)) {
2603 infoPtr->resultCode = TCL_ERROR;
2604 return order;
2605 }
2606 if (a > b) {
2607 order = 1;
2608 } else if (b > a) {
2609 order = -1;
2610 }
2611 } else {
2612 int oldLength;
2613
2614 /*
2615 * Generate and evaluate a command to determine which string comes
2616 * first.
2617 */
2618
2619 oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
2620 Tcl_DStringAppendElement(&infoPtr->compareCmd,
2621 Tcl_GetStringFromObj(objPtr1, &dummy));
2622 Tcl_DStringAppendElement(&infoPtr->compareCmd,
2623 Tcl_GetStringFromObj(objPtr2, &dummy));
2624 infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
2625 Tcl_DStringValue(&infoPtr->compareCmd));
2626 Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
2627 if (infoPtr->resultCode != TCL_OK) {
2628 Tcl_AddErrorInfo(infoPtr->interp,
2629 "\n (-compare command)");
2630 return order;
2631 }
2632
2633 /*
2634 * Parse the result of the command.
2635 */
2636
2637 if (Tcl_GetIntFromObj(infoPtr->interp,
2638 Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
2639 Tcl_ResetResult(infoPtr->interp);
2640 Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
2641 "-compare command returned non-numeric result", -1);
2642 infoPtr->resultCode = TCL_ERROR;
2643 return order;
2644 }
2645 }
2646 if (!infoPtr->isIncreasing) {
2647 order = -order;
2648 }
2649 return order;
2650}
2651
2652
2653/*
2654 *----------------------------------------------------------------------
2655 *
2656 * DictionaryCompare
2657 *
2658 * This function compares two strings as if they were being used in
2659 * an index or card catalog. The case of alphabetic characters is
2660 * ignored, except to break ties. Thus "B" comes before "b" but
2661 * after "a". Also, integers embedded in the strings compare in
2662 * numerical order. In other words, "x10y" comes after "x9y", not
2663 * before it as it would when using strcmp().
2664 *
2665 * Results:
2666 * A negative result means that the first element comes before the
2667 * second, and a positive result means that the second element
2668 * should come first. A result of zero means the two elements
2669 * are equal and it doesn't matter which comes first.
2670 *
2671 * Side effects:
2672 * None.
2673 *
2674 *----------------------------------------------------------------------
2675 */
2676
2677static int
2678DictionaryCompare(left, right)
2679 char *left, *right; /* The strings to compare */
2680{
2681 int diff, zeros;
2682 int secondaryDiff = 0;
2683
2684 while (1) {
2685 if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
2686 /*
2687 * There are decimal numbers embedded in the two
2688 * strings. Compare them as numbers, rather than
2689 * strings. If one number has more leading zeros than
2690 * the other, the number with more leading zeros sorts
2691 * later, but only as a secondary choice.
2692 */
2693
2694 zeros = 0;
2695 while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
2696 right++;
2697 zeros--;
2698 }
2699 while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
2700 left++;
2701 zeros++;
2702 }
2703 if (secondaryDiff == 0) {
2704 secondaryDiff = zeros;
2705 }
2706
2707 /*
2708 * The code below compares the numbers in the two
2709 * strings without ever converting them to integers. It
2710 * does this by first comparing the lengths of the
2711 * numbers and then comparing the digit values.
2712 */
2713
2714 diff = 0;
2715 while (1) {
2716 if (diff == 0) {
2717 diff = UCHAR(*left) - UCHAR(*right);
2718 }
2719 right++;
2720 left++;
2721 if (!isdigit(UCHAR(*right))) {
2722 if (isdigit(UCHAR(*left))) {
2723 return 1;
2724 } else {
2725 /*
2726 * The two numbers have the same length. See
2727 * if their values are different.
2728 */
2729
2730 if (diff != 0) {
2731 return diff;
2732 }
2733 break;
2734 }
2735 } else if (!isdigit(UCHAR(*left))) {
2736 return -1;
2737 }
2738 }
2739 continue;
2740 }
2741 diff = UCHAR(*left) - UCHAR(*right);
2742 if (diff) {
2743 if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
2744 diff = UCHAR(tolower(*left)) - UCHAR(*right);
2745 if (diff) {
2746 return diff;
2747 } else if (secondaryDiff == 0) {
2748 secondaryDiff = -1;
2749 }
2750 } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
2751 diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
2752 if (diff) {
2753 return diff;
2754 } else if (secondaryDiff == 0) {
2755 secondaryDiff = 1;
2756 }
2757 } else {
2758 return diff;
2759 }
2760 }
2761 if (*left == 0) {
2762 break;
2763 }
2764 left++;
2765 right++;
2766 }
2767 if (diff == 0) {
2768 diff = secondaryDiff;
2769 }
2770 return diff;
2771}
Note: See TracBrowser for help on using the repository browser.