cde/programs/dtdocbook/tcl/tclProc.c

   1 /*
   2  * CDE - Common Desktop Environment
   3  *
   4  * Copyright (c) 1993-2012, The Open Group. All rights reserved.
   5  *
   6  * These libraries and programs are free software; you can
   7  * redistribute them and/or modify them under the terms of the GNU
   8  * Lesser General Public License as published by the Free Software
   9  * Foundation; either version 2 of the License, or (at your option)
  10  * any later version.
  11  *
  12  * These libraries and programs are distributed in the hope that
  13  * they will be useful, but WITHOUT ANY WARRANTY; without even the
  14  * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15  * PURPOSE. See the GNU Lesser General Public License for more
  16  * details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with these librararies and programs; if not, write
  20  * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  21  * Floor, Boston, MA 02110-1301 USA
  22  */
  23 /* $XConsortium: tclProc.c /main/2 1996/08/08 14:46:17 cde-hp $ */
  24 /*
  25  * tclProc.c --
  26  *
  27  *      This file contains routines that implement Tcl procedures,
  28  *      including the "proc" and "uplevel" commands.
  29  *
  30  * Copyright (c) 1987-1993 The Regents of the University of California.
  31  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  32  *
  33  * See the file "license.terms" for information on usage and redistribution
  34  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  35  *
  36  * SCCS: @(#) tclProc.c 1.72 96/02/15 11:42:48
  37  */
  38
  39 #include "tclInt.h"
  40
  41 /*
  42  * Forward references to procedures defined later in this file:
  43  */
  44
  45 static void     CleanupProc _ANSI_ARGS_((Proc *procPtr));
  46 static  int     InterpProc _ANSI_ARGS_((ClientData clientData,
  47                     Tcl_Interp *interp, int argc, char **argv));
  48 static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  49 \f
  50 /*
  51  *----------------------------------------------------------------------
  52  *
  53  * Tcl_ProcCmd --
  54  *
  55  *      This procedure is invoked to process the "proc" Tcl command.
  56  *      See the user documentation for details on what it does.
  57  *
  58  * Results:
  59  *      A standard Tcl result value.
  60  *
  61  * Side effects:
  62  *      A new procedure gets created.
  63  *
  64  *----------------------------------------------------------------------
  65  */
  66
  67         /* ARGSUSED */
  68 int
  69 Tcl_ProcCmd(dummy, interp, argc, argv)
  70     ClientData dummy;                   /* Not used. */
  71     Tcl_Interp *interp;                 /* Current interpreter. */
  72     int argc;                           /* Number of arguments. */
  73     char **argv;                        /* Argument strings. */
  74 {
  75     register Interp *iPtr = (Interp *) interp;
  76     register Proc *procPtr;
  77     int result, argCount, i;
  78     char **argArray = NULL;
  79     Arg *lastArgPtr;
  80     register Arg *argPtr = NULL;        /* Initialization not needed, but
  81                                          * prevents compiler warning. */
  82
  83     if (argc != 4) {
  84         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  85                 " name args body\"", (char *) NULL);
  86         return TCL_ERROR;
  87     }
  88
  89     procPtr = (Proc *) ckalloc(sizeof(Proc));
  90     procPtr->iPtr = iPtr;
  91     procPtr->refCount = 1;
  92     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  93     strcpy(procPtr->command, argv[3]);
  94     procPtr->argPtr = NULL;
  95
  96     /*
  97      * Break up the argument list into argument specifiers, then process
  98      * each argument specifier.
  99      */
 100
 101     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
 102     if (result != TCL_OK) {
 103         goto procError;
 104     }
 105     lastArgPtr = NULL;
 106     for (i = 0; i < argCount; i++) {
 107         int fieldCount, nameLength, valueLength;
 108         char **fieldValues;
 109
 110         /*
 111          * Now divide the specifier up into name and default.
 112          */
 113
 114         result = Tcl_SplitList(interp, argArray[i], &fieldCount,
 115                 &fieldValues);
 116         if (result != TCL_OK) {
 117             goto procError;
 118         }
 119         if (fieldCount > 2) {
 120             ckfree((char *) fieldValues);
 121             Tcl_AppendResult(interp,
 122                     "too many fields in argument specifier \"",
 123                     argArray[i], "\"", (char *) NULL);
 124             result = TCL_ERROR;
 125             goto procError;
 126         }
 127         if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
 128             ckfree((char *) fieldValues);
 129             Tcl_AppendResult(interp, "procedure \"", argv[1],
 130                     "\" has argument with no name", (char *) NULL);
 131             result = TCL_ERROR;
 132             goto procError;
 133         }
 134         nameLength = strlen(fieldValues[0]) + 1;
 135         if (fieldCount == 2) {
 136             valueLength = strlen(fieldValues[1]) + 1;
 137         } else {
 138             valueLength = 0;
 139         }
 140         argPtr = (Arg *) ckalloc((unsigned)
 141                 (sizeof(Arg) - sizeof(argPtr->name) + nameLength
 142                 + valueLength));
 143         if (lastArgPtr == NULL) {
 144             procPtr->argPtr = argPtr;
 145         } else {
 146             lastArgPtr->nextPtr = argPtr;
 147         }
 148         lastArgPtr = argPtr;
 149         argPtr->nextPtr = NULL;
 150         strcpy(argPtr->name, fieldValues[0]);
 151         if (fieldCount == 2) {
 152             argPtr->defValue = argPtr->name + nameLength;
 153             strcpy(argPtr->defValue, fieldValues[1]);
 154         } else {
 155             argPtr->defValue = NULL;
 156         }
 157         ckfree((char *) fieldValues);
 158     }
 159
 160     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
 161             ProcDeleteProc);
 162     ckfree((char *) argArray);
 163     return TCL_OK;
 164
 165     procError:
 166     ckfree(procPtr->command);
 167     while (procPtr->argPtr != NULL) {
 168         argPtr = procPtr->argPtr;
 169         procPtr->argPtr = argPtr->nextPtr;
 170         ckfree((char *) argPtr);
 171     }
 172     ckfree((char *) procPtr);
 173     if (argArray != NULL) {
 174         ckfree((char *) argArray);
 175     }
 176     return result;
 177 }
 178 \f
 179 /*
 180  *----------------------------------------------------------------------
 181  *
 182  * TclGetFrame --
 183  *
 184  *      Given a description of a procedure frame, such as the first
 185  *      argument to an "uplevel" or "upvar" command, locate the
 186  *      call frame for the appropriate level of procedure.
 187  *
 188  * Results:
 189  *      The return value is -1 if an error occurred in finding the
 190  *      frame (in this case an error message is left in interp->result).
 191  *      1 is returned if string was either a number or a number preceded
 192  *      by "#" and it specified a valid frame.  0 is returned if string
 193  *      isn't one of the two things above (in this case, the lookup
 194  *      acts as if string were "1").  The variable pointed to by
 195  *      framePtrPtr is filled in with the address of the desired frame
 196  *      (unless an error occurs, in which case it isn't modified).
 197  *
 198  * Side effects:
 199  *      None.
 200  *
 201  *----------------------------------------------------------------------
 202  */
 203
 204 int
 205 TclGetFrame(interp, string, framePtrPtr)
 206     Tcl_Interp *interp;         /* Interpreter in which to find frame. */
 207     char *string;               /* String describing frame. */
 208     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
 209                                  * if global frame indicated). */
 210 {
 211     register Interp *iPtr = (Interp *) interp;
 212     int curLevel, level, result;
 213     CallFrame *framePtr;
 214
 215     /*
 216      * Parse string to figure out which level number to go to.
 217      */
 218
 219     result = 1;
 220     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
 221     if (*string == '#') {
 222         if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
 223             return -1;
 224         }
 225         if (level < 0) {
 226             levelError:
 227             Tcl_AppendResult(interp, "bad level \"", string, "\"",
 228                     (char *) NULL);
 229             return -1;
 230         }
 231     } else if (isdigit(UCHAR(*string))) {
 232         if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
 233             return -1;
 234         }
 235         level = curLevel - level;
 236     } else {
 237         level = curLevel - 1;
 238         result = 0;
 239     }
 240
 241     /*
 242      * Figure out which frame to use, and modify the interpreter so
 243      * its variables come from that frame.
 244      */
 245
 246     if (level == 0) {
 247         framePtr = NULL;
 248     } else {
 249         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
 250                 framePtr = framePtr->callerVarPtr) {
 251             if (framePtr->level == level) {
 252                 break;
 253             }
 254         }
 255         if (framePtr == NULL) {
 256             goto levelError;
 257         }
 258     }
 259     *framePtrPtr = framePtr;
 260     return result;
 261 }
 262 \f
 263 /*
 264  *----------------------------------------------------------------------
 265  *
 266  * Tcl_UplevelCmd --
 267  *
 268  *      This procedure is invoked to process the "uplevel" Tcl command.
 269  *      See the user documentation for details on what it does.
 270  *
 271  * Results:
 272  *      A standard Tcl result value.
 273  *
 274  * Side effects:
 275  *      See the user documentation.
 276  *
 277  *----------------------------------------------------------------------
 278  */
 279
 280         /* ARGSUSED */
 281 int
 282 Tcl_UplevelCmd(dummy, interp, argc, argv)
 283     ClientData dummy;                   /* Not used. */
 284     Tcl_Interp *interp;                 /* Current interpreter. */
 285     int argc;                           /* Number of arguments. */
 286     char **argv;                        /* Argument strings. */
 287 {
 288     register Interp *iPtr = (Interp *) interp;
 289     int result;
 290     CallFrame *savedVarFramePtr, *framePtr;
 291
 292     if (argc < 2) {
 293         uplevelSyntax:
 294         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 295                 " ?level? command ?arg ...?\"", (char *) NULL);
 296         return TCL_ERROR;
 297     }
 298
 299     /*
 300      * Find the level to use for executing the command.
 301      */
 302
 303     result = TclGetFrame(interp, argv[1], &framePtr);
 304     if (result == -1) {
 305         return TCL_ERROR;
 306     }
 307     argc -= (result+1);
 308     if (argc == 0) {
 309         goto uplevelSyntax;
 310     }
 311     argv += (result+1);
 312
 313     /*
 314      * Modify the interpreter state to execute in the given frame.
 315      */
 316
 317     savedVarFramePtr = iPtr->varFramePtr;
 318     iPtr->varFramePtr = framePtr;
 319
 320     /*
 321      * Execute the residual arguments as a command.
 322      */
 323
 324     if (argc == 1) {
 325         result = Tcl_Eval(interp, argv[0]);
 326     } else {
 327         char *cmd;
 328
 329         cmd = Tcl_Concat(argc, argv);
 330         result = Tcl_Eval(interp, cmd);
 331         ckfree(cmd);
 332     }
 333     if (result == TCL_ERROR) {
 334         char msg[60];
 335         sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
 336         Tcl_AddErrorInfo(interp, msg);
 337     }
 338
 339     /*
 340      * Restore the variable frame, and return.
 341      */
 342
 343     iPtr->varFramePtr = savedVarFramePtr;
 344     return result;
 345 }
 346 \f
 347 /*
 348  *----------------------------------------------------------------------
 349  *
 350  * TclFindProc --
 351  *
 352  *      Given the name of a procedure, return a pointer to the
 353  *      record describing the procedure.
 354  *
 355  * Results:
 356  *      NULL is returned if the name doesn't correspond to any
 357  *      procedure.  Otherwise the return value is a pointer to
 358  *      the procedure's record.
 359  *
 360  * Side effects:
 361  *      None.
 362  *
 363  *----------------------------------------------------------------------
 364  */
 365
 366 Proc *
 367 TclFindProc(iPtr, procName)
 368     Interp *iPtr;               /* Interpreter in which to look. */
 369     char *procName;             /* Name of desired procedure. */
 370 {
 371     Tcl_HashEntry *hPtr;
 372     Command *cmdPtr;
 373
 374     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
 375     if (hPtr == NULL) {
 376         return NULL;
 377     }
 378     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
 379     if (cmdPtr->proc != InterpProc) {
 380         return NULL;
 381     }
 382     return (Proc *) cmdPtr->clientData;
 383 }
 384 \f
 385 /*
 386  *----------------------------------------------------------------------
 387  *
 388  * TclIsProc --
 389  *
 390  *      Tells whether a command is a Tcl procedure or not.
 391  *
 392  * Results:
 393  *      If the given command is actuall a Tcl procedure, the
 394  *      return value is the address of the record describing
 395  *      the procedure.  Otherwise the return value is 0.
 396  *
 397  * Side effects:
 398  *      None.
 399  *
 400  *----------------------------------------------------------------------
 401  */
 402
 403 Proc *
 404 TclIsProc(cmdPtr)
 405     Command *cmdPtr;            /* Command to test. */
 406 {
 407     if (cmdPtr->proc == InterpProc) {
 408         return (Proc *) cmdPtr->clientData;
 409     }
 410     return (Proc *) 0;
 411 }
 412 \f
 413 /*
 414  *----------------------------------------------------------------------
 415  *
 416  * InterpProc --
 417  *
 418  *      When a Tcl procedure gets invoked, this routine gets invoked
 419  *      to interpret the procedure.
 420  *
 421  * Results:
 422  *      A standard Tcl result value, usually TCL_OK.
 423  *
 424  * Side effects:
 425  *      Depends on the commands in the procedure.
 426  *
 427  *----------------------------------------------------------------------
 428  */
 429
 430 static int
 431 InterpProc(clientData, interp, argc, argv)
 432     ClientData clientData;      /* Record describing procedure to be
 433                                  * interpreted. */
 434     Tcl_Interp *interp;         /* Interpreter in which procedure was
 435                                  * invoked. */
 436     int argc;                   /* Count of number of arguments to this
 437                                  * procedure. */
 438     char **argv;                /* Argument values. */
 439 {
 440     register Proc *procPtr = (Proc *) clientData;
 441     register Arg *argPtr;
 442     register Interp *iPtr;
 443     char **args;
 444     CallFrame frame;
 445     char *value;
 446     int result;
 447
 448     /*
 449      * Set up a call frame for the new procedure invocation.
 450      */
 451
 452     iPtr = procPtr->iPtr;
 453     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
 454     if (iPtr->varFramePtr != NULL) {
 455         frame.level = iPtr->varFramePtr->level + 1;
 456     } else {
 457         frame.level = 1;
 458     }
 459     frame.argc = argc;
 460     frame.argv = argv;
 461     frame.callerPtr = iPtr->framePtr;
 462     frame.callerVarPtr = iPtr->varFramePtr;
 463     iPtr->framePtr = &frame;
 464     iPtr->varFramePtr = &frame;
 465     iPtr->returnCode = TCL_OK;
 466
 467     /*
 468      * Match the actual arguments against the procedure's formal
 469      * parameters to compute local variables.
 470      */
 471
 472     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
 473             argPtr != NULL;
 474             argPtr = argPtr->nextPtr, args++, argc--) {
 475
 476         /*
 477          * Handle the special case of the last formal being "args".  When
 478          * it occurs, assign it a list consisting of all the remaining
 479          * actual arguments.
 480          */
 481
 482         if ((argPtr->nextPtr == NULL)
 483                 && (strcmp(argPtr->name, "args") == 0)) {
 484             if (argc < 0) {
 485                 argc = 0;
 486             }
 487             value = Tcl_Merge(argc, args);
 488             Tcl_SetVar(interp, argPtr->name, value, 0);
 489             ckfree(value);
 490             argc = 0;
 491             break;
 492         } else if (argc > 0) {
 493             value = *args;
 494         } else if (argPtr->defValue != NULL) {
 495             value = argPtr->defValue;
 496         } else {
 497             Tcl_AppendResult(interp, "no value given for parameter \"",
 498                     argPtr->name, "\" to \"", argv[0], "\"",
 499                     (char *) NULL);
 500             result = TCL_ERROR;
 501             goto procDone;
 502         }
 503         Tcl_SetVar(interp, argPtr->name, value, 0);
 504     }
 505     if (argc > 0) {
 506         Tcl_AppendResult(interp, "called \"", argv[0],
 507                 "\" with too many arguments", (char *) NULL);
 508         result = TCL_ERROR;
 509         goto procDone;
 510     }
 511
 512     /*
 513      * Invoke the commands in the procedure's body.
 514      */
 515
 516     procPtr->refCount++;
 517     result = Tcl_Eval(interp, procPtr->command);
 518     procPtr->refCount--;
 519     if (procPtr->refCount <= 0) {
 520         CleanupProc(procPtr);
 521     }
 522     if (result == TCL_RETURN) {
 523         result = TclUpdateReturnInfo(iPtr);
 524     } else if (result == TCL_ERROR) {
 525         char msg[100];
 526
 527         /*
 528          * Record information telling where the error occurred.
 529          */
 530
 531         sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
 532                 iPtr->errorLine);
 533         Tcl_AddErrorInfo(interp, msg);
 534     } else if (result == TCL_BREAK) {
 535         iPtr->result = "invoked \"break\" outside of a loop";
 536         result = TCL_ERROR;
 537     } else if (result == TCL_CONTINUE) {
 538         iPtr->result = "invoked \"continue\" outside of a loop";
 539         result = TCL_ERROR;
 540     }
 541
 542     /*
 543      * Delete the call frame for this procedure invocation (it's
 544      * important to remove the call frame from the interpreter
 545      * before deleting it, so that traces invoked during the
 546      * deletion don't see the partially-deleted frame).
 547      */
 548
 549     procDone:
 550     iPtr->framePtr = frame.callerPtr;
 551     iPtr->varFramePtr = frame.callerVarPtr;
 552
 553     /*
 554      * The check below is a hack.  The problem is that there could be
 555      * unset traces on the variables, which cause scripts to be evaluated.
 556      * This will clear the ERR_IN_PROGRESS flag, losing stack trace
 557      * information if the procedure was exiting with an error.  The
 558      * code below preserves the flag.  Unfortunately, that isn't
 559      * really enough:  we really should preserve the errorInfo variable
 560      * too (otherwise a nested error in the trace script will trash
 561      * errorInfo).  What's really needed is a general-purpose
 562      * mechanism for saving and restoring interpreter state.
 563      */
 564
 565     if (iPtr->flags & ERR_IN_PROGRESS) {
 566         TclDeleteVars(iPtr, &frame.varTable);
 567         iPtr->flags |= ERR_IN_PROGRESS;
 568     } else {
 569         TclDeleteVars(iPtr, &frame.varTable);
 570     }
 571     return result;
 572 }
 573 \f
 574 /*
 575  *----------------------------------------------------------------------
 576  *
 577  * ProcDeleteProc --
 578  *
 579  *      This procedure is invoked just before a command procedure is
 580  *      removed from an interpreter.  Its job is to release all the
 581  *      resources allocated to the procedure.
 582  *
 583  * Results:
 584  *      None.
 585  *
 586  * Side effects:
 587  *      Memory gets freed, unless the procedure is actively being
 588  *      executed.  In this case the cleanup is delayed until the
 589  *      last call to the current procedure completes.
 590  *
 591  *----------------------------------------------------------------------
 592  */
 593
 594 static void
 595 ProcDeleteProc(clientData)
 596     ClientData clientData;              /* Procedure to be deleted. */
 597 {
 598     Proc *procPtr = (Proc *) clientData;
 599
 600     procPtr->refCount--;
 601     if (procPtr->refCount <= 0) {
 602         CleanupProc(procPtr);
 603     }
 604 }
 605 \f
 606 /*
 607  *----------------------------------------------------------------------
 608  *
 609  * CleanupProc --
 610  *
 611  *      This procedure does all the real work of freeing up a Proc
 612  *      structure.  It's called only when the structure's reference
 613  *      count becomes zero.
 614  *
 615  * Results:
 616  *      None.
 617  *
 618  * Side effects:
 619  *      Memory gets freed.
 620  *
 621  *----------------------------------------------------------------------
 622  */
 623
 624 static void
 625 CleanupProc(procPtr)
 626     register Proc *procPtr;             /* Procedure to be deleted. */
 627 {
 628     register Arg *argPtr;
 629
 630     ckfree((char *) procPtr->command);
 631     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
 632         Arg *nextPtr = argPtr->nextPtr;
 633
 634         ckfree((char *) argPtr);
 635         argPtr = nextPtr;
 636     }
 637     ckfree((char *) procPtr);
 638 }
 639 \f
 640 /*
 641  *----------------------------------------------------------------------
 642  *
 643  * TclUpdateReturnInfo --
 644  *
 645  *      This procedure is called when procedures return, and at other
 646  *      points where the TCL_RETURN code is used.  It examines fields
 647  *      such as iPtr->returnCode and iPtr->errorCode and modifies
 648  *      the real return status accordingly.
 649  *
 650  * Results:
 651  *      The return value is the true completion code to use for
 652  *      the procedure, instead of TCL_RETURN.
 653  *
 654  * Side effects:
 655  *      The errorInfo and errorCode variables may get modified.
 656  *
 657  *----------------------------------------------------------------------
 658  */
 659
 660 int
 661 TclUpdateReturnInfo(iPtr)
 662     Interp *iPtr;               /* Interpreter for which TCL_RETURN
 663                                  * exception is being processed. */
 664 {
 665     int code;
 666
 667     code = iPtr->returnCode;
 668     iPtr->returnCode = TCL_OK;
 669     if (code == TCL_ERROR) {
 670         Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
 671                 (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
 672                 TCL_GLOBAL_ONLY);
 673         iPtr->flags |= ERROR_CODE_SET;
 674         if (iPtr->errorInfo != NULL) {
 675             Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
 676                     iPtr->errorInfo, TCL_GLOBAL_ONLY);
 677             iPtr->flags |= ERR_IN_PROGRESS;
 678         }
 679     }
 680     return code;
 681 }