diff options
author | Jacob Bachmeyer <jcb@gnu.org> | 2022-09-30 21:14:37 -0500 |
---|---|---|
committer | Jacob Bachmeyer <jcb@gnu.org> | 2022-09-30 21:14:37 -0500 |
commit | af1760154d4607fa59b1c4e06df59f8ae474b440 (patch) | |
tree | 555c2ab5d30617adc529af3090c7867040f5905a | |
parent | 355456674cce4400c85770b50b0f1dda6cbebb9a (diff) | |
download | dejagnu-af1760154d4607fa59b1c4e06df59f8ae474b440.zip dejagnu-af1760154d4607fa59b1c4e06df59f8ae474b440.tar.gz dejagnu-af1760154d4607fa59b1c4e06df59f8ae474b440.tar.bz2 |
Add initial unit tests for lib/dg.exp
-rw-r--r-- | ChangeLog | 10 | ||||
-rw-r--r-- | testsuite/runtest.libs/dg.test | 166 | ||||
-rw-r--r-- | testsuite/runtest.libs/mockutil.tcl | 18 |
3 files changed, 193 insertions, 1 deletions
@@ -1,3 +1,13 @@ +2022-09-30 Jacob Bachmeyer <jcb@gnu.org> + + PR58065 + + * testsuite/runtest.libs/mockutil.tcl (test_proc_with_mocks): Add + usage comment and option to match number of calls for test. + (create_test_interpreter): Add support for mockvfs. + + * testsuite/runtest.libs/dg.test: New file. + 2022-09-29 Jacob Bachmeyer <jcb@gnu.org> PR58065 diff --git a/testsuite/runtest.libs/dg.test b/testsuite/runtest.libs/dg.test new file mode 100644 index 0000000..e0a2416 --- /dev/null +++ b/testsuite/runtest.libs/dg.test @@ -0,0 +1,166 @@ +# Test procedures in lib/dg.exp -*- Tcl -*- + +# Copyright (C) 2022 Free Software Foundation, Inc. +# +# This file is part of DejaGnu. +# +# DejaGnu is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# DejaGnu is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with DejaGnu; if not, write to the Free Software Foundation, +# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA. + +foreach lib { default_procs mockutil mockvfs } { + set file $srcdir/$subdir/${lib}.tcl + if [ file exists $file] { + source $file + } else { + puts "ERROR: $file doesn't exist" + } +} +foreach lib { utils dg } { + set file $srcdir/../lib/${lib}.exp + if [ file exists $file] { + source $file + } else { + puts "ERROR: $file doesn't exist" + } +} + +# callbacks required by dg.exp + +proc mock-dg-test { prog what flags } { + set chan [open $prog r] + set linum 0 + set output "" + + while { [gets $chan line] >= 0 } { + incr linum + if { [regexp -- {^%([EW])\s+([^\r\n{}]*)} $line -> item text] } { + switch -- $item { + E { append output "$prog:$linum: error: $text\n" } + W { append output "$prog:$linum: warning: $text\n" } + } + } + } + puts "<<< $prog $what $flags" + puts -nonewline $output + puts ">>> $prog $what $flags" + return [list $output a.out] +} + +proc mock-dg-prune { target output } { + puts "<<< output pruning callback" + puts "target: $target" + puts "output:\n$output" + puts ">>> output pruning callback" + return $output +} + +# testing... + +# init call trace list +reset_mock_trace +# build test environment +create_mockvfs dg-test-vfs +create_test_interpreter dg-test-1 { + copy_procs { + dg-format-linenum dg-get-options dg-process-target + dg-prms-id dg-options dg-do + dg-error dg-warning dg-bogus dg-build + dg-excess-errors dg-output dg-final + dg-init dg-runtest dg-test dg-finish + dg-trim-dirname + grep mock-dg-test mock-dg-prune + } + link_procs { verbose } + shim_procs { runtest_file_p } + attach_vfs { dg-test-vfs } + link_channels { stdout } + copy_vars { + dg-do-what-default dg-interpreter-batch-mode dg-linenum-format + srcdir subdir target_triplet + } + vars { + tool mock + runtests { dg.test {} } + } + mocks { + # minor test shims + prune_warnings { text } { $text } + unknown { args } { [error "unknown $args"] } + # results collection + pass { message } { 0 } + fail { message } { 0 } + xpass { message } { 0 } + xfail { message } { 0 } + kpass { bugid message } { 0 } + kfail { bugid message } { 0 } + } +} + +foreach {type token line} { + pass error {%E foo { dg-error "foo" "simple error" }} + fail error {% foo { dg-error "foo" "simple error" }} + pass warning {%W foo { dg-warning "foo" "simple warning" }} + fail warning {% foo { dg-warning "foo" "simple warning" }} + pass bogus {% foo { dg-bogus "foo" "bogus message" }} + fail bogus {%W foo { dg-bogus "foo" "bogus message" }} + pass build {% foo { dg-build "foo" "build failure" }} + fail build {%E foo { dg-build "foo" "build failure" }} + pass excess {% foo} + fail excess {%E extra} +} { + create_mock_file dg-test-vfs "dg/basic-${type}-${token}" \ + "# test file for dg.exp\n$line\n" +} + +dg-test-1 eval {proc send_log { text } { puts $text }} + +dg-test-1 eval dg-init +foreach { type token message } { + pass error { test for errors, line 2 } + fail error { test for errors, line 2 } + pass warning { test for warnings, line 2 } + fail warning { test for warnings, line 2 } + pass bogus { test for bogus message } + fail bogus { test for bogus message } + pass build { test for build failure } + fail build { test for build failure } + pass excess { test for excess errors } + fail excess { test for excess errors } +} { + set check_calls {xpass ! {} xfail ! {} kpass ! {} kfail ! {}} + switch -glob -- ${type}:${token} { + pass:excess { lappend check_calls fail ! {} pass C 1 } + fail:excess { lappend check_calls pass ! {} fail C 1 } + pass:* { lappend check_calls fail ! {} pass C 2 } + fail:* { lappend check_calls fail C 1 pass C 1 } + } + if { $message ne "" } { + lappend check_calls $type 0 [list 1 ".*[string trim ${message}].*"] + } + if { $token ne "excess" } { + lappend check_calls pass + switch -- ${type} { + pass { lappend check_calls 1 } + fail { lappend check_calls 0 } + } + lappend check_calls { 1 {.*test for excess errors.*} } + } + test_proc_with_mocks "test with dg/basic-${type}-${token}" dg-test-1 \ + [list dg-runtest dg/basic-${type}-${token} "" ""] \ + check_calls $check_calls +} +dg-test-1 eval dg-finish + + +puts "END dg.test" diff --git a/testsuite/runtest.libs/mockutil.tcl b/testsuite/runtest.libs/mockutil.tcl index a8fa2fd..20b6b9b 100644 --- a/testsuite/runtest.libs/mockutil.tcl +++ b/testsuite/runtest.libs/mockutil.tcl @@ -28,7 +28,7 @@ proc strip_comment_lines { text } { proc create_test_interpreter { name opts } { array set opt { - copy_arrays {} copy_procs {} copy_vars {} + copy_arrays {} copy_procs {} copy_vars {} attach_vfs {} link_channels {} link_procs {} shim_procs {} mocks {} vars {} } array set opt [strip_comment_lines $opts] @@ -75,6 +75,9 @@ proc create_test_interpreter { name opts } { foreach chan $opt(link_channels) { interp share {} $chan $name } foreach link $opt(link_procs) { establish_link $name $link } foreach shim $opt(shim_procs) { establish_shim $name $shim } + if { $opt(attach_vfs) ne "" } { + attach_mockvfs $name [lindex $opt(attach_vfs) 0] + } return $name } proc copy_array_to_test_interpreter { sicmd dest {src {}} } { @@ -176,6 +179,13 @@ proc match_argpat { argpat call } { return $result } +# test_proc_with_mocks testName sicmd testCode { +# check_calls { +# prefix mode:[*U[:digit:]] { [argument pattern]... } +# prefix mode:[!] { } +# prefix mode:[C] [ { count } | count ] +# } +# } proc test_proc_with_mocks { name sicmd code args } { array set opt { check_calls {} @@ -217,6 +227,12 @@ proc test_proc_with_mocks { name sicmd code args } { verbose " failed!" set result fail } + } elseif { $callpos eq "C" } { + # succeed if exactly N calls match prefix + if { [llength $calls] != [lindex $argpat 0] } { + verbose " failed!" + set result fail + } } elseif { $callpos eq "U" } { # prefix selects one unique call if { [llength $calls] != 1 } { |