/* Agent Tcl
 * Bob Gray
 * 25 January 1995
 *
 * *** NOT PART OF THE STANDARD TCL DISTRIBUTION ***
 *
 * This is part of the code that is used to capture and restore the interal
 * state of an executing Tcl script. 
 * 
 * tclStateLoad.c --
 * 
 *      This file contains a collection of procedures that are used to 
 *      loading the state of a previously suspended TCL program.
 *   
 * Copyright (c) 1995, Robert S. Gray, Dartmouth College
 *
 * See the file "agent.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

static int TclLoadVariableTable 
	_ANSI_ARGS_((Tcl_Interp *interp, Tcl_HashTable *upvarTable, Tcl_HashTable *table, 
	char *state));
static int TclLoadVariable 
	_ANSI_ARGS_((Tcl_Interp *interp, Tcl_HashTable *upvarTable, Tcl_HashTable *table, 
	char *state));
static int TclLoadCallFrames 
	_ANSI_ARGS_((Tcl_Interp *interp, Tcl_HashTable *upvarTable, char *state));
static int TclLoadProcedureTable _ANSI_ARGS_((Tcl_Interp *interp, char *state));
static int TclLoadStack _ANSI_ARGS_((Tcl_Interp *interp, char *state)); 
static int TclLoadGlobals _ANSI_ARGS_((Tcl_Interp *interp, char *state));

/* TclLoadProcedureTable

   Purpose:
     Input:
    Output:
*/

static int TclLoadProcedureTable (interp, state)
     Tcl_Interp *interp;
     char *state;
{
  int flags = TCL_PROC | TCL_TRANSFER | TCL_INTERRUPT;
  int name_length, value_length;
  int ip;
  int ap;
  int num_procedures, num_elements, num_args;
  char **procedures, **elements, **args;
  Proc *proc;
  Arg *arg;
  Arg *arg_ptr;

    /* split the list into one entry per procedure */

  if (Tcl_SplitList (interp, state, &num_procedures, &procedures) != TCL_OK)
    return TCL_ERROR;

    /* loop through each procedure */

  for (ip = 0; ip < num_procedures; ip++)
  {
      /* split each procedure entry into its consituent elements */
      /* elements[0] = procedure name                            */
      /* elements[1] = reference count                           */
      /* elements[2] = argument list                             */
      /* elements[3] = procedure body                            */
 
    if (Tcl_SplitList (interp, procedures[ip], &num_elements, &elements) != TCL_OK)
      return TCL_ERROR;

      /* allocate the procedure entry */

    proc            = (Proc *) ckalloc (sizeof(Proc));
    proc -> argPtr  = NULL;
    proc -> command = ckalloc (strlen(elements[3]) + 1);
    strcpy (proc -> command, elements[3]);

    if (Tcl_GetInt(interp, elements[1], &proc -> refCount) != TCL_OK)
      return TCL_ERROR;

      /* split apart the argument list */

    if (Tcl_SplitList (interp, elements[2], &num_args, &args) != TCL_OK)
      return TCL_ERROR;

    ap      = 0;
    arg_ptr = NULL;

    while (ap < num_args)
    {
       name_length = strlen(args[ap]) + 1;

       if (!strcmp(args[ap+1], "_NO_DEFAULT_"))
       {
         arg = (Arg *) ckalloc (sizeof(Arg) - sizeof(arg -> name) + name_length);
         strcpy (arg -> name, args[ap]);
         arg -> defValue = NULL;
         ap += 2;
       }
       else
       {
         value_length = strlen(args[ap+2]) + 1;
         arg = (Arg *) ckalloc (sizeof(Arg) - sizeof(arg -> name) + name_length + value_length);
         strcpy (arg -> name, args[ap]);
         strcpy (name_length + arg -> name, args[ap + 2]);
         arg -> defValue = name_length + arg -> name;
         ap += 3;
       }

       if (arg_ptr == NULL)
         proc -> argPtr = arg;
       else
         arg_ptr -> nextPtr = arg;

       arg_ptr        = arg; 
       arg -> nextPtr = NULL;
    }

    TclCreateCommand (interp,  elements[0], InterpProc, (ClientData) proc, ProcDeleteProc, flags);
    free ((char *) args);
    free ((char *) elements);  
  } 

  free ((char *) procedures);
  return TCL_OK;
}

/* TclLoadVariableTable

   Purpose:

     Input: interp = the interpreter
            table  = hash table that contains the variables
	    state  = global variable state

    Output:
*/

static int TclLoadVariable(interp, upvarTable, table, state)
     Tcl_Interp *interp;
     Tcl_HashTable *upvarTable;
     Tcl_HashTable *table;
     char *state;
{
  int num_elements;      /* number of elements in the variable definition */
  char **elements;       /* the elements of the variable definition       */
  Tcl_HashEntry *hPtr;   /* pointer to the hash entry                     */ 
  Var *varPtr;           /* pointer to the variable entry                 */
  int dummy;

    /* split the variable definition into its elements */
    /* elements[0] = _DEFINED_ or _UNDEFINED_          */
    /* elements[1] = name of the variable              */
    /* elements[2] = reference count                   */
    /* elements[3] = _UPVAR_, _ARRAY_ or _VALUE_       */
    /* elements[4] = upvar id, array entries or value  */
    /* elements[5] = upvar id if ref count above 0     */

  if (Tcl_SplitList (interp, state, &num_elements, &elements) != TCL_OK) {
    return TCL_ERROR;
  }

  varPtr = TclNewVar ();
 
  if (!strcmp(elements[0], "_DEFINED_")) {
    varPtr -> flags &= ~VAR_UNDEFINED;
  }

  if (Tcl_GetInt (interp, elements[2], &varPtr -> refCount) != TCL_OK) {
    return TCL_ERROR;
  } 

  if (varPtr -> refCount > 0) {
    hPtr = Tcl_CreateHashEntry (upvarTable, elements[5], &dummy);
    Tcl_SetHashValue (hPtr, (ClientData) varPtr);
  }
 
  if (!strcmp (elements[3], "_UPVAR_")) {

    varPtr -> flags |= VAR_UPVAR;

    if (!strcmp (elements[4], "0")) {
      varPtr -> value.upvarPtr = TclNewVar ();
      varPtr -> value.upvarPtr -> refCount = 1;
    } else if ((hPtr = Tcl_FindHashEntry (upvarTable, elements[4])) == NULL) {
      return TCL_ERROR;
    } else {
      varPtr -> value.upvarPtr = (Var *) Tcl_GetHashValue (hPtr);
    }

  } else if (!strcmp (elements[3], "_VALUE_")) {

    varPtr -> valueLength  = strlen(elements[4]);
    varPtr -> value.string = ckalloc ((unsigned long) varPtr -> valueLength + 1);
    strcpy (varPtr -> value.string, elements[4]); 
    varPtr -> valueSpace   = varPtr -> valueLength;

  } else {

    varPtr -> flags |= VAR_ARRAY;
    varPtr -> value.tablePtr = (Tcl_HashTable *) ckalloc ((unsigned long) sizeof(Tcl_HashTable));
    Tcl_InitHashTable (varPtr -> value.tablePtr, TCL_STRING_KEYS);
    TclLoadVariableTable (interp, upvarTable, varPtr -> value.tablePtr, elements[4]);    
  } 
 
  hPtr = Tcl_CreateHashEntry (table, elements[1], &dummy);
  varPtr -> hPtr = hPtr;
  Tcl_SetHashValue (hPtr, varPtr); 
  ckfree ((char *) elements);
  return TCL_OK;
}
 
static int TclLoadVariableTable (interp, upvarTable, table, state)
     Tcl_Interp *interp;
     Tcl_HashTable *upvarTable;
     Tcl_HashTable *table;
     char *state;
{
  int num_variables;    /* number of variables         */
  char **variables;     /* one entry for each variable */
  int iv;               /* variable counter            */

  if (Tcl_SplitList (interp, state, &num_variables, &variables) != TCL_OK) {
    return TCL_ERROR;
  }

  for (iv = 0; iv < num_variables; iv++) {
    if (TclLoadVariable (interp, upvarTable, table, variables[iv]) != TCL_OK) {
      return TCL_ERROR;
    }
  }

  ckfree ((char *) variables);
  return TCL_OK; 
}

/* TclLoadCallFrames

   Purpose:

     Input:

    Output:
*/

static int TclLoadCallFrames (interp, upvarTable, state)
     Tcl_Interp *interp;
     Tcl_HashTable *upvarTable;
     char *state;
{
  Interp *iPtr = (Interp *) interp;
  CallFrame** frames;                
  int num_callframe, num_element;
  char **callframe, **element;
  int i, levelCaller;

    /* split apart the call frames */
 
  if (Tcl_SplitList (interp, state, &num_callframe, &callframe) != TCL_OK) {
    return TCL_ERROR;
  }

    /* load the call frames */

  frames    = (CallFrame **) ckalloc ((unsigned long) num_callframe * sizeof(char *));
  frames[0] = NULL;

  for (i = 1; i < num_callframe; i++) {

    frames[i] = (CallFrame *) ckalloc ((unsigned long) sizeof(CallFrame));
    frames[i] -> level = i;
    frames[i] -> callerPtr = frames[i - 1];
    Tcl_InitHashTable (&frames[i] -> varTable, TCL_STRING_KEYS);

       /* split apart the call frame information */
       /* elements[0] = var level                */
       /* elements[1] = caller var level         */
       /* elements[2] = variable table           */
       /* elements[3] = stack index              */
 
     if (Tcl_SplitList (interp, callframe[num_callframe - i], &num_element, &element) != TCL_OK) {
       return TCL_ERROR;
     }

     if (Tcl_GetInt(interp, element[0], &frames[i] -> varLevel) != TCL_OK) {
       return TCL_ERROR;
     }

     if (Tcl_GetInt(interp, element[1], &levelCaller) != TCL_OK) {
       return TCL_ERROR;
     }

     if (TclLoadVariableTable (interp, upvarTable, &frames[i] -> varTable, element[2]) != TCL_OK) {
       return TCL_ERROR;
     }

     if (Tcl_GetInt(interp, element[3], &frames[i] -> stackIndex) != TCL_OK) {
       return TCL_ERROR;
     }

     frames[i] -> callerVarPtr = frames[levelCaller];
     ckfree ((char *) element);
  }

    /* set up the interpreter pointers */

  if (Tcl_GetInt (interp, callframe[0], &levelCaller) != TCL_OK)
    return TCL_ERROR;

  iPtr -> framePtr    = frames[num_callframe - 1];
  iPtr -> varFramePtr = frames[levelCaller];
  ckfree ((char *) callframe);
  ckfree ((char *) frames);
  return TCL_OK;   
}   

/* Tcl_LoadStack

   Purpose:
     Input:
    Output:
*/

static int TclLoadStack (interp, state)
     Tcl_Interp *interp;
     char *state;
{
  Interp *iPtr = (Interp *) interp;
  Stack *stack = &iPtr -> execution_stack;
  Stack_Element *topStack;
  int i, stateFlag;
  int num_stack_elements, num_elements, num_args;
  char **stack_elements, **elements, **args;

    /* split out the the stack elements */

  if (Tcl_SplitList (interp, state, &num_stack_elements, &stack_elements) != TCL_OK)
    return TCL_ERROR;
  
  for (i = 0; i < num_stack_elements; i++)
  {
    /* split out the parts of a stack element  */
    /* elements[0] = state flag                */
    /* elements[1] = current substitution      */
    /* elements[2] = TCL_BRACKET_TERM flag     */
    /* elements[3] = TCL_RECORD_BOUNDS flag    */
    /* elements[4] = TCL_ALLOW_EXCEPTIONS flag */
    /* elements[5] = arguments                 */
    
    if (Tcl_SplitList (interp, stack_elements[i], &num_elements, &elements) != TCL_OK)
      return TCL_ERROR;
  
      /* get the state flag */ 
   
    if (Tcl_GetInt (interp, elements[0], &stateFlag) != TCL_OK)
      return TCL_ERROR;  

      /* split out the arguments */

    if (Tcl_SplitList (interp, elements[5], &num_args, &args) != TCL_OK) {
      return TCL_ERROR;
    }

      /* push on the state flag and the "rest of command" */
      /* then set up argc and argv                        */
      /* then get the substitution and the flags          */ 
 
    TclPushStack (stack, stateFlag, args[num_args - 1], TCL_VOLATILE);
    topStack = stack -> slots[stack -> top];
    topStack -> commandFlags = TCL_INTERRUPT;
    topStack -> argc = num_args - 1;

    if (topStack -> argc != 0) {
      topStack -> argv = args;
    }

    if (Tcl_GetInt (interp, elements[1], &topStack -> substitution) != TCL_OK)
      return TCL_OK;

    if (!strcmp(elements[2], "_BRACKET_")) {
      topStack -> termChar   = ']';
      topStack -> evalFlags |= TCL_BRACKET_TERM;
    }

    if (!strcmp(elements[3], "_RECORD_")) {
      topStack -> evalFlags |= TCL_RECORD_BOUNDS;
    }

    if (!strcmp(elements[4], "_EXCEPTION_")) {
      topStack -> evalFlags |= TCL_ALLOW_EXCEPTIONS;
    }
  }

  return TCL_OK;
} 

/* TclLoadGlobals
  
   Purpose: Load the global information

     Input: interp = the current interpreter
            state  = string that contains the global information
 
    Output: The procedure loads the global information into the interpreter.
            Global information consists of the result and return codes,
            the result and error strings, the error line, the global flags, 
            the numeric format and precision, the command count, and the name
            of the current script.
*/

static int TclLoadGlobals (interp, state)
     Tcl_Interp *interp;
     char *state;
{
  Interp *iPtr = (Interp *) interp;
  int num_elements;           /* number of elements in the global state */
  char **elements;            /* the elements themselves                */
  int el = 0;                 /* element counter                        */
   
  if (Tcl_SplitList (interp, state, &num_elements, &elements) != TCL_OK) {
    return TCL_ERROR;
  }

    /*  1. result code */

  if (Tcl_GetInt (interp, elements[el], &iPtr -> resultCode) != TCL_OK) {
    return TCL_ERROR;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /*  2. return code */

  if (Tcl_GetInt (interp, elements[el], &iPtr -> returnCode) != TCL_OK) {
    return TCL_ERROR;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /*  3. result string */

  if (!strcmp(elements[el], "_RESULT_")) {
    if (++el >= num_elements) {
      return TCL_ERROR;
    }
    iPtr -> result = (char *) ckalloc ((unsigned) strlen(elements[el]) + 1);
    strcpy (iPtr -> result, elements[el]); 
    iPtr -> freeProc = (void (*)) free;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /*  4. error info */

  if (!strcmp(elements[el], "_INFO_")) {
    if (++el >= num_elements) {
      return TCL_ERROR;
    }
    iPtr -> errorInfo = (char *) ckalloc ((unsigned) strlen(elements[el]) + 1);
    strcpy (iPtr -> errorInfo, elements[el]); 
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /*  5. error code */

  if (!strcmp(elements[el], "_CODE_")) {
    if (++el >= num_elements) {
      return TCL_ERROR;
    }
    iPtr -> errorCode = (char *) ckalloc ((unsigned) strlen(elements[el]) + 1);
    strcpy (iPtr -> errorCode, elements[el]); 
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /*  6. error line */

  if (Tcl_GetInt (interp, elements[el], &iPtr -> errorLine) != TCL_OK) {
    return TCL_ERROR;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /*  7. DELETED            flag */
    /*  8. ERR_IN_PROGRESS    flag */
    /*  9. ERR_ALREADY_LOGGED flag */
    /* 10. ERROR_CODE_SET     flag */

  if (!strcmp(elements[el], "_DELETED_")) {
    iPtr -> flags |= DELETED; 
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

  if (!strcmp(elements[el], "_ERR_IN_PROGRESS_")) {
    iPtr -> flags |= ERR_IN_PROGRESS;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

  if (!strcmp(elements[el], "_ERR_ALREADY_LOGGED_")) {
    iPtr -> flags |= ERR_ALREADY_LOGGED;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

  if (!strcmp(elements[el], "_ERROR_CODE_SET_")) {
    iPtr -> flags |= ERROR_CODE_SET; 
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /* 11. filename of the current script */

  if (!strcmp(elements[el], "_SCRIPT_")) {
    if (++el >= num_elements) {
      return TCL_ERROR;
    }
    iPtr -> scriptFile = (char *) ckalloc ((unsigned) strlen(elements[el]) + 1);
    strcpy (iPtr -> scriptFile, elements[el]); 
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /* 12. format string     */
    /* 13. numeric precision */

  if (strlen(elements[el]) >= 10) {
    return TCL_ERROR;
  }
  strcpy (iPtr -> pdFormat, elements[el]);
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

  if (Tcl_GetInt (interp, elements[el], &iPtr -> pdPrec) != TCL_OK) {
    return TCL_ERROR;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }

    /* 14. command count */

  if (Tcl_GetInt (interp, elements[el], &iPtr -> cmdCount) != TCL_OK) {
    return TCL_ERROR;
  }
  if (++el >= num_elements) {
    return TCL_ERROR;
  }
  
    /* 15. no eval flag */

  if (Tcl_GetInt (interp, elements[el], &iPtr -> noEval) != TCL_OK) {
    return TCL_ERROR;
  }

  return TCL_OK;
}


 
/* Tcl_LoadState

   Purpose:
     Input:
    Output:
*/

int Tcl_LoadState (interp, state, error)
     Tcl_Interp *interp;
     char *state;
     Tcl_DString *error;
{
   char **elements;
   int num_elements;
   CallFrame **frames;
   int code = TCL_ERROR;
   Tcl_HashTable upvarTable;
   Interp *iPtr = (Interp *) interp; 
#ifdef TCL_STATE_HANDLERS
   int i;
   int argc;
   int newFlag;
   Tcl_HashEntry *hPtr;
   char **argv = (char **) NULL;
   EXTENSION_STATE *extension = (EXTENSION_STATE *) NULL;
#endif

     /* check for the empty string */

   if (state == NULL) {
     return TCL_OK;
   }

     /* split out the parts of the state               */
     /* elements[0] = global variable table            */
     /* elements[1] = call frames                      */
     /* elements[2] = procedures                       */
     /* elements[3] = execution stack                  */
     /* elements[4] = globals                          */
     /* elements[5] = state variables                  */

   if (Tcl_SplitList (interp, state, &num_elements, &elements) != TCL_OK) {
     return TCL_ERROR;
   } else if (num_elements <= 5) {
     ckfree ((char *) elements);
     return TCL_ERROR;
   }

   Tcl_InitHashTable (&upvarTable, TCL_STRING_KEYS);
 
      /* load the global variable table, the callframes, the procedures, */
      /* the execution stack and the globals                             */

   if (TclLoadVariableTable (interp, &upvarTable, &iPtr -> globalTable, elements[0]) != TCL_OK) {
     Tcl_DStringAppend (error, ":unable to load global variable table ", -1);
     goto cleanup;
   } 

   if (TclLoadCallFrames (interp, &upvarTable, elements[1]) != TCL_OK) {
     Tcl_DStringAppend (error, ":unable to load call frames ", -1);
     goto cleanup;
   }

   if (TclLoadProcedureTable (interp, elements[2]) != TCL_OK) {
     Tcl_DStringAppend (error, ":unable to load defined procedures ", -1);
     goto cleanup;
   }

   if (TclLoadStack (interp, elements[3]) != TCL_OK) {
     Tcl_DStringAppend (error, ":unable to load execution stack ", -1);
     goto cleanup;
   }

   if (TclLoadGlobals (interp, elements[4]) != TCL_OK) {
     Tcl_DStringAppend (error, ":unable to load globals ", -1);
     goto cleanup;
   }

   if (TclLoadVariableTable (interp, &upvarTable, &iPtr -> stateTable, elements[5]) != TCL_OK) {
     Tcl_DStringAppend (error, ":unable to load state variables ", -1);
     goto cleanup;
   }

#ifdef TCL_STATE_HANDLERS

     /* break out the extension state */

   for (i = 6; i < num_elements; i++) {

     if ((Tcl_SplitList (interp, elements[i], &argc, &argv) != TCL_OK) || (argc <= 4)) {
       break;
     }

       /* new EXTENSION_STATE structure */

     extension = (EXTENSION_STATE *) ckalloc ((unsigned) sizeof(EXTENSION_STATE));
     Tcl_DStringInit (&extension -> state);
     Tcl_DStringInit (&extension -> error);

       /* symbolic name */

     extension -> name = (char *) ckalloc ((unsigned) strlen(argv[0]) + 1);
     strcpy (extension -> name, argv[0]);
	
       /* major and minor number */

     if (Tcl_GetInt (interp, argv[1], &extension -> major) != TCL_OK) {
       break;
     }

     if (Tcl_GetInt (interp, argv[2], &extension -> minor) != TCL_OK) {
       break;
     }

	/* alpha, beta or production */

     if (!strcmp(argv[3], "ALPHA")) {
       extension -> type = TCL_ALPHA;
     } else if (!strcmp(argv[3], "BETA")) {
       extension -> type = TCL_BETA;
     } else if (!strcmp(argv[3], "PRODUCTION")) {
       extension -> type = TCL_PRODUCTION;
     } else {
       break;
     }

       /* extension state */

     Tcl_DStringAppend (&extension -> state, argv[4], -1);

       /* put it into the hash table */

     hPtr = Tcl_CreateHashEntry (&iPtr -> extenState, extension -> name, &newFlag);

     if (!newFlag) {
       break;
     }
 
     Tcl_SetHashValue (hPtr, (ClientData) extension);
     ckfree ((void *) argv);
     extension = NULL;
     argv = NULL;
   }

   if (argv != NULL) {
     ckfree ((char *) argv);
   }

   if (extension != NULL) {
     Tcl_DStringFree (&extension -> error);
     Tcl_DStringFree (&extension -> state);
     ckfree ((char *) extension);
   }

   code = (i == num_elements) ? TCL_OK : TCL_ERROR;

#else

   code = TCL_OK;

#endif    /* TCL_STATE_HANDLERS */

cleanup: 

   Tcl_DeleteHashTable (&upvarTable);
   free ((char *) elements);   
   return (code);
}
