/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdil.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25