xargs/testsuite/config/unix.exp

   1 # -*- TCL -*-
   2 # Test-specific TCL procedures required by DejaGNU.
   3 # Copyright (C) 1994, 2005, 2007 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 3 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, see <http://www.gnu.org/licenses/>.
  17
  18 # Modified by David MacKenzie <djm@gnu.ai.mit.edu> from the gcc files
  19 # written by Rob Savoye <rob@cygnus.com>.
  20 \f
  21
  22 verbose "base_dir is $base_dir" 2
  23
  24 set objfile "xargs.o"
  25 set dir "$base_dir/.."
  26 set path "$dir/$objfile"
  27 if ![file exists $path] then {
  28     error "$path does not exist"
  29 } else {
  30     set XARGS [findfile $base_dir/../xargs [transform xargs]]
  31 }
  32
  33 global XARGS
  34
  35
  36 set XARGS [findfile $base_dir/../xargs $base_dir/../xargs [transform xargs]]
  37 if [ string match "/*" $XARGS ] {
  38     verbose "XARGS is set to $XARGS" 1
  39 } else {
  40     error "Failed to find a binary to test"
  41 }
  42
  43 global XARGSFLAGS
  44 if ![info exists XARGSFLAGS] then {
  45     set XARGSFLAGS ""
  46 }
  47
  48 # Called by runtest.
  49 # Extract and print the version number of xargs.
  50 proc xargs_version {} {
  51     global XARGS
  52     global XARGSFLAGS
  53
  54     if {[which $XARGS] != 0} then {
  55         set tmp [ eval exec $XARGS $XARGSFLAGS --version </dev/null ]
  56         regexp "version.*$" $tmp version
  57         if [info exists version] then {
  58             clone_output "[which $XARGS] $version\n"
  59         } else {
  60             warning "cannot get version from $tmp."
  61         }
  62     } else {
  63         warning "$XARGS, program does not exist"
  64     }
  65 }
  66
  67 # Run xargs and leave the output in $comp_output.
  68 # Called by individual test scripts.
  69 proc xargs_start { passfail options {infile ""} {errh ""} {command ""} } {
  70     global verbose
  71     global XARGS
  72     global XARGSFLAGS
  73     global comp_output
  74
  75     if {[which $XARGS] == 0} then {
  76         error "$XARGS, program does not exist"
  77         exit 1
  78     }
  79
  80     set scriptname [uplevel {info script}]
  81     set testbase [file rootname $scriptname]
  82     set testname [file tail $testbase]
  83
  84     if {[string match "\[0-9\]*" $passfail]} then {
  85         set execrc "$passfail"
  86     } elseif {[string match "p*" $passfail]} then {
  87         set execrc "0"
  88     } elseif {[string match "f*" $passfail]} then {
  89         set execrc "1"
  90     } else {
  91         fail "$testname, failure in testing framework: passfail=$passfail"
  92         return
  93     }
  94
  95     set outfile "$testbase.xo"
  96     if {$infile != ""} then {
  97         set infile "[file dirname [file dirname $testbase]]/inputs/$infile"
  98     } else {
  99         set infile /dev/null
 100     }
 101
 102     if {[string match "s*" $errh]} then {
 103         set errfile ""
 104     } else {
 105         set errfile "$testbase.xe"
 106     }
 107
 108     catch "exec rm -f xargs.out xargs.err"
 109
 110     if {$command != ""} then {
 111         set cmd "$command  < $infile > xargs.out 2> xargs.err"
 112     } else {
 113         set cmd "$XARGS $XARGSFLAGS $options < $infile > xargs.out 2> xargs.err"
 114     }
 115     send_log "$cmd\n"
 116     if $verbose>1 then {
 117         send_user "Spawning \"$cmd\"\n"
 118     }
 119
 120     set status 0
 121     if {[catch "exec $cmd" comp_output]} then {
 122         if {[lindex $::errorCode 0] == "CHILDSTATUS"} then {
 123             set status [lindex $::errorCode 2]
 124         } else {
 125             fail "$testname, failure in testing framework, $comp_output"
 126             return
 127         }
 128     }
 129
 130     catch "exec cat xargs.err" comp_error
 131
 132     if {$execrc != $status} then {
 133         if {$status == 0} then {
 134             fail "$testname, unexpected success"
 135         } elseif {$execrc == 0} then {
 136             fail "$testname, unexpected failure, $comp_output, $comp_error"
 137         } else {
 138             fail "$testname, expected exit code $execrc, but got exit code $status"
 139         }
 140         return
 141     }
 142     # ok, at least exit code match.
 143
 144     if [file exists $outfile] then {
 145         set cmp_cmd "cmp xargs.out $outfile"
 146         send_log "$cmp_cmd\n"
 147         catch "exec $cmp_cmd" cmpout
 148         if {$cmpout != ""} then {
 149             # stdout is wrong.
 150             catch "exec diff -u xargs.out $outfile" diffs
 151             send_log "stdout diffs: $diffs\n"
 152             fail "$testname, wrong stdout output: $cmpout"
 153             return
 154         }
 155     } elseif {[file size xargs.out] != 0} then {
 156         fail "$testname, output on stdout should be empty"
 157         return
 158     }
 159
 160     # if stderr check is enabled,
 161     if {$errfile != ""} then {
 162         if {[file exists $errfile]} then {
 163             set cmp_cmd "cmp xargs.err $errfile"
 164             send_log "$cmp_cmd\n"
 165             catch "exec $cmp_cmd" cmperr
 166             if {$cmperr != ""} then {
 167                 # stderr is wrong
 168                 catch "exec diff -ua xargs.err $errfile" diffs
 169                 send_log "stderr diffs: $diffs\n"
 170                 fail "$testname, wrong stderr output: $cmperr"
 171                 return
 172             }
 173         } elseif {[file size xargs.err] != 0} then {
 174             fail "$testname, output on stderr should be empty"
 175             return
 176         }
 177     }
 178
 179     pass "$testname"
 180 }
 181
 182 # Called by runtest.
 183 # Clean up (remove temporary files) before runtest exits.
 184 proc xargs_exit {} {
 185     catch "exec rm -f xargs.out xargs.err"
 186 }