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