Add initial unit tests for lib/dg.exp

ChangeLog

@@ -1,3 +1,13 @@
+2022-09-30  Jacob Bachmeyer  <[email protected]>
+
+	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  <[email protected]>
 
 	PR58065

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"

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