1package LibGsfTest; 2use strict; 3use Exporter; 4use File::Basename qw(fileparse); 5use Config; 6use XML::Parser; 7 8$| = 1; 9 10@LibGsfTest::ISA = qw (Exporter); 11@LibGsfTest::EXPORT = qw(message test_valgrind 12 test_zip 13 $topsrc $top_builddir 14 $gsf $PERL); 15@LibGsfTest::EXPORT_OK = qw(junkfile $unzip $zipinfo); 16 17use vars qw($topsrc $top_builddir $PERL $verbose); 18use vars qw($gsf $unzip $zipinfo $sevenz); 19 20$PERL = $Config{'perlpath'}; 21$PERL .= $Config{'_exe'} if $^O ne 'VMS' && $PERL !~ m/$Config{'_exe'}$/i; 22 23$unzip = &find_program ("unzip"); 24$zipinfo = &find_program ("zipinfo"); 25$sevenz = &find_program ("7z", 1); 26 27$topsrc = $0; 28$topsrc =~ s|/[^/]+$|/..|; 29$topsrc =~ s|^\./(.)|$1|; 30$topsrc =~ s|/tests/\.\.$||; 31 32$top_builddir = ".."; 33$gsf = "$top_builddir/tools/gsf"; 34$verbose = 0; 35 36# ----------------------------------------------------------------------------- 37 38my @tempfiles; 39END { 40 unlink @tempfiles; 41} 42 43sub junkfile { 44 my ($fn) = @_; 45 push @tempfiles, $fn; 46} 47 48sub removejunk { 49 my ($fn) = @_; 50 unlink $fn; 51 52 if (@tempfiles && $fn eq $tempfiles[-1]) { 53 scalar (pop @tempfiles); 54 } 55} 56 57# ----------------------------------------------------------------------------- 58 59sub system_failure { 60 my ($program,$code) = @_; 61 62 if ($code == -1) { 63 die "failed to run $program: $!\n"; 64 } elsif ($code >> 8) { 65 my $sig = $code >> 8; 66 die "$program died due to signal $sig\n"; 67 } else { 68 die "$program exited with exit code $code\n"; 69 } 70} 71 72sub read_file { 73 my ($fn) = @_; 74 75 local (*FIL); 76 open (FIL, $fn) or die "Cannot open $fn: $!\n"; 77 local $/ = undef; 78 my $lines = <FIL>; 79 close FIL; 80 81 return $lines; 82} 83 84sub write_file { 85 my ($fn,$contents) = @_; 86 87 local (*FIL); 88 open (FIL, ">$fn.tmp") or die "Cannot create $fn.tmp: $!\n"; 89 print FIL $contents; 90 close FIL; 91 rename "$fn.tmp", $fn; 92} 93 94sub update_file { 95 my ($fn,$contents) = @_; 96 97 my @stat = stat $fn; 98 die "Cannot stat $fn: $!\n" unless @stat > 2; 99 100 &write_file ($fn,$contents); 101 102 chmod $stat[2], $fn or 103 die "Cannot chmod $fn: $!\n"; 104} 105 106# Print a string with each line prefixed by "| ". 107sub dump_indented { 108 my ($txt) = @_; 109 return if $txt eq ''; 110 $txt =~ s/^/| /gm; 111 $txt = "$txt\n" unless substr($txt, -1) eq "\n"; 112 print STDERR $txt; 113} 114 115sub find_program { 116 my ($p,$qoptional) = @_; 117 118 if ($p =~ m{/}) { 119 return $p if -x $p; 120 } else { 121 my $PATH = exists $ENV{'PATH'} ? $ENV{'PATH'} : ''; 122 foreach my $dir (split (':', $PATH)) { 123 $dir = '.' if $dir eq ''; 124 my $tentative = "$dir/$p"; 125 return $tentative if -x $tentative; 126 } 127 } 128 129 return undef if $qoptional; 130 131 &report_skip ("$p is missing"); 132} 133 134# ----------------------------------------------------------------------------- 135 136sub message { 137 my ($message) = @_; 138 print "-" x 79, "\n"; 139 my $me = $0; 140 $me =~ s|^.*/||; 141 foreach (split (/\n/, $message)) { 142 print "$me: $_\n"; 143 } 144} 145 146# ----------------------------------------------------------------------------- 147 148sub test_command { 149 my ($cmd,$test) = @_; 150 151 my $output = `$cmd 2>&1`; 152 my $err = $?; 153 die "Failed command: $cmd\n" if $err; 154 155 &dump_indented ($output); 156 local $_ = $output; 157 if (&$test ($output)) { 158 print STDERR "Pass\n"; 159 } else { 160 die "Fail\n"; 161 } 162} 163 164# ----------------------------------------------------------------------------- 165 166sub test_valgrind { 167 my ($cmd,$uselibtool) = @_; 168 169 local (%ENV) = %ENV; 170 $ENV{'G_DEBUG'} .= ':gc-friendly:resident-modules'; 171 $ENV{'G_SLICE'} = 'always-malloc'; 172 delete $ENV{'VALGRIND_OPTS'}; 173 174 my $outfile = 'valgrind.log'; 175 unlink $outfile; 176 die "Cannot remove $outfile.\n" if -f $outfile; 177 &junkfile ($outfile); 178 179 my $valhelp = `valgrind --help 2>&1`; 180 &report_skip ("Valgrind is not available") unless defined $valhelp; 181 die "Problem running valgrind.\n" unless $valhelp =~ /log-file/; 182 183 my $valvers = `valgrind --version`; 184 die "Problem running valgrind.\n" 185 unless $valvers =~ /^valgrind-(\d+)\.(\d+)\.(\d+)/; 186 $valvers = $1 * 10000 + $2 * 100 + $3; 187 &report_skip ("Valgrind is too old") unless $valvers >= 30500; 188 189 $cmd = "--gen-suppressions=all $cmd"; 190 191 { 192 my $suppfile = "$topsrc/tests/common.supp"; 193 &report_skip ("file $suppfile does not exist") unless -r $suppfile; 194 $cmd = "--suppressions=$suppfile $cmd" if -r $suppfile; 195 } 196 197 { 198 my $suppfile = $0; 199 $suppfile =~ s/\.pl$/.supp/; 200 $cmd = "--suppressions=$suppfile $cmd" if -r $suppfile; 201 } 202 203 # $cmd = "--show-reachable=yes $cmd"; 204 $cmd = "--show-below-main=yes $cmd"; 205 $cmd = "--leak-check=full $cmd"; 206 $cmd = "--num-callers=20 $cmd"; 207 $cmd = "--track-fds=yes $cmd"; 208 if ($valhelp =~ /--log-file-exactly=/) { 209 $cmd = "--log-file-exactly=$outfile $cmd"; 210 } else { 211 $cmd = "--log-file=$outfile $cmd"; 212 } 213 $cmd = "valgrind $cmd"; 214 $cmd = "../libtool --mode=execute $cmd" if $uselibtool; 215 216 my $code = system ($cmd); 217 &system_failure ('valgrind', $code) if $code; 218 219 my $txt = &read_file ($outfile); 220 &removejunk ($outfile); 221 my $errors = ($txt =~ /ERROR\s+SUMMARY:\s*(\d+)\s+errors?/i) 222 ? $1 223 : -1; 224 if ($errors == 0) { 225 &dump_indented ($txt) if $verbose; 226 print STDERR "Pass\n"; 227 return; 228 } 229 230 &dump_indented ($txt); 231 die "Fail\n"; 232} 233 234# ----------------------------------------------------------------------------- 235 236sub quotearg { 237 return join (' ', map { "earg1 ($_) } @_); 238} 239 240sub quotearg1 { 241 my ($arg) = @_; 242 243 return "''" if $arg eq ''; 244 my $res = ''; 245 while ($arg ne '') { 246 if ($arg =~ m!^([-=/._a-zA-Z0-9]+)!) { 247 $res .= $1; 248 $arg = substr ($arg, length $1); 249 } else { 250 $res .= "\\" . substr ($arg, 0, 1); 251 $arg = substr ($arg, 1); 252 } 253 } 254 return $res; 255} 256 257# ----------------------------------------------------------------------------- 258 259sub zipinfo_callback { 260 my ($archive) = @_; 261 262 my @result = (); 263 264 my $entry = undef; 265 foreach (`$zipinfo -v $archive`) { 266 print STDERR "| $_" if $verbose; 267 268 if (/^Central directory entry #\d+:$/) { 269 push @result, $entry if defined $entry; 270 $entry = {}; 271 next; 272 } 273 274 if ($entry && /^\s*- A subfield with ID 0x0001 \(PKWARE 64-bit sizes\)/) { 275 $entry->{'zip64'} = 1; 276 next; 277 } 278 279 if ($entry && /^\s*- A subfield with ID 0x4949 /) { 280 $entry->{'ignore'} = 1; 281 next; 282 } 283 284 if ($entry && /^ *(\S.*\S):\s*(\S.*)$/) { 285 my $field = $1; 286 my $val = $2; 287 $val =~ s/ (bytes|characters)$//; 288 $entry->{$field} = $val; 289 next; 290 } 291 292 if ($entry && keys %$entry == 0 && /^ (.*)$/) { 293 $entry->{'name'} = $1; 294 next; 295 } 296 } 297 push @result, $entry if defined $entry; 298 299 return (undef,\@result); 300} 301 302sub test_zip { 303 my (%args) = @_; 304 305 $args{'create-arg'} = 'createzip'; 306 $args{'ext'} = 'zip'; 307 $args{'archive-tester'} = $sevenz ? [$sevenz, 't'] : [$unzip, '-q', '-t']; 308 $args{'independent-cat'} = [$unzip, '-p']; 309 $args{'infofunc'} = \&zipinfo_callback; 310 311 foreach my $test (@{$args{'zip-member-tests'} || []}) { 312 $args{'member-tests'} ||= []; 313 314 if ($test eq 'zip64') { 315 push @{$args{'member-tests'}}, 316 sub { 317 my ($member) = @_; 318 my $name = $member->{'name'}; 319 die "Member $name should have been zip64\n" unless $member->{'zip64'}; 320 }; 321 next; 322 } 323 324 if ($test eq '!zip64') { 325 push @{$args{'member-tests'}}, 326 sub { 327 my ($member) = @_; 328 my $name = $member->{'name'}; 329 die "Member $name should not be zip64\n" if $member->{'zip64'}; 330 }; 331 next; 332 } 333 334 if ($test eq '!ignore') { 335 push @{$args{'member-tests'}}, 336 sub { 337 my ($member) = @_; 338 my $name = $member->{'name'}; 339 die "Member $name should not use ignore extension\n" if $member->{'ignore'}; 340 }; 341 next; 342 } 343 } 344 345 &test_archive (\%args); 346} 347 348# ----------------------------------------------------------------------------- 349 350sub test_archive { 351 my ($pargs) = @_; 352 353 my $pfiles = $pargs->{'files'}; 354 my $ext = $pargs->{'ext'}; 355 my $tester = $pargs->{'archive-tester'}; 356 my $independent_cat = $pargs->{'independent-cat'}; 357 my $member_tests = $pargs->{'member-tests'}; 358 my $infofunc = $pargs->{'infofunc'}; 359 360 my $archive = "test.$ext"; 361 &junkfile ($archive); 362 363 { 364 my $gsfcmd = $pargs->{'create-arg'}; 365 my $gsfopts = $pargs->{'create-options'} || []; 366 my $stdio = $pargs->{'stdio'}; 367 my $cmd = "earg ($gsf, $gsfcmd, @$gsfopts, 368 ($stdio ? "-" : $archive), 369 @$pfiles); 370 print STDERR "# $cmd\n"; 371 my $code = 372 $stdio 373 ? system ("($cmd | cat >$archive) 2>&1 | sed -e 's/^/| /'") 374 : system ("$cmd 2>&1 | sed -e 's/^/| /'"); 375 &system_failure ($gsf, $code) if $code; 376 die "$gsf failed to create the archive $archive\n" unless -e $archive; 377 } 378 379 if ($tester) { 380 my $cmd = "earg (@$tester, $archive); 381 print STDERR "# $cmd\n"; 382 my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'"); 383 &system_failure ($tester->[0], $code) if $code; 384 } 385 386 foreach my $file (@$pfiles) { 387 my $cmd = "earg ('cat', $file); 388 print STDERR "# $cmd\n"; 389 my $original_data = `$cmd`; 390 391 # Match stored data using external extractor if we have one 392 if ($independent_cat) { 393 my $cmd = "earg (@$independent_cat, $archive, $file); 394 print STDERR "# $cmd\n"; 395 my $stored_data = `$cmd`; 396 397 die "Mismatch for member $file\n" 398 unless $stored_data eq $original_data; 399 } 400 401 # Match stored data using our own extractor 402 { 403 my $cmd = "earg ($gsf, 'cat', $archive, $file); 404 print STDERR "# $cmd\n"; 405 my $stored_data = `$cmd`; 406 407 die "Mismatch for member $file\n" 408 unless $stored_data eq $original_data; 409 } 410 411 print STDERR "# Member $file matched.\n"; 412 } 413 414 if ($infofunc) { 415 my ($ainfo,$minfo) = &$infofunc ($archive); 416 417 foreach my $test (@$member_tests) { 418 foreach my $member (@$minfo) { 419 &$test ($member); 420 } 421 } 422 } 423} 424 425# ----------------------------------------------------------------------------- 426 427sub report_skip { 428 my ($txt) = @_; 429 430 print "SKIP -- $txt\n"; 431 # 77 is magic for automake 432 exit 77; 433} 434 435# ----------------------------------------------------------------------------- 436# Setup a consistent environment 437 438&report_skip ("all tests skipped") if exists $ENV{'LIBGSF_SKIP_TESTS'}; 439 440delete $ENV{'G_SLICE'}; 441$ENV{'G_DEBUG'} = 'fatal_criticals'; 442 443delete $ENV{'LANG'}; 444delete $ENV{'LANGUAGE'}; 445foreach (keys %ENV) { delete $ENV{$_} if /^LC_/; } 446$ENV{'LC_ALL'} = 'C'; 447 448# libgsf listens for this 449delete $ENV{'WINDOWS_LANGUAGE'}; 450 451if (@ARGV && $ARGV[0] eq '--verbose') { 452 $verbose = 1; 453 scalar shift @ARGV; 454} 455 4561; 457