LibMkKernel_extension_atl.c

Go to the documentation of this file.

 
/* LABEL-NO */
 
#include "LibMkKernel_private_atl.h"
#include "tclInt.h"
 
#ifndef Atl_EvalObjv
 
// *********************************************************************
// ATL Eval
 
/*
 *----------------------------------------------------------------------
 *
 * EvalObjv --
 *
 *  This procedure evaluates a Tcl command that has already been
 *  parsed into words, with one Tcl_Obj holding each word.
 *
 * Results:
 *  The return value is a standard Tcl completion code such as
 *  TCL_OK or TCL_ERROR.  A result or error message is left in
 *  interp's result.  If an error occurs, this procedure does
 *  NOT add any information to the errorInfo variable.
 *
 * Side effects:
 *  Depends on the command.
 *
 *----------------------------------------------------------------------
 */
 
static int
EvalObjv(
    Tcl_Interp *interp,   /* Interpreter in which to evaluate the
         * command.  Also used for error
         * reporting. */
    int objc,     /* Number of words in command. */
    Tcl_Obj *CONST objv[],  /* An array of pointers to objects that are
         * the words that make up the command. */
    char *command,    /* Points to the beginning of the string
         * representation of the command; this
         * is used for traces.  If the string
         * representation of the command is
         * unknown, an empty string should be
         * supplied. */
    int length,     /* Number of bytes in command; if -1, all
         * characters up to the first null byte are
         * used. */
    int flags       /* Collection of OR-ed bits that control
         * the evaluation of the script.  Only
         * TCL_EVAL_GLOBAL is currently
         * supported. */
) {
  Command *cmdPtr;
  Interp *iPtr = (Interp *) interp;
  Tcl_Obj **newObjv;
  int i, code;
  Trace *tracePtr, *nextPtr;
  //char **argv, *commandCopy;
  char *commandCopy;
  CallFrame *savedVarFramePtr;  /* Saves old copy of iPtr->varFramePtr
         * in case TCL_EVAL_GLOBAL was set. */
 
  Tcl_ResetResult(interp);
  if (objc == 0) {
    return TCL_OK;
  }
 
  /*
   * If the interpreter was deleted, return an error.
   */
  
  if (iPtr->flags & DELETED) {
    Tcl_AppendToObj(Tcl_GetObjResult(interp),
      "attempt to call eval in deleted interpreter", -1);
    Tcl_SetErrorCode(interp, "CORE", "IDELETE",
      "attempt to call eval in deleted interpreter",
      (char *) NULL);
    return TCL_ERROR;
  }
 
  /*
   * Check depth of nested calls to Tcl_Eval:  if this gets too large,
   * it's probably because of an infinite loop somewhere.
   */
 
  if (iPtr->numLevels >= iPtr->maxNestingDepth) {
    iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
    return TCL_ERROR;
  }
  iPtr->numLevels++;
 
#if 0
  /*
   * On the Mac, we will never reach the default recursion limit before
   * blowing the stack. So we need to do a check here.
   */
  
  if (TclpCheckStackSpace() == 0) {
    /*NOTREACHED*/
    iPtr->numLevels--;
    iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
    return TCL_ERROR;
  }
#endif
  
  /*
   * Find the procedure to execute this command. If there isn't one,
   * then see if there is a command "unknown".  If so, create a new
   * word array with "unknown" as the first word and the original
   * command words as arguments.  Then call ourselves recursively
   * to execute it.
   */
  
  cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
  if (cmdPtr == NULL) {
    newObjv = (Tcl_Obj **) ckalloc( (((unsigned)objc + 1) * (unsigned) sizeof (Tcl_Obj *)));
    for (i = objc-1; i >= 0; i--) {
      newObjv[i+1] = objv[i];
    }
    newObjv[0] = Tcl_NewStringObj("unknown", -1);
    Tcl_IncrRefCount(newObjv[0]);
    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
    if (cmdPtr == NULL) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
        "invalid command name \"", Tcl_GetString(objv[0]), "\"",
        (char *) NULL);
      code = TCL_ERROR;
    } else {
      code = EvalObjv(interp, objc+1, newObjv, command, length, 0);
    }
    Tcl_DecrRefCount(newObjv[0]);
    ckfree((char *) newObjv);
    goto done;
  }
  
  /*
   * Call trace procedures if needed.
   */
 
//  argv = NULL;
  commandCopy = command;
 
  for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) {
    nextPtr = tracePtr->nextPtr;
    if (iPtr->numLevels > tracePtr->level) {
      continue;
    }
 
    /*
     * This is a bit messy because we have to emulate the old trace
     * interface, which uses strings for everything.
     */
 
/*
    if (argv == NULL) {
      argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
      for (i = 0; i < objc; i++) {
        argv[i] = Tcl_GetString(objv[i]);
      }
      argv[objc] = 0;
    }
*/
 
    if (length < 0) {
      length = (int) strlen(command);
    } else if ((size_t)length < strlen(command)) {
      commandCopy = (char *) ckalloc((unsigned) (length + 1));
      strncpy(commandCopy, command, (size_t) length);
      commandCopy[length] = 0;
    }
    // Tcl_CmdObjTraceProc
    (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
          commandCopy, (Tcl_Command) cmdPtr, objc, objv);
  }
/*
  if (argv != NULL) {
    ckfree((char *) argv);
  }
*/
  if (commandCopy != command) {
    ckfree((char *) commandCopy);
  }
    
  /*
   * Finally, invoke the command's Tcl_ObjCmdProc.
   */
  
  iPtr->cmdCount++;
  savedVarFramePtr = iPtr->varFramePtr;
  if (flags & TCL_EVAL_GLOBAL) {
    iPtr->varFramePtr = NULL;
  }
  code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
  iPtr->varFramePtr = savedVarFramePtr;
  if (Tcl_AsyncReady()) {
    code = Tcl_AsyncInvoke(interp, code);
  }
 
  /*
   * If the interpreter has a non-empty string result, the result
   * object is either empty or stale because some procedure set
   * interp->result directly. If so, move the string result to the
   * result object, then reset the string result.
   */
  
  if (*(iPtr->result) != 0) {
    (void) Tcl_GetObjResult(interp);
  }
 
  done:
  iPtr->numLevels--;
  return code;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Atl_EvalObjv --
 *
 *  This procedure evaluates a Tcl command that has already been
 *  parsed into words, with one Tcl_Obj holding each word.
 *
 * Results:
 *  The return value is a standard Tcl completion code such as
 *  TCL_OK or TCL_ERROR.  A result or error message is left in
 *  interp's result.
 *
 * Side effects:
 *  Depends on the command.
 *
 *----------------------------------------------------------------------
 */
 
int
Atl_EvalObjv(
  Tcl_Interp *interp,   /* Interpreter in which to evaluate the
       * command.  Also used for error
       * reporting. */
  int objc,     /* Number of words in command. */
  Tcl_Obj *CONST objv[],  /* An array of pointers to objects that are
       * the words that make up the command. */
  int flags       /* Collection of OR-ed bits that control
       * the evaluation of the script.  Only
       * TCL_EVAL_GLOBAL is currently
       * supported. */
) {
  Interp *iPtr = (Interp *)interp;
  Trace *tracePtr;
  Tcl_DString cmdBuf;
  char *cmdString = "";
  int cmdLen = 0;
  int code = TCL_OK;
 
  for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
    /*
     * EvalObjv will increment numLevels so use "<" rather than "<="
     */
    if (iPtr->numLevels < tracePtr->level) {
      int i;
      /*
       * The command will be needed for an execution trace or stack trace
       * generate a command string.
       */
  cmdtraced:
      Tcl_DStringInit(&cmdBuf);
      for (i = 0; i < objc; i++) {
        Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
      }
      cmdString = Tcl_DStringValue(&cmdBuf);
      cmdLen = Tcl_DStringLength(&cmdBuf);
      break;
    }
  }
 
  /*
   * Execute the command if we have not done so already
   */
  switch (code) {
    case TCL_OK:
      code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags);
      if (code == TCL_ERROR && cmdLen == 0)
      goto cmdtraced;
    break;
    case TCL_ERROR:
      Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
    break;
    default:
    /*NOTREACHED*/
    break;
  }
 
  if (cmdLen != 0) {
    Tcl_DStringFree(&cmdBuf);
  }
  return code;
}
 
#endif
 
#if 0
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TryObjCmd, TclNRTryObjCmd --
 *
 *  This procedure is invoked to process the "try" Tcl command. See the
 *  user documentation (or TIP #329) for details on what it does.
 *
 * Results:
 *  A standard Tcl object result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */
 
static int
Tcl_TryObjCmd (
    ClientData      clientData,   /* Not used. */
    Tcl_Interp      *interp,      /* Current interpreter. */
    int             objc,         /* Number of arguments. */
    Tcl_Obj *const  objv[])       /* Argument objects. */
{
  Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
  int i, bodyShared, haveHandlers, dummy, code;
  static const char *const handlerNames[] = {
    "finally", "on", "trap", NULL
  };
  enum Handlers {
    TryFinally, TryOn, TryTrap
  };
 
  /*
   * Parse the arguments. The handlers are passed to subsequent callbacks as
   * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix,
   * bindVariables, script), and the finally script is just passed as it is.
   */
 
  if (objc < 2) {
    Tcl_WrongNumArgs(interp, 1, objv,
      "body ?handler ...? ?finally script?");
    return TCL_ERROR;
  }
  bodyObj = objv[1];
  TclNewObj(handlersObj);
  bodyShared = 0;
  haveHandlers = 0;
  for (i=2 ; i<objc ; i++) {
    int type;
    Tcl_Obj *info[5];
 
    if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type",
      0, &type) != TCL_OK) {
      Tcl_DecrRefCount(handlersObj);
      return TCL_ERROR;
    }
    switch ((enum Handlers) type) {
      case TryFinally:  /* finally script */
        if (i < objc-2) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(
            "finally clause must be last", -1));
          Tcl_DecrRefCount(handlersObj);
          Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
            "NONTERMINAL", NULL);
          return TCL_ERROR;
        } else if (i == objc-1) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(
            "wrong # args to finally clause: must be"
              " \"... finally script\"", -1));
          Tcl_DecrRefCount(handlersObj);
          Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
            "ARGUMENT", NULL);
          return TCL_ERROR;
        }
        finallyObj = objv[++i];
      break;
 
      case TryOn:   /* on code variableList script */
        if (i > objc-4) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(
            "wrong # args to on clause: must be \"... on code"
              " variableList script\"", -1));
          Tcl_DecrRefCount(handlersObj);
          Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
            "ARGUMENT", NULL);
          return TCL_ERROR;
        }
        if (TclGetCompletionCodeFromObj(interp, objv[i+1], &code) != TCL_OK) {
          Tcl_DecrRefCount(handlersObj);
          return TCL_ERROR;
        }
        info[2] = NULL;
        goto commonHandler;
 
      case TryTrap:   /* trap pattern variableList script */
        if (i > objc-4) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj(
            "wrong # args to trap clause: "
              "must be \"... trap pattern variableList script\"",
                -1));
          Tcl_DecrRefCount(handlersObj);
          Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
            "ARGUMENT", NULL);
          return TCL_ERROR;
        }
        code = 1;
        if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
          Tcl_SetObjResult(interp, Tcl_ObjPrintf(
            "bad prefix '%s': must be a list",
          Tcl_GetString(objv[i+1])));
          Tcl_DecrRefCount(handlersObj);
          Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
            "EXNFORMAT", NULL);
          return TCL_ERROR;
        }
        info[2] = objv[i+1];
 
  commonHandler:
        if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
          Tcl_DecrRefCount(handlersObj);
          return TCL_ERROR;
        }
 
        info[0] = objv[i];      /* type */
        TclNewIntObj(info[1], code);  /* returnCode */
        if (info[2] == NULL) {    /* errorCodePrefix */
          TclNewObj(info[2]);
        }
        info[3] = objv[i+2];    /* bindVariables */
        info[4] = objv[i+3];    /* script */
 
        bodyShared = !strcmp(TclGetString(objv[i+3]), "-");
        Tcl_ListObjAppendElement(NULL, handlersObj,
        Tcl_NewListObj(5, info));
        haveHandlers = 1;
        i += 3;
      break;
    }
  }
  if (bodyShared) {
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
      "last non-finally clause must not have a body of \"-\"", -1));
    Tcl_DecrRefCount(handlersObj);
    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
      NULL);
    return TCL_ERROR;
  }
  if (!haveHandlers) {
    Tcl_DecrRefCount(handlersObj);
    handlersObj = NULL;
  }
 
  /*
   * Execute the body.
   */
 
  code = TclEvalObjEx(interp, bodyObj, 0, ((Interp *) interp)->cmdFramePtr, 1);
    if (code
 
  return TclEvalObjEx(interp, bodyObj, 0, ((Interp *) interp)->cmdFramePtr, 1);
}
 
#endif