testsuite/lib/launcher.exp

   1 # Copyright (C) 2018, 2021, 2024 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, see <http://www.gnu.org/licenses/>.
  17
  18 # This file was written by Jacob Bachmeyer.
  19
  20 if { ![info exists LAUNCHER] } {
  21     set LAUNCHER \
  22         [file normalize \
  23              [file join [file dirname [testsuite file -source -top]] dejagnu]]
  24 }
  25 verbose "Using LAUNCHER $LAUNCHER" 2
  26
  27 if { [which $LAUNCHER] == 0 } {
  28     perror "Can't find LAUNCHER = $LAUNCHER"
  29     exit 2
  30 }
  31
  32 # run dejagnu(1) LAUNCHER with ARGLIST, returning { output exit_code }
  33 proc dejagnu_run { launcher arglist envlist } {
  34     global LAUNCHER_SHELL errorCode
  35
  36     set exec_cmd [list exec]
  37     if { [llength $envlist] > 0 } {
  38         lappend exec_cmd env
  39         foreach var $envlist { lappend exec_cmd $var }
  40     }
  41     if { [info exists LAUNCHER_SHELL] && $LAUNCHER_SHELL ne "" } {
  42         lappend exec_cmd $LAUNCHER_SHELL
  43     }
  44     lappend exec_cmd $launcher
  45
  46     # reset errorCode
  47     catch { error }
  48
  49     verbose -log "Running \"[lrange $exec_cmd 1 end] $arglist\" ..."
  50     catch { eval $exec_cmd $arglist } output
  51     verbose -log $output
  52
  53     if { [lindex $errorCode 0] eq "CHILDSTATUS" } {
  54         return [list $output [lindex $errorCode 2]]
  55     } else {
  56         return [list $output 0]
  57     }
  58 }
  59
  60 # evaluate a test against LAUNCHER, returning true if it passes
  61 # TEST is a list:  { name arglist envlist exit_code output_re... }
  62 proc try_dejagnu_launcher { launcher test } {
  63     foreach part [lrange $test 4 end] { append re $part }
  64
  65     if { [llength [lindex $test 2]] > 0 } {
  66         verbose "Spawning \"env [lindex $test 2] $launcher [lindex $test 1]\" ..."
  67     } else {
  68         verbose "Spawning \"$launcher [lindex $test 1]\" ..."
  69     }
  70     verbose "Expecting to match {$re} ..." 2
  71     set result [dejagnu_run $launcher [lindex $test 1] [lindex $test 2]]
  72     verbose "Exit code [lindex $result 1]; output {[lindex $result 0]}" 2
  73
  74     if { [regexp $re [lindex $result 0]]
  75          && [lindex $test 3] == [lindex $result 1] } {
  76         return 1
  77     } else {
  78         return 0
  79     }
  80 }
  81
  82 proc link_dejagnu_launcher_test_item {link target} {
  83     if {[file exists $link]} {
  84         verbose -log "   item $link already exists"
  85         return
  86     }
  87     verbose -log "linking $link"
  88     verbose -log "     to $target"
  89     if {[catch {file link -symbolic $link [file normalize $target]} err]} {
  90         perror $err 0
  91     }
  92 }
  93
  94 proc run_dejagnu_launcher_tests { launcher tests } {
  95     foreach test $tests {
  96         if { [lindex $test 0] == "#" } {
  97             # ignore comments in test list
  98         } elseif { [llength $test] == 1 } {
  99             # name only is a stub
 100             untested [lindex $test 0]
 101         } elseif { [try_dejagnu_launcher $launcher $test] } {
 102             pass [lindex $test 0]
 103         } else {
 104             fail [lindex $test 0]
 105         }
 106     }
 107 }
 108
 109 proc skip_dejagnu_launcher_tests { why result tests } {
 110     perror $why 0
 111     foreach test $tests {
 112         if { [lindex $test 0] == "#" } {
 113             # ignore comments in test list
 114         } else {
 115             $result [lindex $test 0]
 116         }
 117     }
 118 }
 119
 120 # stub: dejagnu(1) itself is non-interactive
 121 proc dejagnu_exit {} {}
 122
 123 # stub: dejagnu(1) does not have a separate version number
 124 proc dejagnu_version {} {
 125 }
 126
 127 #EOF