[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
PATCH: use a slave interpreter
From: |
Ben Elliston |
Subject: |
PATCH: use a slave interpreter |
Date: |
09 Feb 2004 15:10:53 +1100 |
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.3 |
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"] != "" } {
- PATCH: use a slave interpreter,
Ben Elliston <=