testsuite/config/unix.exp

   1 # -*- TCL -*-
   2 # Test-specific TCL procedures required by DejaGNU.
   3 # Copyright (C) 1994 Free Software Foundation, Inc.
   4
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19 # Modified by David MacKenzie <djm@gnu.ai.mit.edu> from the gcc files
  20 # written by Rob Savoye <rob@cygnus.com>.
  21 \f
  22
  23 # Called by runtest.
  24 # Extract and print the version number of xargs.
  25 proc xargs_version {} {
  26     global XARGS
  27     global XARGSFLAGS
  28
  29     if {[which $XARGS] != 0} then {
  30         set tmp [ eval exec $XARGS $XARGSFLAGS --version </dev/null ]
  31         regexp "version.*$" $tmp version
  32         if [info exists version] then {
  33             clone_output "[which $XARGS] $version\n"
  34         } else {
  35             warning "cannot get version from $tmp."
  36         }
  37     } else {
  38         warning "$XARGS, program does not exist"
  39     }
  40 }
  41
  42 # Run xargs and leave the output in $comp_output.
  43 # Called by individual test scripts.
  44 proc xargs_start { passfail options infile } {
  45     global verbose
  46     global XARGS
  47     global XARGSFLAGS
  48     global comp_output
  49
  50     if {[which $XARGS] == 0} then {
  51         error "$XARGS, program does not exist"
  52         exit 1
  53     }
  54
  55     set fail_good [string match "f*" $passfail]
  56
  57     set scriptname [uplevel {info script}]
  58     set testbase [file rootname $scriptname]
  59     set testname [file tail $testbase]
  60
  61     set outfile "$testbase.xo"
  62     if {$infile != ""} then {
  63         set infile "[file dirname [file dirname $testbase]]/inputs/$infile"
  64     } else {
  65         set infile /dev/null
  66     }
  67
  68     set cmd "$XARGS $XARGSFLAGS $options < $infile > xargs.out"
  69     send_log "$cmd\n"
  70     if $verbose>1 then {
  71         send_user "Spawning \"$cmd\"\n"
  72     }
  73
  74     catch "exec $cmd" comp_output
  75     if {$comp_output != ""} then {
  76         send_log "$comp_output\n"
  77         if $verbose>1 then {
  78             send_user "$comp_output\n"
  79         }
  80         if $fail_good then {
  81             pass "$testname"
  82         } else {
  83             fail "$testname, $comp_output"
  84         }
  85         return
  86     }
  87
  88     if [file exists $outfile] then {
  89         set cmp_cmd "cmp xargs.out $outfile"
  90         send_log "$cmp_cmd\n"
  91         catch "exec $cmp_cmd" cmpout
  92         if {$cmpout != ""} then {
  93             fail "$testname, $cmpout"
  94             return
  95         }
  96     } else {
  97         if {[file size xargs.out] != 0} then {
  98             fail "$testname, output should be empty"
  99             return
 100         }
 101     }
 102     pass "$testname"
 103 }
 104
 105 # Called by runtest.
 106 # Clean up (remove temporary files) before runtest exits.
 107 proc xargs_exit {} {
 108     catch "exec rm -f xargs.out"
 109 }