![[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.