diff options
author | Jacob Bachmeyer <jcb62281+dev@gmail.com> | 2020-05-21 16:49:49 -0600 |
---|---|---|
committer | Rob Savoye <rob@senecass.com> | 2020-05-21 16:50:22 -0600 |
commit | 94cb6b788790fd0f60b5f283b6e9b1f7e5089636 (patch) | |
tree | b3812af51400004a2977165b9cdae16e3b54ff2d | |
parent | 249df0fd7dccf281c845ac582f54a87843fc3c3f (diff) | |
download | dejagnu-94cb6b788790fd0f60b5f283b6e9b1f7e5089636.zip dejagnu-94cb6b788790fd0f60b5f283b6e9b1f7e5089636.tar.gz dejagnu-94cb6b788790fd0f60b5f283b6e9b1f7e5089636.tar.bz2 |
New file
-rw-r--r-- | testsuite/runtest.libs/mockutil.tcl | 246 |
1 files changed, 246 insertions, 0 deletions
diff --git a/testsuite/runtest.libs/mockutil.tcl b/testsuite/runtest.libs/mockutil.tcl new file mode 100644 index 0000000..a8fa2fd --- /dev/null +++ b/testsuite/runtest.libs/mockutil.tcl @@ -0,0 +1,246 @@ +# Copyright (C) 2019 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. + +# This file was written by Jacob Bachmeyer. + +# This library provides convenience procedures for running isolated tests +# of DejaGnu procedures in a slave interpreter. These are designed to be +# run in the child process used by the DejaGnu library tests. + +proc strip_comment_lines { text } { + regsub -all -- {\n[[:space:]]*#[^\r\n]*[\r\n]+} $text "\n" +} + +proc create_test_interpreter { name opts } { + array set opt { + copy_arrays {} copy_procs {} copy_vars {} + link_channels {} link_procs {} shim_procs {} mocks {} vars {} + } + array set opt [strip_comment_lines $opts] + + interp create -safe -- $name + foreach array $opt(copy_arrays) { # inlined due to upvar + if { [llength $array] == 2 } { + upvar [lindex $array 1] src_array + } elseif { [llength $array] == 1 } { + upvar [lindex $array 0] src_array + } else { + error "bogus copy_arrays directive: $array" + } + $name eval array set [list [lindex $array 0] [array get src_array]] + } + foreach proc $opt(copy_procs) { # inlined due to uplevel + # proc reconstruction adapted from Tcl info(n) manpage + set argspec [list] + foreach arg [uplevel info args $proc] { + if { [uplevel info default $proc $arg value] } { + lappend argspec [list $arg $value] + } else { + lappend argspec [list $arg] + } + } + $name eval proc $proc [list $argspec] [list [uplevel info body $proc]] + } + foreach var $opt(copy_vars) { # inlined due to upvar + if { [llength $var] == 2 } { + upvar [lindex $var 1] src_var + } elseif { [llength $var] == 1 } { + upvar [lindex $var 0] src_var + } else { + error "bogus copy_vars directive: $var" + } + $name eval set [list [lindex $var 0] $src_var] + } + foreach {varname var} $opt(vars) { + $name eval set [list $varname $var] + } + foreach {mockname arglist retexpr} $opt(mocks) { + establish_mock $name $mockname $arglist $retexpr + } + 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 } + return $name +} +proc copy_array_to_test_interpreter { sicmd dest {src {}} } { + if { $src eq {} } { set src $dest } + upvar $src src_array + $sicmd eval array set [list $dest [array get src_array]] +} +proc delete_test_interpreter { name } { + interp delete $name +} + +proc reset_mock_trace {} { + global mock_call_trace + set mock_call_trace [list] +} +proc dump_mock_trace {} { + global mock_call_trace + puts "<<< mocked calls recorded" + foreach cell $mock_call_trace { + puts " [lindex $cell 0]" + if { [llength $cell] > 1 } { + puts " -> [lindex $cell 1]" + } + } + puts ">>> mocked calls recorded" +} +proc get_mock_trace {} { + global mock_call_trace + return $mock_call_trace +} +proc find_mock_calls { prefix } { + global mock_call_trace + set result [list] + foreach cell $mock_call_trace { + if { [string match "${prefix}*" [lindex $cell 0]] } { + lappend result $cell + } + } + return $result +} + +proc relay_link_call { name args } { + eval [list $name] $args +} +proc establish_link { sicmd name } { + $sicmd alias $name relay_link_call $name +} + +proc record_mock_call { name args } { + global mock_call_trace + lappend mock_call_trace [list [linsert $args 0 $name]] + return +} +proc establish_mock_log_alias { sicmd name } { + $sicmd alias logcall_$name record_mock_call $name +} +proc establish_mock { sicmd name arglist retexpr } { + establish_mock_log_alias $sicmd $name + + set sargl [list] + foreach arg $arglist { lappend sargl [format {$%s} $arg] } + + if { [lindex $arglist end] eq "args" } { + set log_call \ + "eval \[list logcall_$name [join [lrange $sargl 0 end-1]]\] \$args" + } else { + set log_call \ + "logcall_$name [join $sargl]" + } + + $sicmd eval [subst -nocommands { + proc $name {$arglist} { + $log_call + return $retexpr + } + }] +} + +proc relay_shim_call { name args } { + global mock_call_trace + set retval [eval [list $name] $args] + lappend mock_call_trace [list [linsert $args 0 $name] [list $retval]] + return $retval +} +proc establish_shim { sicmd name } { + $sicmd alias $name relay_shim_call $name +} + +proc match_argpat { argpat call } { + set result 1 + foreach {pos qre} $argpat { + set qre [regsub -all {\M\s+(?=[^*+?\s])} $qre {\s+}] + set qre [regsub -all {([*+?])\s+(?=[^*+?\s])} $qre {\1\s+} ] + set out [lindex $call 0 $pos] + verbose "matching: ^$qre$" + verbose " against: $out" + if { ![regexp "^$qre$" $out] } { set result 0 } + } + return $result +} + +proc test_proc_with_mocks { name sicmd code args } { + array set opt { + check_calls {} + } + foreach { key value } $args { + if { ![info exists opt($key)] } { + error "test_proc_with_mocks: unknown option $key" + } + set opt($key) [strip_comment_lines $value] + } + + verbose "-------- begin test: $name" + reset_mock_trace + $sicmd eval $code + dump_mock_trace + + set result pass + foreach { prefix callpos argpat } $opt(check_calls) { + set calls [find_mock_calls $prefix] + + verbose "checking: \[$callpos\] $prefix" + if { $callpos eq "*" } { + # succeed if any call matches both prefix and argpat + set innerresult fail + foreach { call } $calls { + verbose " step: [lindex $call 0]" + if { [match_argpat $argpat $call] } { + set innerresult pass + break + } + } + if { $innerresult ne "pass" } { + verbose " failed!" + set result fail + } + } elseif { $callpos eq "!" } { + # succeed if no calls match prefix + if { [llength $calls] != 0 } { + verbose " failed!" + set result fail + } + } elseif { $callpos eq "U" } { + # prefix selects one unique call + if { [llength $calls] != 1 } { + error "expected unique call" + return + } + if { ![match_argpat $argpat [lindex $calls 0]] } { + verbose " failed!" + set result fail + } + } elseif { [llength $calls] > $callpos } { + if { ![match_argpat $argpat [lindex $calls $callpos]] } { + verbose " failed!" + set result fail + } + } else { + error "failed to select trace record" + return + } + } + + $result $name + verbose "-------- end test: $name" +} + + +#EOF |