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

}