PATCH: use a slave interpreter

[Ben Elliston]

The following patch makes a good start at running .exp test scripts in
a slave interpreter that is distinct from the interpreter running the
framework.  This has some immediate benefits:

  * Test scripts can create variables and procs, but they will be
    disposed of at the end of the script.  Currently, this presents
    problems.  For example, a script that creates an associative array
    $foo, but forgets to unset it will cause a later script to get
    upset if it tries to set a scalar $foo.  It makes debugging
    dependent on the set of tests run and the order they are run in.

  * The slave interpreter can be sandboxed from the test harness so
    that it cannot manipulate private variables of DejaGnu or call
    private procs.  At present, I have duplicated the entire
    environment in the slave so that no test scripts will break,
    however over time I intend to restrict the set of procs and
    commands available to in the slave.

This code is not super fast and will slow down testsuites with a large
number of .exp scripts relative to the total runtime.  I profiled the
RUNTEST_* procs and was able to reduce the impact considerably.  For
the GAS testsuite--which has a short runtime--but lots of .exp
scripts, it introduced a 4% slowdown.  I think this is justified given
the benefits of robustness and clearer interfaces.

Comments while I test it extensively?


2004-02-09  Ben Elliston  <address@hidden>

        * runtest.exp (runtest): Create a new interpreter for each .exp
        test script. Duplicate procs, globals, commands and channels from
        the master interpreter within the slave. Destroy the interpreter
        once each test script completes.
        (RUNTEST_clone_interp): New proc.
        (RUNTEST_clone_var): Likewise.
        (RUNTEST_clone_proc): Likewise.

Index: runtest.exp
===================================================================
RCS file: /cvsroot/dejagnu/dejagnu/runtest.exp,v
retrieving revision 1.20
diff -u -p -c -r1.20 runtest.exp
cvs server: conflicting specifications of output style
*** runtest.exp 30 Jan 2004 06:24:00 -0000      1.20
--- runtest.exp 9 Feb 2004 03:53:29 -0000
***************
*** 1,5 ****
  # Test Framework Driver
! # Copyright (C) 1992 - 2002, 2003 Free Software Foundation, Inc.
  
  # This program is free software; you can redistribute it and/or modify
  # it under the terms of the GNU General Public License as published by
--- 1,6 ----
  # Test Framework Driver
! # Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
! # 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
  
  # This program is free software; you can redistribute it and/or modify
  # it under the terms of the GNU General Public License as published by
*************** if ![info exists verbose] {
*** 133,139 ****
      set verbose 0
  }
  
! #
  # verbose [-n] [-log] [--] message [level]
  #
  # Print MESSAGE if the verbose level is >= LEVEL.
--- 134,182 ----
      set verbose 0
  }
  
! proc RUNTEST_clone_interp {} {
!     set exclude "auto_index auto_execs env errorCode errorInfo"
!     # First clone all variables.
!     foreach var [info globals] {
!       if [expr [lsearch $exclude $var] >= 0] then continue
!       set clone [RUNTEST_clone_var $var]
!       append self "$clone\n"
!     }
!     
!     # Now clone all procs (not built-ins, though).
!     foreach procedure [info procs] {
!       set clone [RUNTEST_clone_proc $procedure]
!       append self "$clone\n"
!     }
!     if [catch {return $self}] { return "" }
! }
! 
! proc RUNTEST_clone_var var {
!     global $var
! 
!     # Try to determine if var is an array or scalar.
!     if [catch {set $var}] then {
!       set array_value [array get $var]
!       return [concat set $var \{$array_value\}]
!     } else {
!       set var_value [set [set var]]
!       return [concat set $var \{$var_value\}]
!     }
! }
! 
! proc RUNTEST_clone_proc procedure {
!     set body [info body $procedure]
!     set args {}
!     foreach arg [info args $procedure] {
!       if {[info default $procedure $arg value]} {
!           lappend args [list $arg $value]
!       } else {
!           lappend args $arg
!       }
!     }
!     return [concat proc $procedure \{ $args \} \{${body}\}]
! }
! 
  # verbose [-n] [-log] [--] message [level]
  #
  # Print MESSAGE if the verbose level is >= LEVEL.
*************** proc runtest { test_file_name } {
*** 1440,1445 ****
--- 1483,1489 ----
      global errcnt
      global errorInfo
      global tool
+     global interp_state interp_cmds
  
      clone_output "Running $test_file_name ..."
      set prms_id       0
*************** proc runtest { test_file_name } {
*** 1455,1478 ****
            }
        }
  
!       if { [catch "uplevel #0 source $test_file_name"] == 1 } {
!           # If we have a Tcl error, propogate the exit status do make
!           # notices the error.
!           global exit_status exit_error
!           # exit error is set by a command line option
!           if { $exit_status == 0 } {
!               set exit_status $exit_error
!           }
!           # We can't call `perror' here, it resets `errorInfo'
!           # before we want to look at it.  Also remember that perror
!           # increments `errcnt'.  If we do call perror we'd have to
!           # reset errcnt afterwards.
!           clone_output "ERROR: tcl error sourcing $test_file_name."
!           if [info exists errorInfo] {
!               clone_output "ERROR: $errorInfo"
!               unset errorInfo
!           }
        }
  
        if [info exists tool] {
            if { [info procs "${tool}_finish"] != "" } {
--- 1499,1539 ----
            }
        }
  
!       # Create a new interpreter for the .exp script to execute in.
!       interp create sandbox
!       if ![info exist interp_state] {
!           set interp_state [RUNTEST_clone_interp]
!       }
!       sandbox eval $interp_state
!       if ![info exist interp_cmds] {
!           set interp_cmds [info commands]
!       }
!       # Expose all registered commands (for now).
!       foreach cmd $interp_cmds {
!           sandbox alias $cmd $cmd
!       }
!       # Share every channel with the slave interpreter.
!       foreach chan [file channels] {
!           interp share {} $chan sandbox
!       }
! 
!       if {[catch {sandbox eval uplevel \#0 source $test_file_name}] == 1} {
!           # If we have a Tcl error, propogate the exit status so the
!           # shell knows about it.  exit_error is set by the --status
!           # command line option
!           global exit_status exit_error
!           if { $exit_status == 0 } {
!               set exit_status $exit_error
!           }
!           # We can't call perror here, it resets $errorInfo before
!           # we can look at it.
!           clone_output "ERROR: Tcl error sourcing $test_file_name"
!           if [sandbox eval info exists errorInfo] {
!               set error_info [sandbox eval set errorInfo]
!               clone_output "ERROR: $error_info"
!           }
        }
+       interp delete sandbox
  
        if [info exists tool] {
            if { [info procs "${tool}_finish"] != "" } {