File: component-test.pl

package info (click to toggle)
fsvs 1.2.7-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid, stretch
  • size: 2,964 kB
  • ctags: 1,464
  • sloc: ansic: 16,650; sh: 5,885; perl: 783; makefile: 338; python: 90
file content (123 lines) | stat: -rwxr-xr-x 2,018 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
#!/usr/bin/perl

use IPC::Open2;

$logfile=shift;

$|=1;

# Don't try $BINdflt - that might have valgrind or similar in front.
$pid = open2(RDR, WTR, 'gdb ' . $ENV{"BIN_FULLPATH"} . ' 2>&1');
$gdb_prompt_delimiter = "GDB-delim-$$-" . time;

$ign=Exch("set pagination off\nset prompt $gdb_prompt_delimiter\\n");

$match="";
$err=0;
$running=0;
$line=0;

@output=();

while (<>)
{
	$line++;
	chomp;
	next if m/^\s*##/;
	next if m/^\s*$/;

	$match="\\\$\\d+ = $1",next
		if m{^\s*#=\s+(.*)};
	$match=$1,next 
		if m{^\s*#[/~]\s+(.*)};

	if (!$running)
	{
		if (/^\s*(print|set|call)\s*/) 
		{
			$err ||= Exch("b _do_component_tests");
# We have to use -D to avoid getting debug messages ... they'd show 
# up in the output, and potentially mess our matching up.
			$err ||= Exch("r -d -D invalid");
			$running=1;
		}
		else
		{
			$running=1 if m#^\s*(r|R)#;
		}
	}

	if (s#^\+##)
	{
		$_=eval($_);
		die $@ if $@;
	}
	else
	{
# substitute $#$ENV{"WAA"}# and similar.
# We don't use ${} as that's needed for hash lookup (%ENV)
		while (s/\$\#(.*?)\#/eval($1)/e)
		{
			die $@ if $@;
		}
	}


	$err ||= Exch($_, $match);
	$match="";

	$running=0 if m#^\s*kill#;
}

Exch("kill");
Exch("q");

open(LOG, "> $logfile") || die "$logfile: $!\n";
print LOG @output;
close LOG;

print @output if $err || length($ENV{"VERBOSE"});
exit $err;



sub Exch
{
	my($out, $exp)=@_;
	my($input, $ok, $err);
	local(%SIG);
	local($/);

	$/=$gdb_prompt_delimiter;

	$SIG{"ALRM"}=sub { die "Timeout waiting for $exp\n"; };

	print WTR $out,"\n";
	push @output,"send>> ", $out,"\n";

	alarm(4);
	$input=<RDR>;
	alarm(0);


	substr($input, -length($/), length($/))="";

# find non-empty lines
	@in=();
	map {
		push @in, $_;
	} grep(/\S/, split(/\n/, $input));
	@in_str=map { "recv<< " . $_ . "\n"; } @in;
	push @output, @in_str;

	return 0 if (!$exp);

	$found = grep(m/$exp/m, @in);
	$err=!$found;
	push @output, "expect '@in' to match /$exp/: err=$err\n";

	warn("$ARGV:$line: /$exp/ not matched:\n", @in_str)
		if ($err);
	return $err;
}