# Copyright (C) 1988, 1990, 1991, 1992, 1996, 1997 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 # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # Please email any bugs, comments, and/or additions to this file to: # bug-dejagnu@prep.ai.mit.edu # This file was written by Rob Savoye. (rob@cygnus.com) set testdrv "unix/tcltest" set tprompt "%" # # tcl_version -- extract and print the version number of tcl # proc tcl_version { } { global testdrv set version "" catch "exec echo puts \[info tclversion\] > x" catch "exec $testdrv x" tmp catch "exec rm -f x" regexp "\[0-9\]\.\[0-9\.\]+" $tmp version clone_output "Tcl library is version\t$version\n" unset tmp unset version } # # tcl_load -- loads the program. For tcl, we just execute it # proc tcl_load { arg } { global subdir global testdrv global spawn_id if ![file exists $arg] then { perror "$arg does not exist." return -1 } verbose "Sourcing $arg..." send "source $arg\n" return 0 } # # tcl_exit -- exit the test driver for tcl # proc tcl_exit {} { } # # tcl_start -- start the test driver for tcl # proc tcl_start { } { global testdrv global objdir global subdir global srcdir global verbose global spawn_id global tprompt set testdrv "$objdir/$testdrv" set defs "$srcdir/../tests/defs" set timeout 100 set timetol 0 spawn $testdrv if ![file exists ${srcdir}/../tests] { perror "The source for the test cases is missing." 0 return -1 } send "[list set srcdir ${srcdir}/../tests]\r" expect { -re "set VERBOSE 1\[\r\n\]*1\[\r\n\]*%" { verbose "Set verbose flag for tests" exp_continue } -re "${srcdir}/../tests\[\r\n\]*$tprompt" { verbose "Set srcdir to $srcdir/../tests" 2 } -re "no files matched glob pattern" { warning "Didn't set srcdir to $srcdir/../tests" } timeout { perror "Couldn't set srcdir" return -1 } } if ![file exists $defs] then { perror "$defs does not exist." return -1 } verbose "Sourcing $defs..." send "source $defs\r\n" expect { -re ".*source $defs.*$" { verbose "Sourced $defs" } "Error: couldn't read file*" { perror "Couldn't source $defs" return -1 } "%" { verbose "Got prompt, sourced $defs" } timeout { warning "Timed out sourcing $defs." if { $timetol <= 3 } { incr timetol exp_continue } else { return -1 } } } set timetol 0 sleep 2 send "set VERBOSE 1\n" expect { -re "% 1.*%" { verbose "Set verbose flag for tests" } -re "set VERBOSE 1.*1.*%" { verbose "Set verbose flag for tests" } timeout { perror "Timed out setting verbose flag." if { $timetol <= 3 } { exp_continue } else { return -1 } } } return $spawn_id }