testsuite/lib/launcher.exp

   1 # Copyright (C) 2018, 2021 Free Software Foundation, Inc.
   2 #
   3 # This file is part of DejaGnu.
   4 #
   5 # DejaGnu is free software; you can redistribute it and/or modify it
   6 # 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 # DejaGnu is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with DejaGnu; if not, write to the Free Software Foundation,
  17 # Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # This file was written by Jacob Bachmeyer.
  20
  21 if { ![info exists LAUNCHER] } {
  22     set LAUNCHER \
  23         [file normalize \
  24              [file join [file dirname [testsuite file -source -top]] dejagnu]]
  25 }
  26 verbose "Using LAUNCHER $LAUNCHER" 2
  27
  28 if { [which $LAUNCHER] == 0 } {
  29     perror "Can't find LAUNCHER = $LAUNCHER"
  30     exit 2
  31 }
  32
  33 # run dejagnu(1) LAUNCHER with ARGLIST, returning { output exit_code }
  34 proc dejagnu_run { launcher arglist envlist } {
  35     global errorCode
  36
  37     set exec_cmd [list exec]
  38     if { [llength $envlist] > 0 } {
  39         lappend exec_cmd env
  40         foreach var $envlist { lappend exec_cmd $var }
  41     }
  42     lappend exec_cmd $launcher
  43
  44     # reset errorCode
  45     catch { error }
  46
  47     verbose -log "Running \"[lrange $exec_cmd 1 end] $arglist\" ..."
  48     catch { eval $exec_cmd $arglist } output
  49     verbose -log $output
  50
  51     if { [lindex $errorCode 0] eq "CHILDSTATUS" } {
  52         return [list $output [lindex $errorCode 2]]
  53     } else {
  54         return [list $output 0]
  55     }
  56 }
  57
  58 # evaluate a test against LAUNCHER, returning true if it passes
  59 # TEST is a list:  { name arglist envlist exit_code output_re... }
  60 proc try_dejagnu_launcher { launcher test } {
  61     foreach part [lrange $test 4 end] { append re $part }
  62
  63     if { [llength [lindex $test 2]] > 0 } {
  64         verbose "Spawning \"env [lindex $test 2] $launcher [lindex $test 1]\" ..."
  65     } else {
  66         verbose "Spawning \"$launcher [lindex $test 1]\" ..."
  67     }
  68     verbose "Expecting to match {$re} ..." 2
  69     set result [dejagnu_run $launcher [lindex $test 1] [lindex $test 2]]
  70     verbose "Exit code [lindex $result 1]; output {[lindex $result 0]}" 2
  71
  72     if { [regexp $re [lindex $result 0]]
  73          && [lindex $test 3] == [lindex $result 1] } {
  74         return 1
  75     } else {
  76         return 0
  77     }
  78 }
  79
  80 proc link_dejagnu_launcher_test_item {link target} {
  81     if {[file exists $link]} {
  82         verbose -log "   item $link already exists"
  83         return
  84     }
  85     verbose -log "linking $link"
  86     verbose -log "     to $target"
  87     if {[catch {file link -symbolic $link [file normalize $target]} err]} {
  88         perror $err 0
  89     }
  90 }
  91
  92 proc run_dejagnu_launcher_tests { launcher tests } {
  93     foreach test $tests {
  94         if { [lindex $test 0] == "#" } {
  95             # ignore comments in test list
  96         } elseif { [llength $test] == 1 } {
  97             # name only is a stub
  98             untested [lindex $test 0]
  99         } elseif { [try_dejagnu_launcher $launcher $test] } {
 100             pass [lindex $test 0]
 101         } else {
 102             fail [lindex $test 0]
 103         }
 104     }
 105 }
 106
 107 proc skip_dejagnu_launcher_tests { why result tests } {
 108     perror $why 0
 109     foreach test $tests {
 110         if { [lindex $test 0] == "#" } {
 111             # ignore comments in test list
 112         } else {
 113             $result [lindex $test 0]
 114         }
 115     }
 116 }
 117
 118 # stub: dejagnu(1) itself is non-interactive
 119 proc dejagnu_exit {} {}
 120
 121 # stub: dejagnu(1) does not have a separate version number
 122 proc dejagnu_version {} {
 123 }
 124
 125 #EOF