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