testsuite/runtest.libs/mockutil.tcl

   1 # Copyright (C) 2019 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
  19 # This file was written by Jacob Bachmeyer.
  20
  21 # This library provides convenience procedures for running isolated tests
  22 # of DejaGnu procedures in a slave interpreter.  These are designed to be
  23 # run in the child process used by the DejaGnu library tests.
  24
  25 proc strip_comment_lines { text } {
  26     regsub -all -- {\n[[:space:]]*#[^\r\n]*[\r\n]+} $text "\n"
  27 }
  28
  29 proc create_test_interpreter { name opts } {
  30     array set opt {
  31         copy_arrays {} copy_procs {} copy_vars {} attach_vfs {}
  32         link_channels {} link_procs {} shim_procs {} mocks {} vars {}
  33     }
  34     array set opt [strip_comment_lines $opts]
  35
  36     interp create -safe -- $name
  37     foreach array $opt(copy_arrays) { # inlined due to upvar
  38         if { [llength $array] == 2 } {
  39             upvar [lindex $array 1] src_array
  40         } elseif { [llength $array] == 1 } {
  41             upvar [lindex $array 0] src_array
  42         } else {
  43             error "bogus copy_arrays directive: $array"
  44         }
  45         $name eval array set [list [lindex $array 0] [array get src_array]]
  46     }
  47     foreach proc $opt(copy_procs) { # inlined due to uplevel
  48         # proc reconstruction adapted from Tcl info(n) manpage
  49         set argspec [list]
  50         foreach arg [uplevel info args $proc] {
  51             if { [uplevel info default $proc $arg value] } {
  52                 lappend argspec [list $arg $value]
  53             } else {
  54                 lappend argspec [list $arg]
  55             }
  56         }
  57         $name eval proc $proc [list $argspec] [list [uplevel info body $proc]]
  58     }
  59     foreach var $opt(copy_vars) { # inlined due to upvar
  60         if { [llength $var] == 2 } {
  61             upvar [lindex $var 1] src_var
  62         } elseif { [llength $var] == 1 } {
  63             upvar [lindex $var 0] src_var
  64         } else {
  65             error "bogus copy_vars directive: $var"
  66         }
  67         $name eval set [list [lindex $var 0] $src_var]
  68     }
  69     foreach {varname var} $opt(vars) {
  70         $name eval set [list $varname $var]
  71     }
  72     foreach {mockname arglist retexpr} $opt(mocks) {
  73         establish_mock $name $mockname $arglist $retexpr
  74     }
  75     foreach chan $opt(link_channels)    { interp share {} $chan $name }
  76     foreach link $opt(link_procs)       { establish_link $name $link }
  77     foreach shim $opt(shim_procs)       { establish_shim $name $shim }
  78     if { $opt(attach_vfs) ne "" } {
  79         attach_mockvfs $name [lindex $opt(attach_vfs) 0]
  80     }
  81     return $name
  82 }
  83 proc copy_array_to_test_interpreter { sicmd dest {src {}} } {
  84     if { $src eq {} } { set src $dest }
  85     upvar $src src_array
  86     $sicmd eval array set [list $dest [array get src_array]]
  87 }
  88 proc delete_test_interpreter { name } {
  89     interp delete $name
  90 }
  91
  92 proc reset_mock_trace {} {
  93     global mock_call_trace
  94     set mock_call_trace [list]
  95 }
  96 proc dump_mock_trace {} {
  97     global mock_call_trace
  98     puts "<<< mocked calls recorded"
  99     foreach cell $mock_call_trace {
 100         puts "  [lindex $cell 0]"
 101         if { [llength $cell] > 1 } {
 102             puts "    -> [lindex $cell 1]"
 103         }
 104     }
 105     puts ">>> mocked calls recorded"
 106 }
 107 proc get_mock_trace {} {
 108     global mock_call_trace
 109     return $mock_call_trace
 110 }
 111 proc find_mock_calls { prefix } {
 112     global mock_call_trace
 113     set result [list]
 114     foreach cell $mock_call_trace {
 115         if { [string match "${prefix}*" [lindex $cell 0]] } {
 116             lappend result $cell
 117         }
 118     }
 119     return $result
 120 }
 121
 122 proc relay_link_call { name args } {
 123     eval [list $name] $args
 124 }
 125 proc establish_link { sicmd name } {
 126     $sicmd alias $name relay_link_call $name
 127 }
 128
 129 proc record_mock_call { name args } {
 130     global mock_call_trace
 131     lappend mock_call_trace [list [linsert $args 0 $name]]
 132     return
 133 }
 134 proc establish_mock_log_alias { sicmd name } {
 135     $sicmd alias logcall_$name record_mock_call $name
 136 }
 137 proc establish_mock { sicmd name arglist retexpr } {
 138     establish_mock_log_alias $sicmd $name
 139
 140     set sargl [list]
 141     foreach arg $arglist { lappend sargl [format {$%s} $arg] }
 142
 143     if { [lindex $arglist end] eq "args" } {
 144         set log_call \
 145             "eval \[list logcall_$name [join [lrange $sargl 0 end-1]]\] \$args"
 146     } else {
 147         set log_call \
 148             "logcall_$name [join $sargl]"
 149     }
 150
 151     $sicmd eval [subst -nocommands {
 152         proc $name {$arglist} {
 153             $log_call
 154             return $retexpr
 155         }
 156     }]
 157 }
 158
 159 proc relay_shim_call { name args } {
 160     global mock_call_trace
 161     set retval [eval [list $name] $args]
 162     lappend mock_call_trace [list [linsert $args 0 $name] [list $retval]]
 163     return $retval
 164 }
 165 proc establish_shim { sicmd name } {
 166     $sicmd alias $name relay_shim_call $name
 167 }
 168
 169 proc match_argpat { argpat call } {
 170     set result 1
 171     foreach {pos qre} $argpat {
 172         set qre [regsub -all {\M\s+(?=[^*+?\s])} $qre {\s+}]
 173         set qre [regsub -all {([*+?])\s+(?=[^*+?\s])} $qre {\1\s+} ]
 174         set out [lindex $call 0 $pos]
 175         verbose "matching: ^$qre$"
 176         verbose " against:  $out"
 177         if { ![regexp "^$qre$" $out] } { set result 0 }
 178     }
 179     return $result
 180 }
 181
 182 # test_proc_with_mocks testName sicmd testCode {
 183 #   check_calls {
 184 #       prefix mode:[*U[:digit:]] { [argument pattern]... }
 185 #       prefix mode:[!] { }
 186 #       prefix mode:[C] [ { count } | count ]
 187 #   }
 188 # }
 189 proc test_proc_with_mocks { name sicmd code args } {
 190     array set opt {
 191         check_calls {}
 192     }
 193     foreach { key value } $args {
 194         if { ![info exists opt($key)] } {
 195             error "test_proc_with_mocks: unknown option $key"
 196         }
 197         set opt($key) [strip_comment_lines $value]
 198     }
 199
 200     verbose "--------  begin test: $name"
 201     reset_mock_trace
 202     $sicmd eval $code
 203     dump_mock_trace
 204
 205     set result pass
 206     foreach { prefix callpos argpat } $opt(check_calls) {
 207         set calls [find_mock_calls $prefix]
 208
 209         verbose "checking: \[$callpos\] $prefix"
 210         if { $callpos eq "*" } {
 211             # succeed if any call matches both prefix and argpat
 212             set innerresult fail
 213             foreach { call } $calls {
 214                 verbose "    step: [lindex $call 0]"
 215                 if { [match_argpat $argpat $call] } {
 216                     set innerresult pass
 217                     break
 218                 }
 219             }
 220             if { $innerresult ne "pass" } {
 221                 verbose "  failed!"
 222                 set result fail
 223             }
 224         } elseif { $callpos eq "!" } {
 225             # succeed if no calls match prefix
 226             if { [llength $calls] != 0 } {
 227                 verbose "  failed!"
 228                 set result fail
 229             }
 230         } elseif { $callpos eq "C" } {
 231             # succeed if exactly N calls match prefix
 232             if { [llength $calls] != [lindex $argpat 0] } {
 233                 verbose "  failed!"
 234                 set result fail
 235             }
 236         } elseif { $callpos eq "U" } {
 237             # prefix selects one unique call
 238             if { [llength $calls] != 1 } {
 239                 verbose "  expected unique call... failed!"
 240                 set result fail
 241                 continue
 242             }
 243             if { ![match_argpat $argpat [lindex $calls 0]] } {
 244                 verbose "  failed!"
 245                 set result fail
 246             }
 247         } elseif { [llength $calls] > $callpos } {
 248             if { ![match_argpat $argpat [lindex $calls $callpos]] } {
 249                 verbose "  failed!"
 250                 set result fail
 251             }
 252         } else {
 253             verbose "  expected trace record not found... failed!"
 254             set result fail
 255             continue
 256         }
 257     }
 258
 259     $result $name
 260     verbose "--------    end test: $name"
 261 }
 262
 263
 264 #EOF