path: root/testsuite/runtest.libs/mockutil.tcl

# 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 {} attach_vfs {}
	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 }
    if { $opt(attach_vfs) ne "" } {
	attach_mockvfs $name [lindex $opt(attach_vfs) 0]
    }
    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
}

# 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 {}
    }
    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 "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 } {
		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