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

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25