1#!/usr/bin/perl 2 3use strict; 4use warnings; 5use Getopt::Long; 6use IO::Handle; 7use IPC::Open2 qw( open2 ); 8use POSIX qw( WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG ); 9 10my $VALGRIND = 0; 11GetOptions( 12 'valgrind|v+' => \$VALGRIND, 13) or exit 1; 14 15my ( $hin, $hout, $hpid ); 16{ 17 local $ENV{LD_LIBRARY_PATH} = ".libs"; 18 my @command = "t/.libs/harness"; 19 unshift @command, "valgrind", "--tool=memcheck", "--leak-check=yes", "--num-callers=25", "--log-file=valgrind.out", "--error-exitcode=126" if $VALGRIND; 20 21 $hpid = open2 $hout, $hin, @command or die "Cannot open2 harness - $!"; 22} 23 24my $exitcode = 0; 25 26my $command; 27my @expect; 28 29sub do_onetest 30{ 31 $hin->print( "$command\n" ); 32 undef $command; 33 34 my $fail_printed = 0; 35 36 while( my $outline = <$hout> ) { 37 last if $outline eq "DONE\n" or $outline eq "?\n"; 38 39 chomp $outline; 40 41 if( !@expect ) { 42 print "# Test failed\n" unless $fail_printed++; 43 print "# expected nothing more\n" . 44 "# Actual: $outline\n"; 45 next; 46 } 47 48 my $expectation = shift @expect; 49 50 next if $expectation eq $outline; 51 52 print "# Test failed\n" unless $fail_printed++; 53 print "# Expected: $expectation\n" . 54 "# Actual: $outline\n"; 55 } 56 57 if( @expect ) { 58 print "# Test failed\n" unless $fail_printed++; 59 print "# Expected: $_\n" . 60 "# didn't happen\n" for @expect; 61 } 62 63 $exitcode = 1 if $fail_printed; 64} 65 66sub do_line 67{ 68 my ( $line ) = @_; 69 70 if( $line =~ m/^!(.*)/ ) { 71 do_onetest if defined $command; 72 print "> $1\n"; 73 } 74 75 # Commands have capitals 76 elsif( $line =~ m/^([A-Z]+)/ ) { 77 # Some convenience formatting 78 if( $line =~ m/^(PUSH|ENCIN) (.*)$/ ) { 79 # we're evil 80 my $string = eval($2); 81 $line = "$1 " . unpack "H*", $string; 82 } 83 84 do_onetest if defined $command; 85 86 $command = $line; 87 undef @expect; 88 } 89 # Expectations have lowercase 90 elsif( $line =~ m/^([a-z]+)/ ) { 91 # Convenience formatting 92 if( $line =~ m/^(text|encout) (.*)$/ ) { 93 $line = "$1 " . join ",", map sprintf("%x", $_), eval($2); 94 } 95 elsif( $line =~ m/^(output) (.*)$/ ) { 96 $line = "$1 " . join ",", map sprintf("%x", $_), unpack "C*", eval($2); 97 } 98 elsif( $line =~ m/^control (.*)$/ ) { 99 $line = sprintf "control %02x", eval($1); 100 } 101 elsif( $line =~ m/^csi (\S+) (.*)$/ ) { 102 $line = sprintf "csi %02x %s", eval($1), $2; # TODO 103 } 104 elsif( $line =~ m/^(escape|osc|dcs) (.*)$/ ) { 105 $line = "$1 " . join "", map sprintf("%02x", $_), unpack "C*", eval($2); 106 } 107 elsif( $line =~ m/^putglyph (\S+) (.*)$/ ) { 108 $line = "putglyph " . join( ",", map sprintf("%x", $_), eval($1) ) . " $2"; 109 } 110 elsif( $line =~ m/^(?:movecursor|scrollrect|moverect|erase|damage|sb_pushline|sb_popline|settermprop|setmousefunc) / ) { 111 # no conversion 112 } 113 else { 114 warn "Unrecognised test expectation '$line'\n"; 115 } 116 117 push @expect, $line; 118 } 119 # ?screen_row assertion is emulated here 120 elsif( $line =~ s/^\?screen_row\s+(\d+)\s*=\s*// ) { 121 my $row = $1; 122 my $row1 = $row + 1; 123 my $want = eval($line); 124 125 do_onetest if defined $command; 126 127 # TODO: may not be 80 128 $hin->print( "\?screen_chars $row,0,$row1,80\n" ); 129 my $response = <$hout>; 130 chomp $response; 131 132 $response = pack "C*", map hex, split m/,/, $response; 133 if( $response ne $want ) { 134 print "# Assert ?screen_row $row failed:\n" . 135 "# Expected: $want\n" . 136 "# Actual: $response\n"; 137 $exitcode = 1; 138 } 139 } 140 # Assertions start with '?' 141 elsif( $line =~ s/^\?([a-z]+.*?=)\s+// ) { 142 do_onetest if defined $command; 143 144 my ( $assertion ) = $1 =~ m/^(.*)\s+=/; 145 146 $hin->print( "\?$assertion\n" ); 147 my $response = <$hout>; defined $response or wait, die "Test harness failed - $?\n"; 148 chomp $response; 149 150 if( $response ne $line ) { 151 print "# Assert $assertion failed:\n" . 152 "# Expected: $line\n" . 153 "# Actual: $response\n"; 154 $exitcode = 1; 155 } 156 } 157 # Test controls start with '$' 158 elsif( $line =~ s/\$SEQ\s+(\d+)\s+(\d+):\s*// ) { 159 my ( $low, $high ) = ( $1, $2 ); 160 foreach my $val ( $low .. $high ) { 161 ( my $inner = $line ) =~ s/\\#/$val/g; 162 do_line( $inner ); 163 } 164 } 165 elsif( $line =~ s/\$REP\s+(\d+):\s*// ) { 166 my $count = $1; 167 do_line( $line ) for 1 .. $count; 168 } 169 else { 170 die "Unrecognised TEST line $line\n"; 171 } 172} 173 174open my $test, "<", $ARGV[0] or die "Cannot open test script $ARGV[0] - $!"; 175 176while( my $line = <$test> ) { 177 $line =~ s/^\s+//; 178 next if $line =~ m/^(?:#|$)/; 179 180 chomp $line; 181 do_line( $line ); 182} 183 184do_onetest if defined $command; 185 186close $hin; 187close $hout; 188 189waitpid $hpid, 0; 190if( $? ) { 191 printf STDERR "Harness exited %d\n", WEXITSTATUS($?) if WIFEXITED($?); 192 printf STDERR "Harness exit signal %d\n", WTERMSIG($?) if WIFSIGNALED($?); 193 $exitcode = WIFEXITED($?) ? WEXITSTATUS($?) : 125; 194} 195 196exit $exitcode; 197