testsuite/runtest.libs/default_procs.tcl

   1 # Copyright (C) 1996-2019, 2020 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 set sum_file ""
  18 set reboot 0
  19 set errno ""
  20
  21 # this tests a proc for a returned pattern
  22 proc lib_pat_test { cmd arglist pattern } {
  23     puts "CMD(lib_pat_test) is: $cmd $arglist"
  24     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
  25         puts "RESULT(lib_pat_test) was: \"${result}\"\
  26                 for pattern \"$pattern\"."
  27         return [string match $pattern $result]
  28     } else {
  29         puts "RESULT(lib_pat_test) was error \"${result}\""
  30         return -1
  31     }
  32 }
  33
  34 # this tests a proc for a returned regexp
  35 proc lib_regexp_test { cmd arglist regexp } {
  36     puts "CMD(lib_regexp_test) is: $cmd $arglist"
  37     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
  38         puts "RESULT(lib_regexp_test) was: \"${result}\"\
  39                 for regexp \"$regexp\"."
  40         return [regexp -- $regexp $result]
  41     } else {
  42         puts "RESULT(lib_regexp_test) was error \"${result}\""
  43         return -1
  44     }
  45 }
  46
  47 # this tests a proc for a returned value
  48 proc lib_ret_test { cmd arglist val } {
  49     puts "CMD(lib_ret_test) is: $cmd $arglist"
  50     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
  51         puts "RESULT(lib_ret_test) was: $result"
  52         return [string equal $result $val]
  53     } else {
  54         puts "RESULT(lib_ret_test) was error \"${result}\""
  55         return -1
  56     }
  57 }
  58
  59 # this tests a proc for an expected boolean result
  60 proc lib_bool_test { cmd arglist val } {
  61     puts "CMD(lib_bool_test) is: $cmd $arglist"
  62     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
  63         puts "RESULT(lib_bool_test) was: \"$result\" expecting $val."
  64         # the "odd" spacing is used to help make the operator grouping clear
  65         return [expr {  $val  ?   $result ? 1 : 0   :   $result ? 0 : 1   }]
  66     } else {
  67         puts "RESULT(lib_bool_test) was error \"${result}\""
  68         return -1
  69     }
  70 }
  71
  72 # this tests that a proc raises an error matching a pattern
  73 proc lib_errpat_test { cmd arglist pattern } {
  74     puts "CMD(lib_errpat_test) is: $cmd $arglist"
  75     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 1 } {
  76         # caught exception code 1 (TCL_ERROR) as expected
  77         puts "RESULT(lib_errpat_test) was error\
  78                 \"${result}\" for pattern \"$pattern\"."
  79         if { [string match $pattern $result] } {
  80             # the expected error
  81             return 1
  82         } else {
  83             # an unexpected error
  84             return -1
  85         }
  86     } else {
  87         # no error -> fail
  88         puts "RESULT(lib_errpat_test) was: \"${result}\"\
  89                 without error; failing."
  90         return 0
  91     }
  92 }
  93
  94 # this tests that a proc raises an error matching a regexp
  95 proc lib_errregexp_test { cmd arglist regexp } {
  96     puts "CMD(lib_errregexp_test) is: $cmd $arglist"
  97     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 1 } {
  98         # caught exception code 1 (TCL_ERROR) as expected
  99         puts "RESULT(lib_errregexp_test) was error\
 100                 \"${result}\" for regexp \"$regexp\"."
 101         if { [regexp -- $regexp $result] } {
 102             # the expected error
 103             return 1
 104         } else {
 105             # an unexpected error
 106             return -1
 107         }
 108     } else {
 109         # no error -> fail
 110         puts "RESULT(lib_errregexp_test) was: \"${result}\"\
 111                 without error; failing."
 112         return 0
 113     }
 114 }
 115
 116 # this tests that a proc raises an error matching an exact string
 117 proc lib_err_test { cmd arglist val } {
 118     puts "CMD(lib_err_test) is: $cmd $arglist"
 119     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 1 } {
 120         # caught exception code 1 (TCL_ERROR) as expected
 121         puts "RESULT(lib_err_test) was error: $result"
 122         if { $result eq $val } {
 123             # the expected error
 124             return 1
 125         } else {
 126             # an unexpected error
 127             return -1
 128         }
 129     } else {
 130         # no error -> fail
 131         puts "RESULT(lib_err_test) was: \"${result}\"\
 132                 without error; failing."
 133         return 0
 134     }
 135 }
 136
 137 # support for testing output procs
 138 proc clear_test_output {} {
 139     global test_output
 140
 141     array unset test_output
 142     array set test_output { error {} log {} tty {} user {} }
 143 }
 144
 145 proc store_test_output { dest argv } {
 146     global test_output
 147
 148     set argc [llength $argv]
 149     for { set argi 0 } { $argi < $argc } { incr argi } {
 150         set arg [lindex $argv $argi]
 151         if { $arg eq "--" } {
 152             set stri [expr $argi + 1]
 153             break
 154         } elseif { ![string match "-*" $arg] } {
 155             set stri $argi
 156         }
 157     }
 158     # the string must be the last argument
 159     if { $stri != ($argc - 1) } {
 160         error "bad call: send_${dest} $argv"
 161     }
 162     append test_output($dest) [lindex $argv $stri]
 163 }
 164 foreach dest { error log tty user } {
 165     proc send_${dest} { args } [concat store_test_output $dest {$args}]
 166 }
 167
 168 # this checks output against VAL, which is a list of key-value pairs
 169 #  each key specifies an output channel (from { error log tty user }) and a
 170 #  matching mode (from { "", pat, re }) separated by "_" unless mode is ""
 171 proc lib_output_test { cmd arglist val } {
 172     global test_output
 173
 174     puts "CMD(lib_output_test) is: $cmd $arglist"
 175     clear_test_output
 176     if { ([llength $val] % 2) != 0 } {
 177         puts "ERROR(lib_output_test): expected result is invalid"
 178         return -1
 179     }
 180     if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
 181         puts "RESULT(lib_output_test) was: $result"
 182         foreach dest { error log tty user } {
 183             puts "OUTPUT(lib_output_test/$dest) was: <<$test_output($dest)>>"
 184         }
 185     } else {
 186         puts "RESULT(lib_output_test) was error \"${result}\""
 187         return -1
 188     }
 189     foreach { check expected } $val {
 190         if { [regexp {(error|log|tty|user)(?:_(pat|re))?} $check\
 191                   -> dest mode] != 1 } {
 192             puts "ERROR(lib_output_test): unknown check token: $check"
 193             return -1
 194         }
 195         switch -- $mode {
 196             "" {
 197                 if { ![string equal $expected $test_output($dest)] } {
 198                     return 0
 199                 }
 200             }
 201             pat {
 202                 if { ![string match $expected $test_output($dest)] } {
 203                     return 0
 204                 }
 205             }
 206             re {
 207                 if { ![regexp -- $expected $test_output($dest)] } {
 208                     return 0
 209                 }
 210             }
 211         }
 212     }
 213     # if we get here, all checks have passed
 214     return 1
 215 }
 216
 217 #
 218 # This runs a standard test for a proc. The list is set up as:
 219 # |test proc|proc being tested|args|pattern|message|
 220 # test proc is something like lib_pat_test or lib_ret_test.
 221 #
 222 proc run_tests { tests } {
 223     foreach test $tests {
 224         # skip comments in test lists
 225         if { [lindex $test 0] eq "#" } { continue }
 226         set result [eval [lrange $test 0 3]]
 227         switch -- $result {
 228             "-1" {
 229                 puts "ERRORED: [lindex $test 4]"
 230             }
 231             "1" {
 232                 puts "PASSED: [lindex $test 4]"
 233             }
 234             "0" {
 235                 puts "FAILED: [lindex $test 4]"
 236             }
 237             default {
 238                 puts "BAD VALUE: [lindex $test 4]"
 239             }
 240         }
 241     }
 242 }
 243
 244 proc pass { msg } {
 245     puts "PASSED: $msg"
 246 }
 247
 248 proc fail { msg } {
 249     puts "FAILED: $msg"
 250 }
 251
 252 proc perror { msg } {
 253     global errno
 254     puts "ERRORED: $msg"
 255     set errno $msg
 256 }
 257
 258 proc warning { msg } {
 259     global errno
 260     puts "WARNED: $msg"
 261     set errno $msg
 262 }
 263
 264 proc untested { msg } {
 265     puts "NOTTESTED: $msg"
 266 }
 267
 268 proc unsupported { msg } {
 269     puts "NOTSUPPORTED: $msg"
 270 }
 271 proc verbose { args } {
 272     puts [lindex $args 0]
 273 }