/* Agent Tcl
   Bob Gray
   12 February 1995

   This file implements the Agent_AppInit procedure and "main".

   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 "platPorting.h"
#include "suppStrings.h"
#include "tcl.h"
#include "agentTcl.h"
#include "tclUtility.h"
#include "requireScript.h"
#include "safetyScript.h"
#ifndef TCL8
#include "initScript.h"
#endif

/*
 * The following string is the startup script executed in new
 * interpreters.  It looks on disk in several different directories
 * for a script "safety.tcl" that is compatible with this version
 * of Tcl.  The safety.tcl script provides safe versions of the unsafe
 * Tcl commands. 
 */

static char initScript[] =
"proc tclInit {} {\n\
    global tcl_library tcl_version tcl_patchLevel env\n\
    rename tclInit {}\n\
    set dirs {}\n\
    if [info exists env(TCL_LIBRARY)] {\n\
	lappend dirs $env(TCL_LIBRARY)\n\
    }\n\
    lappend dirs [info library]\n\
    foreach i $dirs {\n\
	set tcl_library $i\n\
	if ![file exists $i/require.tcl] {\n\
	    continue\n\
	}\n\
	if ![file exists $i/safety.tcl] {\n\
	    continue\n\
	}\n\
	uplevel #0 [list source $i/require.tcl]\n\
	uplevel #0 [list source $i/safety.tcl]\n\
	return\n\
    }\n\
    set msg \"Can't find a usable require.tcl and safety.tcl in the following directories: \n\"\n\
    append msg \"    $dirs\n\"\n\
    append msg \"This probably means that Agent Tcl wasn't installed properly.\n\"\n\
    error $msg\n\
}\n\
tclInit";

static char finalScript[] = 
"proc tclInit {} {\n\
    global tcl_library\n\
    rename tclInit {}\n\
    set fd [open $tcl_library/init.tcl r]\n\
    set code [read $fd]\n\
    close $fd\n\
    set slaves [interp slaves]\n\
    foreach s $slaves {\n\
	$s eval [list uplevel #0 $code]\n\
    }\n\
}\n\
tclInit";

/* Tcl_SafeInit

   Purpose: Perform safe initialization of the Tcl core

     Input: interp       = the Tcl interpreter
		           (struct Tcl_Interp *)

	    masterInterp = the trusted master interpreter
			   (struct Tcl_Interp *)

    Output: The procedure returns TCL_ERROR and sets the interpreter result
	    to an appropriate error message on error.  Otherwise the
	    procedure returns TCL_OK.
*/

int Tcl_SafeInit (Tcl_Interp *interp, Tcl_Interp *masterInterp)
{
    int code;
    char *argv[1];
  
	/*
	 * Assertions on the parameters.
	 */

    assert (interp != NULL);
    assert (masterInterp != NULL);

	/*
	 * Get the slave path
	 */

    code = Tcl_GetInterpPath (masterInterp, interp);
    assert (code == TCL_OK);
    argv[0] = strcpyWithAlloc (masterInterp -> result);

	/*
	 * Initialize the master interpreter -- first the Tcl initialization
	 */

    if (Tcl_Init(masterInterp) != TCL_OK) {
	Tcl_TransferResult (interp, masterInterp);
	Tcl_AddErrorInfo (interp, "\n    (\"master\" initialization)");
	return TCL_ERROR;
    }

	/*
	 * Then the safe versions of the unsafe Tcl commands
	 */

    if ((string_requireScript != NULL) && (*string_requireScript != '\0') &&
	(string_safetyScript  != NULL) && (*string_safetyScript  != '\0')) { 

#ifdef FIX_LATER
	    /*
	     * we copy the script since Tcl_ParseVar can modify the
	     * script in place (by temporarily replacing the character at
	     * the end of a variable name with a \0 -- we should not have to 
	     * do this
	     */
#endif

	char *script = new char [strlen(string_requireScript) + 1];
	strcpy (script, string_requireScript);
	code = Tcl_GlobalEval (masterInterp, script);
	delete (script);

	if (code == TCL_OK) {
	    script = new char [strlen(string_safetyScript) + 1];
	    strcpy (script, string_safetyScript);
	    code = Tcl_GlobalEval (masterInterp, script);
	    delete (script);
	}

    } else {

	code = Tcl_GlobalEval (masterInterp, initScript);
    }

    if (code != TCL_OK) {
	Tcl_TransferResult (interp, masterInterp);
	Tcl_AddErrorInfo (interp, "\n    (\"master\" initialization)");
	return TCL_ERROR;
    }

	/* 
	 * Then link the unsafe Tcl commands to the safe Tcl commands
	 */

	/* 
	 * Start with the file commands
	 */

    (void) Tcl_CreateAlias (interp, "source", masterInterp, "kernelSource", 1, argv);
    (void) Tcl_CreateAlias (interp, "open", masterInterp, "kernelOpen", 1, argv);
    (void) Tcl_CreateAlias (interp, "close", masterInterp, "kernelClose", 1, argv);
    (void) Tcl_CreateAlias (interp, "fconfigure", masterInterp, "kernelFconfigure", 1, argv);
    (void) Tcl_CreateAlias (interp, "cd", masterInterp, "kernelCd", 1, argv);
    (void) Tcl_CreateAlias (interp, "pwd", masterInterp, "kernelPwd", 1, argv);
    (void) Tcl_CreateAlias (interp, "file", masterInterp, "kernelFile", 1, argv);
    (void) Tcl_CreateAlias (interp, "glob", masterInterp, "kernelGlob", 1, argv);
    (void) Tcl_CreateAlias (interp, "puts", masterInterp, "kernelPuts", 1, argv);

	/*
	 * Now the program execution commands
	 */
    
    (void) Tcl_CreateAlias (interp, "exec", masterInterp, "kernelExec", 1, argv);

	/*
	 * Now the dynamic loading commands
	 */

    (void) Tcl_CreateAlias (interp, "load", masterInterp, "kernelLoad", 1, argv);

	/*
	 * Now the network commands
	 */

    (void) Tcl_CreateAlias (interp, "socket", masterInterp, "kernelSocket", 1, argv);

	/*
	 * Now the require command
	 */

    (void) Tcl_CreateAlias (interp, "require", masterInterp, "userRequire", 1, argv);

	/* 
	 * Finally the miscellaneous commands
	 */

    (void) Tcl_CreateAlias (interp, "exit", masterInterp, "kernelExit", 1, argv);

	/*
	 * cleanup the argv array
	 */

    delete [] argv[0];

#ifdef TCL8

	/*
	 * Finally force the slave interpreter to source init.tcl 
	 */

    code = Tcl_GlobalEval (masterInterp, finalScript);

    if (code != TCL_OK) {
	Tcl_TransferResult (interp, masterInterp);
    }

#else

	/*
	 * Finally force the slave interpreter to source init.tcl 
	 */

    if ((string_initScript != NULL) && (*string_initScript != '\0')) {

#ifdef FIX_LATER
	    /*
	     * we copy the script since Tcl_ParseVar can modify the
	     * script in place (by temporarily replacing the character at
	     * the end of a variable name with a \0 -- we should not have to 
	     * do this
	     */
#endif

	char *script = new char [strlen(string_initScript) + 1];
	strcpy (script, string_initScript);
	code = Tcl_GlobalEval (interp, script);
	delete (script);

    } else {

	code = Tcl_GlobalEval (masterInterp, finalScript);

	if (code != TCL_OK) {
	    Tcl_TransferResult (interp, masterInterp);
	}
    }

#endif

    if (code != TCL_OK) {
	Tcl_AddErrorInfo (interp, "\n    (\"master\" initialization)");
	return TCL_ERROR;
    }

	/*
	 * done
	 */

    return TCL_OK;
}
