![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclcmdil.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tcl|
Return to tclcmdil.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 root 1: /*
2: * tclCmdIL.c --
3: *
4: * This file contains the top-level command routines for most of
5: * the Tcl built-in commands whose names begin with the letters
6: * I through L. It contains only commands in the generic core
7: * (i.e. those that don't depend much upon UNIX facilities).
8: *
9: * Copyright 1987-1991 Regents of the University of California
10: * Permission to use, copy, modify, and distribute this
11: * software and its documentation for any purpose and without
12: * fee is hereby granted, provided that the above copyright
13: * notice appear in all copies. The University of California
14: * makes no representations about the suitability of this
15: * software for any purpose. It is provided "as is" without
16: * express or implied warranty.
17: */
18:
19: #ifndef lint
20: static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.84 91/12/06 10:42:36 ouster Exp $ SPRITE (Berkeley)";
21: #endif
22:
23: #include "tclint.h"
24:
25: /*
26: * Global absolute file name:
27: */
28:
29: char *TCL_Library = TCL_LIBRARY;
30:
31: /*
32: * Forward declarations for procedures defined in this file:
33: */
34:
35: static int SortCompareProc _ANSI_ARGS_((CONST VOID *first,
36: CONST VOID *second));
37:
38: /*
39: *----------------------------------------------------------------------
40: *
41: * Tcl_IfCmd --
42: *
43: * This procedure is invoked to process the "if" Tcl command.
44: * See the user documentation for details on what it does.
45: *
46: * Results:
47: * A standard Tcl result.
48: *
49: * Side effects:
50: * See the user documentation.
51: *
52: *----------------------------------------------------------------------
53: */
54:
55: /* ARGSUSED */
56: int
57: Tcl_IfCmd(dummy, interp, argc, argv)
58: ClientData dummy; /* Not used. */
59: Tcl_Interp *interp; /* Current interpreter. */
60: int argc; /* Number of arguments. */
61: char **argv; /* Argument strings. */
62: {
63: char *condition, *ifPart, *elsePart, *cmd, *name;
64: char *clause;
65: int result, value;
66:
67: name = argv[0];
68: if (argc < 3) {
69: ifSyntax:
70: Tcl_AppendResult(interp, "wrong # args: should be \"", name,
71: " bool ?then? command ?else? ?command?\"", (char *) NULL);
72: return TCL_ERROR;
73: }
74: condition = argv[1];
75: argc -= 2;
76: argv += 2;
77: if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
78: argc--;
79: argv++;
80: }
81: if (argc < 1) {
82: goto ifSyntax;
83: }
84: ifPart = *argv;
85: argv++;
86: argc--;
87: if (argc == 0) {
88: elsePart = "";
89: } else {
90: if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
91: argc--;
92: argv++;
93: }
94: if (argc != 1) {
95: goto ifSyntax;
96: }
97: elsePart = *argv;
98: }
99:
100: cmd = ifPart;
101: clause = "\"then\" clause";
102: result = Tcl_ExprBoolean(interp, condition, &value);
103: if (result != TCL_OK) {
104: if (result == TCL_ERROR) {
105: char msg[60];
106: sprintf(msg, "\n (\"if\" test line %d)", interp->errorLine);
107: Tcl_AddErrorInfo(interp, msg);
108: }
109: return result;
110: }
111: if (value == 0) {
112: cmd = elsePart;
113: clause = "\"else\" clause";
114: }
115: if (*cmd == 0) {
116: return TCL_OK;
117: }
118: result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
119: if (result == TCL_ERROR) {
120: char msg[60];
121: sprintf(msg, "\n (%s line %d)", clause, interp->errorLine);
122: Tcl_AddErrorInfo(interp, msg);
123: }
124: return result;
125: }
126:
127: /*
128: *----------------------------------------------------------------------
129: *
130: * Tcl_IncrCmd --
131: *
132: * This procedure is invoked to process the "incr" Tcl command.
133: * See the user documentation for details on what it does.
134: *
135: * Results:
136: * A standard Tcl result.
137: *
138: * Side effects:
139: * See the user documentation.
140: *
141: *----------------------------------------------------------------------
142: */
143:
144: /* ARGSUSED */
145: int
146: Tcl_IncrCmd(dummy, interp, argc, argv)
147: ClientData dummy; /* Not used. */
148: Tcl_Interp *interp; /* Current interpreter. */
149: int argc; /* Number of arguments. */
150: char **argv; /* Argument strings. */
151: {
152: int value;
153: char *oldString, *result;
154: char newString[30];
155:
156: if ((argc != 2) && (argc != 3)) {
157: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
158: " varName ?increment?\"", (char *) NULL);
159: return TCL_ERROR;
160: }
161:
162: oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
163: if (oldString == NULL) {
164: return TCL_ERROR;
165: }
166: if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
167: Tcl_AddErrorInfo(interp,
168: "\n (reading value of variable to increment)");
169: return TCL_ERROR;
170: }
171: if (argc == 2) {
172: value += 1;
173: } else {
174: int increment;
175:
176: if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
177: Tcl_AddErrorInfo(interp,
178: "\n (reading increment)");
179: return TCL_ERROR;
180: }
181: value += increment;
182: }
183: sprintf(newString, "%d", value);
184: result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
185: if (result == NULL) {
186: return TCL_ERROR;
187: }
188: interp->result = result;
189: return TCL_OK;
190: }
191:
192: /*
193: *----------------------------------------------------------------------
194: *
195: * Tcl_InfoCmd --
196: *
197: * This procedure is invoked to process the "info" Tcl command.
198: * See the user documentation for details on what it does.
199: *
200: * Results:
201: * A standard Tcl result.
202: *
203: * Side effects:
204: * See the user documentation.
205: *
206: *----------------------------------------------------------------------
207: */
208:
209: /* ARGSUSED */
210: int
211: Tcl_InfoCmd(dummy, interp, argc, argv)
212: ClientData dummy; /* Not used. */
213: Tcl_Interp *interp; /* Current interpreter. */
214: int argc; /* Number of arguments. */
215: char **argv; /* Argument strings. */
216: {
217: register Interp *iPtr = (Interp *) interp;
218: int length;
219: char c;
220: Arg *argPtr;
221: Proc *procPtr;
222: Var *varPtr;
223: Command *cmdPtr;
224: Tcl_HashEntry *hPtr;
225: Tcl_HashSearch search;
226:
227: if (argc < 2) {
228: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
229: " option ?arg arg ...?\"", (char *) NULL);
230: return TCL_ERROR;
231: }
232: c = argv[1][0];
233: length = strlen(argv[1]);
234: if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
235: if (argc != 3) {
236: Tcl_AppendResult(interp, "wrong # args: should be \"",
237: argv[0], " args procname\"", (char *) NULL);
238: return TCL_ERROR;
239: }
240: procPtr = TclFindProc(iPtr, argv[2]);
241: if (procPtr == NULL) {
242: infoNoSuchProc:
243: Tcl_AppendResult(interp, "\"", argv[2],
244: "\" isn't a procedure", (char *) NULL);
245: return TCL_ERROR;
246: }
247: for (argPtr = procPtr->argPtr; argPtr != NULL;
248: argPtr = argPtr->nextPtr) {
249: Tcl_AppendElement(interp, argPtr->name, 0);
250: }
251: return TCL_OK;
252: } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
253: if (argc != 3) {
254: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
255: " body procname\"", (char *) NULL);
256: return TCL_ERROR;
257: }
258: procPtr = TclFindProc(iPtr, argv[2]);
259: if (procPtr == NULL) {
260: goto infoNoSuchProc;
261: }
262: iPtr->result = procPtr->command;
263: return TCL_OK;
264: } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
265: && (length >= 2)) {
266: if (argc != 2) {
267: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
268: " cmdcount\"", (char *) NULL);
269: return TCL_ERROR;
270: }
271: sprintf(iPtr->result, "%d", iPtr->cmdCount);
272: return TCL_OK;
273: } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
274: && (length >= 2)){
275: if (argc > 3) {
276: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
277: " commands [pattern]\"", (char *) NULL);
278: return TCL_ERROR;
279: }
280: for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
281: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
282: char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
283: if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
284: continue;
285: }
286: Tcl_AppendElement(interp, name, 0);
287: }
288: return TCL_OK;
289: } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
290: if (argc != 5) {
291: Tcl_AppendResult(interp, "wrong # args: should be \"",
292: argv[0], " default procname arg varname\"",
293: (char *) NULL);
294: return TCL_ERROR;
295: }
296: procPtr = TclFindProc(iPtr, argv[2]);
297: if (procPtr == NULL) {
298: goto infoNoSuchProc;
299: }
300: for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
301: if (argPtr == NULL) {
302: Tcl_AppendResult(interp, "procedure \"", argv[2],
303: "\" doesn't have an argument \"", argv[3],
304: "\"", (char *) NULL);
305: return TCL_ERROR;
306: }
307: if (strcmp(argv[3], argPtr->name) == 0) {
308: if (argPtr->defValue != NULL) {
309: if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
310: argPtr->defValue, 0) == NULL) {
311: defStoreError:
312: Tcl_AppendResult(interp,
313: "couldn't store default value in variable \"",
314: argv[4], "\"", (char *) NULL);
315: return TCL_ERROR;
316: }
317: iPtr->result = "1";
318: } else {
319: if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
320: == NULL) {
321: goto defStoreError;
322: }
323: iPtr->result = "0";
324: }
325: return TCL_OK;
326: }
327: }
328: } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
329: char *p;
330: if (argc != 3) {
331: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
332: " exists varName\"", (char *) NULL);
333: return TCL_ERROR;
334: }
335: p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
336:
337: /*
338: * The code below handles the special case where the name is for
339: * an array: Tcl_GetVar will reject this since you can't read
340: * an array variable without an index.
341: */
342:
343: if (p == NULL) {
344: Tcl_HashEntry *hPtr;
345: Var *varPtr;
346:
347: if (strchr(argv[2], '(') != NULL) {
348: noVar:
349: iPtr->result = "0";
350: return TCL_OK;
351: }
352: if (iPtr->varFramePtr == NULL) {
353: hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
354: } else {
355: hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
356: }
357: if (hPtr == NULL) {
358: goto noVar;
359: }
360: varPtr = (Var *) Tcl_GetHashValue(hPtr);
361: if (varPtr->flags & VAR_UPVAR) {
362: varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
363: }
364: if (!(varPtr->flags & VAR_ARRAY)) {
365: goto noVar;
366: }
367: }
368: iPtr->result = "1";
369: return TCL_OK;
370: } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
371: char *name;
372:
373: if (argc > 3) {
374: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
375: " globals [pattern]\"", (char *) NULL);
376: return TCL_ERROR;
377: }
378: for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
379: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
380: varPtr = (Var *) Tcl_GetHashValue(hPtr);
381: if (varPtr->flags & VAR_UNDEFINED) {
382: continue;
383: }
384: name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
385: if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
386: continue;
387: }
388: Tcl_AppendElement(interp, name, 0);
389: }
390: return TCL_OK;
391: } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
392: && (length >= 2)) {
393: if (argc == 2) {
394: if (iPtr->varFramePtr == NULL) {
395: iPtr->result = "0";
396: } else {
397: sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
398: }
399: return TCL_OK;
400: } else if (argc == 3) {
401: int level;
402: CallFrame *framePtr;
403:
404: if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
405: return TCL_ERROR;
406: }
407: if (level <= 0) {
408: if (iPtr->varFramePtr == NULL) {
409: levelError:
410: Tcl_AppendResult(interp, "bad level \"", argv[2],
411: "\"", (char *) NULL);
412: return TCL_ERROR;
413: }
414: level += iPtr->varFramePtr->level;
415: }
416: for (framePtr = iPtr->varFramePtr; framePtr != NULL;
417: framePtr = framePtr->callerVarPtr) {
418: if (framePtr->level == level) {
419: break;
420: }
421: }
422: if (framePtr == NULL) {
423: goto levelError;
424: }
425: iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
426: iPtr->freeProc = (Tcl_FreeProc *) free;
427: return TCL_OK;
428: }
429: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
430: " level [number]\"", (char *) NULL);
431: return TCL_ERROR;
432: } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
433: && (length >= 2)) {
434: if (argc != 2) {
435: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
436: " library\"", (char *) NULL);
437: return TCL_ERROR;
438: }
439: #ifdef TCL_LIBRARY
440: interp->result = TCL_Library;
441: return TCL_OK;
442: #else
443: interp->result = "there is no Tcl library at this installation";
444: return TCL_ERROR;
445: #endif
446: } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
447: && (length >= 2)) {
448: char *name;
449:
450: if (argc > 3) {
451: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
452: " locals [pattern]\"", (char *) NULL);
453: return TCL_ERROR;
454: }
455: if (iPtr->varFramePtr == NULL) {
456: return TCL_OK;
457: }
458: for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
459: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
460: varPtr = (Var *) Tcl_GetHashValue(hPtr);
461: if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
462: continue;
463: }
464: name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
465: if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
466: continue;
467: }
468: Tcl_AppendElement(interp, name, 0);
469: }
470: return TCL_OK;
471: } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
472: if (argc > 3) {
473: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
474: " procs [pattern]\"", (char *) NULL);
475: return TCL_ERROR;
476: }
477: for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
478: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
479: char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
480:
481: cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
482: if (!TclIsProc(cmdPtr)) {
483: continue;
484: }
485: if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
486: continue;
487: }
488: Tcl_AppendElement(interp, name, 0);
489: }
490: return TCL_OK;
491: } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
492: if (argc != 2) {
493: Tcl_AppendResult(interp, "wrong # args: should be \"",
494: argv[0], " script\"", (char *) NULL);
495: return TCL_ERROR;
496: }
497: if (iPtr->scriptFile != NULL) {
498: interp->result = iPtr->scriptFile;
499: }
500: return TCL_OK;
501: } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
502: if (argc != 2) {
503: Tcl_AppendResult(interp, "wrong # args: should be \"",
504: argv[0], " tclversion\"", (char *) NULL);
505: return TCL_ERROR;
506: }
507:
508: /*
509: * Note: TCL_VERSION below is expected to be set with a "-D"
510: * switch in the Makefile.
511: */
512:
513: strcpy(iPtr->result, TCL_VERSION);
514: return TCL_OK;
515: } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
516: Tcl_HashTable *tablePtr;
517: char *name;
518:
519: if (argc > 3) {
520: Tcl_AppendResult(interp, "wrong # args: should be \"",
521: argv[0], " vars [pattern]\"", (char *) NULL);
522: return TCL_ERROR;
523: }
524: if (iPtr->varFramePtr == NULL) {
525: tablePtr = &iPtr->globalTable;
526: } else {
527: tablePtr = &iPtr->varFramePtr->varTable;
528: }
529: for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
530: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
531: varPtr = (Var *) Tcl_GetHashValue(hPtr);
532: if (varPtr->flags & VAR_UNDEFINED) {
533: continue;
534: }
535: name = Tcl_GetHashKey(tablePtr, hPtr);
536: if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
537: continue;
538: }
539: Tcl_AppendElement(interp, name, 0);
540: }
541: return TCL_OK;
542: } else {
543: Tcl_AppendResult(interp, "bad option \"", argv[1],
544: "\": should be args, body, commands, cmdcount, default, ",
545: "exists, globals, level, library, locals, procs, ",
546: "script, tclversion, or vars",
547: (char *) NULL);
548: return TCL_ERROR;
549: }
550: }
551:
552: /*
553: *----------------------------------------------------------------------
554: *
555: * Tcl_JoinCmd --
556: *
557: * This procedure is invoked to process the "join" Tcl command.
558: * See the user documentation for details on what it does.
559: *
560: * Results:
561: * A standard Tcl result.
562: *
563: * Side effects:
564: * See the user documentation.
565: *
566: *----------------------------------------------------------------------
567: */
568:
569: /* ARGSUSED */
570: int
571: Tcl_JoinCmd(dummy, interp, argc, argv)
572: ClientData dummy; /* Not used. */
573: Tcl_Interp *interp; /* Current interpreter. */
574: int argc; /* Number of arguments. */
575: char **argv; /* Argument strings. */
576: {
577: char *joinString;
578: char **listArgv;
579: int listArgc, i;
580:
581: if (argc == 2) {
582: joinString = " ";
583: } else if (argc == 3) {
584: joinString = argv[2];
585: } else {
586: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
587: " list ?joinString?\"", (char *) NULL);
588: return TCL_ERROR;
589: }
590:
591: if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
592: return TCL_ERROR;
593: }
594: for (i = 0; i < listArgc; i++) {
595: if (i == 0) {
596: Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
597: } else {
598: Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
599: }
600: }
601: ckfree((char *) listArgv);
602: return TCL_OK;
603: }
604:
605: /*
606: *----------------------------------------------------------------------
607: *
608: * Tcl_LindexCmd --
609: *
610: * This procedure is invoked to process the "lindex" Tcl command.
611: * See the user documentation for details on what it does.
612: *
613: * Results:
614: * A standard Tcl result.
615: *
616: * Side effects:
617: * See the user documentation.
618: *
619: *----------------------------------------------------------------------
620: */
621:
622: /* ARGSUSED */
623: int
624: Tcl_LindexCmd(dummy, interp, argc, argv)
625: ClientData dummy; /* Not used. */
626: Tcl_Interp *interp; /* Current interpreter. */
627: int argc; /* Number of arguments. */
628: char **argv; /* Argument strings. */
629: {
630: char *p, *element;
631: int index, size, parenthesized, result;
632:
633: if (argc != 3) {
634: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
635: " list index\"", (char *) NULL);
636: return TCL_ERROR;
637: }
638: if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
639: return TCL_ERROR;
640: }
641: if (index < 0) {
642: return TCL_OK;
643: }
644: for (p = argv[1] ; index >= 0; index--) {
645: result = TclFindElement(interp, p, &element, &p, &size,
646: &parenthesized);
647: if (result != TCL_OK) {
648: return result;
649: }
650: }
651: if (size == 0) {
652: return TCL_OK;
653: }
654: if (size >= TCL_RESULT_SIZE) {
655: interp->result = (char *) ckalloc((unsigned) size+1);
656: interp->freeProc = (Tcl_FreeProc *) free;
657: }
658: if (parenthesized) {
659: memcpy((VOID *) interp->result, (VOID *) element, size);
660: interp->result[size] = 0;
661: } else {
662: TclCopyAndCollapse(size, element, interp->result);
663: }
664: return TCL_OK;
665: }
666:
667: /*
668: *----------------------------------------------------------------------
669: *
670: * Tcl_LinsertCmd --
671: *
672: * This procedure is invoked to process the "linsert" Tcl command.
673: * See the user documentation for details on what it does.
674: *
675: * Results:
676: * A standard Tcl result.
677: *
678: * Side effects:
679: * See the user documentation.
680: *
681: *----------------------------------------------------------------------
682: */
683:
684: /* ARGSUSED */
685: int
686: Tcl_LinsertCmd(dummy, interp, argc, argv)
687: ClientData dummy; /* Not used. */
688: Tcl_Interp *interp; /* Current interpreter. */
689: int argc; /* Number of arguments. */
690: char **argv; /* Argument strings. */
691: {
692: char *p, *element, savedChar;
693: int i, index, count, result, size;
694:
695: if (argc < 4) {
696: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
697: " list index element ?element ...?\"", (char *) NULL);
698: return TCL_ERROR;
699: }
700: if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
701: return TCL_ERROR;
702: }
703:
704: /*
705: * Skip over the first "index" elements of the list, then add
706: * all of those elements to the result.
707: */
708:
709: size = 0;
710: element = argv[1];
711: for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
712: result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
713: if (result != TCL_OK) {
714: return result;
715: }
716: }
717: if (*p == 0) {
718: Tcl_AppendResult(interp, argv[1], (char *) NULL);
719: } else {
720: char *end;
721:
722: end = element+size;
723: if (element != argv[1]) {
724: while ((*end != 0) && !isspace(*end)) {
725: end++;
726: }
727: }
728: savedChar = *end;
729: *end = 0;
730: Tcl_AppendResult(interp, argv[1], (char *) NULL);
731: *end = savedChar;
732: }
733:
734: /*
735: * Add the new list elements.
736: */
737:
738: for (i = 3; i < argc; i++) {
739: Tcl_AppendElement(interp, argv[i], 0);
740: }
741:
742: /*
743: * Append the remainder of the original list.
744: */
745:
746: if (*p != 0) {
747: Tcl_AppendResult(interp, " ", p, (char *) NULL);
748: }
749: return TCL_OK;
750: }
751:
752: /*
753: *----------------------------------------------------------------------
754: *
755: * Tcl_ListCmd --
756: *
757: * This procedure is invoked to process the "list" Tcl command.
758: * See the user documentation for details on what it does.
759: *
760: * Results:
761: * A standard Tcl result.
762: *
763: * Side effects:
764: * See the user documentation.
765: *
766: *----------------------------------------------------------------------
767: */
768:
769: /* ARGSUSED */
770: int
771: Tcl_ListCmd(dummy, interp, argc, argv)
772: ClientData dummy; /* Not used. */
773: Tcl_Interp *interp; /* Current interpreter. */
774: int argc; /* Number of arguments. */
775: char **argv; /* Argument strings. */
776: {
777: if (argc < 2) {
778: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
779: " arg ?arg ...?\"", (char *) NULL);
780: return TCL_ERROR;
781: }
782: interp->result = Tcl_Merge(argc-1, argv+1);
783: interp->freeProc = (Tcl_FreeProc *) free;
784: return TCL_OK;
785: }
786:
787: /*
788: *----------------------------------------------------------------------
789: *
790: * Tcl_LlengthCmd --
791: *
792: * This procedure is invoked to process the "llength" Tcl command.
793: * See the user documentation for details on what it does.
794: *
795: * Results:
796: * A standard Tcl result.
797: *
798: * Side effects:
799: * See the user documentation.
800: *
801: *----------------------------------------------------------------------
802: */
803:
804: /* ARGSUSED */
805: int
806: Tcl_LlengthCmd(dummy, interp, argc, argv)
807: ClientData dummy; /* Not used. */
808: Tcl_Interp *interp; /* Current interpreter. */
809: int argc; /* Number of arguments. */
810: char **argv; /* Argument strings. */
811: {
812: int count, result;
813: char *element, *p;
814:
815: if (argc != 2) {
816: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
817: " list\"", (char *) NULL);
818: return TCL_ERROR;
819: }
820: for (count = 0, p = argv[1]; *p != 0 ; count++) {
821: result = TclFindElement(interp, p, &element, &p, (int *) NULL,
822: (int *) NULL);
823: if (result != TCL_OK) {
824: return result;
825: }
826: if (*element == 0) {
827: break;
828: }
829: }
830: sprintf(interp->result, "%d", count);
831: return TCL_OK;
832: }
833:
834: /*
835: *----------------------------------------------------------------------
836: *
837: * Tcl_LrangeCmd --
838: *
839: * This procedure is invoked to process the "lrange" Tcl command.
840: * See the user documentation for details on what it does.
841: *
842: * Results:
843: * A standard Tcl result.
844: *
845: * Side effects:
846: * See the user documentation.
847: *
848: *----------------------------------------------------------------------
849: */
850:
851: /* ARGSUSED */
852: int
853: Tcl_LrangeCmd(notUsed, interp, argc, argv)
854: ClientData notUsed; /* Not used. */
855: Tcl_Interp *interp; /* Current interpreter. */
856: int argc; /* Number of arguments. */
857: char **argv; /* Argument strings. */
858: {
859: int first, last, result;
860: char *begin, *end, c, *dummy;
861: int count;
862:
863: if (argc != 4) {
864: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
865: " list first last\"", (char *) NULL);
866: return TCL_ERROR;
867: }
868: if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
869: return TCL_ERROR;
870: }
871: if (first < 0) {
872: first = 0;
873: }
874: if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
875: last = 1000000;
876: } else {
877: if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
878: Tcl_ResetResult(interp);
879: Tcl_AppendResult(interp,
880: "expected integer or \"end\" but got \"",
881: argv[3], "\"", (char *) NULL);
882: return TCL_ERROR;
883: }
884: }
885: if (first > last) {
886: return TCL_OK;
887: }
888:
889: /*
890: * Extract a range of fields.
891: */
892:
893: for (count = 0, begin = argv[1]; count < first; count++) {
894: result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
895: (int *) NULL);
896: if (result != TCL_OK) {
897: return result;
898: }
899: if (*begin == 0) {
900: break;
901: }
902: }
903: for (count = first, end = begin; (count <= last) && (*end != 0);
904: count++) {
905: result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
906: (int *) NULL);
907: if (result != TCL_OK) {
908: return result;
909: }
910: }
911:
912: /*
913: * Chop off trailing spaces.
914: */
915:
916: while (isspace(end[-1])) {
917: end--;
918: }
919: c = *end;
920: *end = 0;
921: Tcl_SetResult(interp, begin, TCL_VOLATILE);
922: *end = c;
923: return TCL_OK;
924: }
925:
926: /*
927: *----------------------------------------------------------------------
928: *
929: * Tcl_LreplaceCmd --
930: *
931: * This procedure is invoked to process the "lreplace" Tcl command.
932: * See the user documentation for details on what it does.
933: *
934: * Results:
935: * A standard Tcl result.
936: *
937: * Side effects:
938: * See the user documentation.
939: *
940: *----------------------------------------------------------------------
941: */
942:
943: /* ARGSUSED */
944: int
945: Tcl_LreplaceCmd(notUsed, interp, argc, argv)
946: ClientData notUsed; /* Not used. */
947: Tcl_Interp *interp; /* Current interpreter. */
948: int argc; /* Number of arguments. */
949: char **argv; /* Argument strings. */
950: {
951: char *p1, *p2, *element, savedChar, *dummy;
952: int i, first, last, count, result, size;
953:
954: if (argc < 4) {
955: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
956: " list first last ?element element ...?\"", (char *) NULL);
957: return TCL_ERROR;
958: }
959: if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
960: return TCL_ERROR;
961: }
962: if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
963: return TCL_ERROR;
964: }
965: if (first < 0) {
966: first = 0;
967: }
968: if (last < 0) {
969: last = 0;
970: }
971: if (first > last) {
972: Tcl_AppendResult(interp, "first index must not be greater than second",
973: (char *) NULL);
974: return TCL_ERROR;
975: }
976:
977: /*
978: * Skip over the elements of the list before "first".
979: */
980:
981: size = 0;
982: element = argv[1];
983: for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
984: result = TclFindElement(interp, p1, &element, &p1, &size,
985: (int *) NULL);
986: if (result != TCL_OK) {
987: return result;
988: }
989: }
990: if (*p1 == 0) {
991: Tcl_AppendResult(interp, "list doesn't contain element ",
992: argv[2], (char *) NULL);
993: return TCL_ERROR;
994: }
995:
996: /*
997: * Skip over the elements of the list up through "last".
998: */
999:
1000: for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
1001: result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
1002: (int *) NULL);
1003: if (result != TCL_OK) {
1004: return result;
1005: }
1006: }
1007:
1008: /*
1009: * Add the elements before "first" to the result. Be sure to
1010: * include quote or brace characters that might terminate the
1011: * last of these elements.
1012: */
1013:
1014: p1 = element+size;
1015: if (element != argv[1]) {
1016: while ((*p1 != 0) && !isspace(*p1)) {
1017: p1++;
1018: }
1019: }
1020: savedChar = *p1;
1021: *p1 = 0;
1022: Tcl_AppendResult(interp, argv[1], (char *) NULL);
1023: *p1 = savedChar;
1024:
1025: /*
1026: * Add the new list elements.
1027: */
1028:
1029: for (i = 4; i < argc; i++) {
1030: Tcl_AppendElement(interp, argv[i], 0);
1031: }
1032:
1033: /*
1034: * Append the remainder of the original list.
1035: */
1036:
1037: if (*p2 != 0) {
1038: if (*interp->result == 0) {
1039: Tcl_SetResult(interp, p2, TCL_VOLATILE);
1040: } else {
1041: Tcl_AppendResult(interp, " ", p2, (char *) NULL);
1042: }
1043: }
1044: return TCL_OK;
1045: }
1046:
1047: /*
1048: *----------------------------------------------------------------------
1049: *
1050: * Tcl_LsearchCmd --
1051: *
1052: * This procedure is invoked to process the "lsearch" Tcl command.
1053: * See the user documentation for details on what it does.
1054: *
1055: * Results:
1056: * A standard Tcl result.
1057: *
1058: * Side effects:
1059: * See the user documentation.
1060: *
1061: *----------------------------------------------------------------------
1062: */
1063:
1064: /* ARGSUSED */
1065: int
1066: Tcl_LsearchCmd(notUsed, interp, argc, argv)
1067: ClientData notUsed; /* Not used. */
1068: Tcl_Interp *interp; /* Current interpreter. */
1069: int argc; /* Number of arguments. */
1070: char **argv; /* Argument strings. */
1071: {
1072: int listArgc;
1073: char **listArgv;
1074: int i, match;
1075:
1076: if (argc != 3) {
1077: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1078: " list pattern\"", (char *) NULL);
1079: return TCL_ERROR;
1080: }
1081: if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
1082: return TCL_ERROR;
1083: }
1084: match = -1;
1085: for (i = 0; i < listArgc; i++) {
1086: if (Tcl_StringMatch(listArgv[i], argv[2])) {
1087: match = i;
1088: break;
1089: }
1090: }
1091: sprintf(interp->result, "%d", match);
1092: ckfree((char *) listArgv);
1093: return TCL_OK;
1094: }
1095:
1096: /*
1097: *----------------------------------------------------------------------
1098: *
1099: * Tcl_LsortCmd --
1100: *
1101: * This procedure is invoked to process the "lsort" Tcl command.
1102: * See the user documentation for details on what it does.
1103: *
1104: * Results:
1105: * A standard Tcl result.
1106: *
1107: * Side effects:
1108: * See the user documentation.
1109: *
1110: *----------------------------------------------------------------------
1111: */
1112:
1113: /* ARGSUSED */
1114: int
1115: Tcl_LsortCmd(notUsed, interp, argc, argv)
1116: ClientData notUsed; /* Not used. */
1117: Tcl_Interp *interp; /* Current interpreter. */
1118: int argc; /* Number of arguments. */
1119: char **argv; /* Argument strings. */
1120: {
1121: int listArgc;
1122: char **listArgv;
1123:
1124: if (argc != 2) {
1125: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1126: " list\"", (char *) NULL);
1127: return TCL_ERROR;
1128: }
1129: if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
1130: return TCL_ERROR;
1131: }
1132: qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
1133: interp->result = Tcl_Merge(listArgc, listArgv);
1134: interp->freeProc = (Tcl_FreeProc *) free;
1135: ckfree((char *) listArgv);
1136: return TCL_OK;
1137: }
1138:
1139: /*
1140: * The procedure below is called back by qsort to determine
1141: * the proper ordering between two elements.
1142: */
1143:
1144: static int
1145: SortCompareProc(first, second)
1146: CONST VOID *first, *second; /* Elements to be compared. */
1147: {
1148: return strcmp(*((char **) first), *((char **) second));
1149: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.