Subversion Repositories or1k

#   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
}