GnumericTest.pm 19.1 KB
Newer Older
Morten Welinder's avatar
Morten Welinder committed
1 2 3 4
package GnumericTest;
use strict;
use Exporter;
use File::Basename qw(fileparse);
Morten Welinder's avatar
Morten Welinder committed
5
use Config;
6
use XML::Parser;
Morten Welinder's avatar
Morten Welinder committed
7

8 9
$| = 1;

Morten Welinder's avatar
Morten Welinder committed
10
@GnumericTest::ISA = qw (Exporter);
11
@GnumericTest::EXPORT = qw(test_sheet_calc test_valgrind
12
                           test_importer test_exporter test_roundtrip
13
			   test_ssindex sstest test_command message subtest
14
			   $ssconvert $sstest $ssdiff $topsrc $top_builddir
15
			   $subtests $samples $PERL);
Morten Welinder's avatar
Morten Welinder committed
16
@GnumericTest::EXPORT_OK = qw(junkfile);
Morten Welinder's avatar
Morten Welinder committed
17

18
use vars qw($topsrc $top_builddir $samples $default_subtests $subtests $PERL $verbose);
19
use vars qw($ssconvert $ssindex $sstest $ssdiff);
20 21 22 23
use vars qw($normalize_gnumeric);

$PERL = $Config{'perlpath'};
$PERL .= $Config{'_exe'} if $^O ne 'VMS' && $PERL !~ m/$Config{'_exe'}$/i;
24 25 26 27 28 29

$topsrc = $0;
$topsrc =~ s|/[^/]+$|/..|;
$topsrc =~ s|/test/\.\.$||;

$top_builddir = "..";
30
$samples = "$topsrc/samples"; $samples =~ s{^\./}{};
31 32 33
$ssconvert = "$top_builddir/src/ssconvert";
$ssindex = "$top_builddir/src/ssindex";
$sstest = "$top_builddir/src/sstest";
34
$ssdiff = "$top_builddir/src/ssdiff";
35
$normalize_gnumeric = "$PERL $topsrc/test/normalize-gnumeric";
Morten Welinder's avatar
Morten Welinder committed
36
$verbose = 0;
37 38
$default_subtests = '*';
$subtests = undef;
Morten Welinder's avatar
Morten Welinder committed
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

# -----------------------------------------------------------------------------

my @tempfiles;
END {
    unlink @tempfiles;
}

sub junkfile {
    my ($fn) = @_;
    push @tempfiles, $fn;
}

sub removejunk {
    my ($fn) = @_;
    unlink $fn;

    if (@tempfiles && $fn eq $tempfiles[-1]) {
	scalar (pop @tempfiles);
    }
}

# -----------------------------------------------------------------------------

sub system_failure {
    my ($program,$code) = @_;

    if ($code == -1) {
	die "failed to run $program: $!\n";
    } elsif ($code >> 8) {
	my $sig = $code >> 8;
	die "$program died due to signal $sig\n";
    } else {
	die "$program exited with exit code $code\n";
    }
}

sub read_file {
    my ($fn) = @_;

    local (*FIL);
    open (FIL, $fn) or die "Cannot open $fn: $!\n";
    local $/ = undef;
    my $lines = <FIL>;
    close FIL;

    return $lines;
}

sub write_file {
    my ($fn,$contents) = @_;

    local (*FIL);
    open (FIL, ">$fn.tmp") or die "Cannot create $fn.tmp: $!\n";
    print FIL $contents;
    close FIL;
    rename "$fn.tmp", $fn;
}

sub update_file {
    my ($fn,$contents) = @_;

    my @stat = stat $fn;
    die "Cannot stat $fn: $!\n" unless @stat > 2;

    &write_file ($fn,$contents);

    chmod $stat[2], $fn or
	die "Cannot chmod $fn: $!\n";
}

Morten Welinder's avatar
Morten Welinder committed
110
# Print a string with each line prefixed by "| ".
111 112
sub dump_indented {
    my ($txt) = @_;
113
    return if $txt eq '';
Morten Welinder's avatar
Morten Welinder committed
114
    $txt =~ s/^/| /gm;
115
    $txt = "$txt\n" unless substr($txt, -1) eq "\n";
Morten Welinder's avatar
Morten Welinder committed
116
    print STDERR $txt;
117 118
}

119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
sub find_program {
    my ($p) = @_;

    if ($p =~ m{/}) {
	return $p if -x $p;
    } else {
	my $PATH = exists $ENV{'PATH'} ? $ENV{'PATH'} : '';
	foreach my $dir (split (':', $PATH)) {
	    $dir = '.' if $dir eq '';
	    my $tentative = "$dir/$p";
	    return $tentative if -x $tentative;
	}
    }

    &report_skip ("$p is missing");
}

Morten Welinder's avatar
Morten Welinder committed
136 137
# -----------------------------------------------------------------------------

138 139 140 141 142 143 144 145 146 147 148 149
sub message {
    my ($message) = @_;
    print "-" x 79, "\n";
    my $me = $0;
    $me =~ s|^.*/||;
    foreach (split (/\n/, $message)) {
	print "$me: $_\n";
    }
}

# -----------------------------------------------------------------------------

150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
sub subtest {
    my ($q) = @_;

    my $res = 0;
    foreach my $t (split (',', $subtests || $default_subtests)) {
	if ($t eq '*' || $t eq $q) {
	    $res = 1;
	    next;
	} elsif ($t eq '-*' || $t eq "-$q") {
	    $res = 0;
	    next;
	}
    }
    return $res;
}

# -----------------------------------------------------------------------------

Morten Welinder's avatar
Morten Welinder committed
168 169 170
sub test_command {
    my ($cmd,$test) = @_;

171
    my $output = `$cmd 2>&1`;
Morten Welinder's avatar
Morten Welinder committed
172 173 174
    my $err = $?;
    die "Failed command: $cmd\n" if $err;

175
    &dump_indented ($output);
Morten Welinder's avatar
Morten Welinder committed
176 177 178 179 180 181 182 183 184 185
    local $_ = $output;
    if (&$test ($output)) {
	print STDERR "Pass\n";
    } else {
	die "Fail\n";
    }
}

# -----------------------------------------------------------------------------

186 187 188 189
sub sstest {
    my $test = shift @_;
    my $expected = shift @_;

190
    my $cmd = &quotearg ($sstest, $test);
191 192 193 194 195 196 197 198
    my $actual = `$cmd 2>&1`;
    my $err = $?;
    die "Failed command: $cmd\n" if $err;

    my $ok;
    if (ref $expected) {
	local $_ = $actual;
	$ok = &$expected ($_);
199 200 201 202 203
	if (!$ok) {
	    foreach (split ("\n", $actual)) {
		print "| $_\n";
	    }
	}
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
    } else {
	my @actual = split ("\n", $actual);
	chomp @actual;
	while (@actual > 0 && $actual[-1] eq '') {
	    my $dummy = pop @actual;
	}

	my @expected = split ("\n", $expected);
	chomp @expected;
	while (@expected > 0 && $expected[-1] eq '') {
	    my $dummy = pop @expected;
	}

	my $i = 0;
	while ($i < @actual && $i < @expected) {
	    last if $actual[$i] ne $expected[$i];
	    $i++;
	}
	if ($i < @actual || $i < @expected) {
	    $ok = 0;
	    print STDERR "Differences between actual and expected on line ", ($i + 1), ":\n";
	    print STDERR "Actual  : ", ($i < @actual ? $actual[$i] : "-"), "\n";
	    print STDERR "Expected: ", ($i < @expected ? $expected[$i] : "-"), "\n";
	} else {
	    $ok = 1;
	}
    }

    if ($ok) {
	print STDERR "Pass\n";
    } else {
	die "Fail.\n\n";
    }
}

# -----------------------------------------------------------------------------

Morten Welinder's avatar
Morten Welinder committed
241
sub test_sheet_calc {
242 243 244
    my $file = shift @_;
    my $pargs = (ref $_[0]) ? shift @_ : [];
    my ($range,$expected) = @_;
Morten Welinder's avatar
Morten Welinder committed
245

246 247
    &report_skip ("file $file does not exist") unless -r $file;

Morten Welinder's avatar
Morten Welinder committed
248 249 250 251
    my $tmp = fileparse ($file);
    $tmp =~ s/\.[a-zA-Z0-9]+$/.csv/;
    &junkfile ($tmp);

252
    my $cmd = "$ssconvert " . &quotearg (@$pargs, '--recalc', "--export-range=$range", $file, $tmp);
253 254
    print STDERR "# $cmd\n" if $verbose;
    my $code = system ("$cmd 2>&1 | sed -e 's/^/| /' ");
Morten Welinder's avatar
Morten Welinder committed
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271
    &system_failure ($ssconvert, $code) if $code;

    my $actual = &read_file ($tmp);

    my $ok;
    if (ref $expected) {
	local $_ = $actual;
	$ok = &$expected ($_);
    } else {
	$ok = ($actual eq $expected);
    }

    &removejunk ($tmp);

    if ($ok) {
	print STDERR "Pass\n";
    } else {
Morten Welinder's avatar
Morten Welinder committed
272 273
	$actual =~ s/\s+$//;
	&dump_indented ($actual);
274
	die "Fail.\n\n";
Morten Welinder's avatar
Morten Welinder committed
275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300
    }
}

# -----------------------------------------------------------------------------

my $import_db = 'import-db';

# Modes:
#   check: check that conversion produces right file
#   create-db: save the current corresponding .gnumeric
#   diff: diff conversion against saved .gnumeric
#   update-SHA-1: update $0 to show current SHA-1  [validate first!]

sub test_importer {
    my ($file,$sha1,$mode) = @_;

    my $tmp = fileparse ($file);
    ($tmp =~ s/\.[a-zA-Z0-9]+$/.gnumeric/ ) or ($tmp .= '.gnumeric');
    if ($mode eq 'create-db') {
	-d $import_db or mkdir ($import_db, 0777) or
	    die "Cannot create $import_db: $!\n";
	$tmp = "$import_db/$tmp";
    } else {
	&junkfile ($tmp);
    }

301 302
    &report_skip ("file $file does not exist") unless -r $file;

Morten Welinder's avatar
Morten Welinder committed
303 304 305
    my $code = system ("$ssconvert '$file' '$tmp' 2>&1 | sed -e 's/^/| /'");
    &system_failure ($ssconvert, $code) if $code;

306
    my $htxt = `zcat -f '$tmp' | $normalize_gnumeric | sha1sum`;
307
    my $newsha1 = lc substr ($htxt, 0, 40);
Morten Welinder's avatar
Morten Welinder committed
308 309 310 311 312 313
    die "SHA-1 failure\n" unless $newsha1 =~ /^[0-9a-f]{40}$/;

    if ($mode eq 'check') {
	if ($sha1 ne $newsha1) {
	    die "New SHA-1 is $newsha1; expected was $sha1\n";
	}
Morten Welinder's avatar
Morten Welinder committed
314
	print STDERR "Pass\n";
Morten Welinder's avatar
Morten Welinder committed
315 316 317 318 319 320 321 322 323 324 325 326
    } elsif ($mode eq 'create-db') {
	if ($sha1 ne $newsha1) {
	    warn ("New SHA-1 is $newsha1; expected was $sha1\n");
	}
	# No file to remove
	return;
    } elsif ($mode eq 'diff') {
	my $saved = "$import_db/$tmp";
	die "$saved not found\n" unless -r $saved;

	my $tmp1 = "$tmp-old";
	&junkfile ($tmp1);
327 328
	my $code1 = system ("zcat -f '$saved' >'$tmp1'");
	&system_failure ('zcat', $code1) if $code1;
Morten Welinder's avatar
Morten Welinder committed
329 330 331

	my $tmp2 = "$tmp-new";
	&junkfile ($tmp2);
332 333
	my $code2 = system ("zcat -f '$tmp' >'$tmp2'");
	&system_failure ('zcat', $code2) if $code2;
Morten Welinder's avatar
Morten Welinder committed
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353

	my $code3 = system ('diff', @ARGV, $tmp1, $tmp2);

	&removejunk ($tmp2);
	&removejunk ($tmp1);
    } elsif ($mode =~ /^update-(sha|SHA)-?1/) {
	if ($sha1 ne $newsha1) {
	    my $script = &read_file ($0);
	    my $count = ($script =~ s/\b$sha1\b/$newsha1/g);
	    die "SHA-1 found in script $count times\n" unless $count == 1;
	    &update_file ($0, $script);
	}
	return;
    } else {
	die "Invalid mode \"$mode\"\n";
    }

    &removejunk ($tmp);
}

Morten Welinder's avatar
Morten Welinder committed
354 355
# -----------------------------------------------------------------------------

356 357 358
sub test_exporter {
    my ($file) = @_;

359 360
    &report_skip ("file $file does not exist") unless -r $file;

361 362 363 364
    my $tmp = fileparse ($file);
    $tmp =~ s/\.([a-zA-Z0-9]+)$// or die "Must have extension for export test.";
    my $ext = $1;
    my $code;
365
    my $keep = 0;
366 367

    my $tmp1 = "$tmp.gnumeric";
368
    &junkfile ($tmp1) unless $keep;
369
    {
370
	my $cmd = &quotearg ($ssconvert, $file, $tmp1);
371 372 373 374
	print STDERR "# $cmd\n" if $verbose;
	my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
	&system_failure ($ssconvert, $code) if $code;
    }
375 376

    my $tmp2 = "$tmp-new.$ext";
377
    &junkfile ($tmp2) unless $keep;
378
    {
379
	my $cmd = &quotearg ($ssconvert, $file, $tmp2);
380 381 382 383
	print STDERR "# $cmd\n" if $verbose;
	my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
	&system_failure ($ssconvert, $code) if $code;
    }
384 385

    my $tmp3 = "$tmp-new.gnumeric";
386
    &junkfile ($tmp3) unless $keep;
387
    {
388
	my $cmd = &quotearg ($ssconvert, $tmp2, $tmp3);
389 390 391 392
	print STDERR "# $cmd\n" if $verbose;
	my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
	&system_failure ($ssconvert, $code) if $code;
    }
393 394

    my $tmp4 = "$tmp.xml";
395
    &junkfile ($tmp4) unless $keep;
396
    $code = system (&quotearg ("zcat", "-f", $tmp1) . " >" . &quotearg ($tmp4));
397 398 399
    &system_failure ('zcat', $code) if $code;

    my $tmp5 = "$tmp-new.xml";
400
    &junkfile ($tmp5) unless $keep;
401
    $code = system (&quotearg ("zcat" , "-f", $tmp3) . " >" . &quotearg ($tmp5));
402 403 404 405 406 407 408 409 410
    &system_failure ('zcat', $code) if $code;

    $code = system ('diff', '-u', $tmp4, $tmp5);
    &system_failure ('diff', $code) if $code;

    print STDERR "Pass\n";
}

# -----------------------------------------------------------------------------
411

412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427
# The BIFF formats leave us with a msole:codepage property
my $drop_codepage_filter =
    "$PERL -p -e '\$_ = \"\" if m{<meta:user-defined meta:name=.msole:codepage.}'";

my $drop_generator_filter =
    "$PERL -p -e '\$_ = \"\" if m{<meta:generator>}'";

# BIFF7 doesn't store cell comment author
my $no_author_filter = "$PERL -p -e 's{ Author=\"[^\"]*\"}{};'";

# BIFF7 cannot store rich text comments
my $no_rich_comment_filter = "$PERL -p -e 'if (/gnm:CellComment/) { s{ TextFormat=\"[^\"]*\"}{}; }'";

# Excel cannot have superscript and subscript at the same time
my $supersub_filter = "$PERL -p -e 's{\\[superscript=1:(\\d+):(\\d+)\\]\\[subscript=1:(\\d+):\\2\\]}{[superscript=1:\$1:\$3][subscript=1:\$3:\$2]};'";

428
my $noframe_filter = "$PERL -p -e '\$_ = \"\" if m{<gnm:SheetWidgetFrame .*/>}'";
429

430 431
my $noasindex_filter = "$PERL -p -e 'if (/gnm:SheetWidget(List|Combo)/) { s{( OutputAsIndex=)\"\\d+\"}{\$1\"0\"}; }'";

432 433 434 435
sub normalize_filter {
    my ($f) = @_;
    return 'cat' unless defined $f;

436 437 438 439 440 441
    $f =~ s/\bstd:drop_codepage\b/$drop_codepage_filter/;
    $f =~ s/\bstd:drop_generator\b/$drop_generator_filter/;
    $f =~ s/\bstd:no_author\b/$no_author_filter/;
    $f =~ s/\bstd:no_rich_comment\b/$no_rich_comment_filter/;
    $f =~ s/\bstd:supersub\b/$supersub_filter/;
    $f =~ s/\bstd:noframewidget\b/$noframe_filter/;
442
    $f =~ s/\bstd:nocomboasindex\b/$noasindex_filter/;
443 444 445 446 447 448

    return $f;
}

# -----------------------------------------------------------------------------

449
sub test_roundtrip {
Morten Welinder's avatar
Morten Welinder committed
450
    my ($file,%named_args) = @_;
451 452 453

    &report_skip ("file $file does not exist") unless -r $file;

Morten Welinder's avatar
Morten Welinder committed
454 455 456
    my $format = $named_args{'format'};
    my $newext = $named_args{'ext'};
    my $resize = $named_args{'resize'};
457
    my $ignore_failure = $named_args{'ignore_failure'};
Morten Welinder's avatar
Morten Welinder committed
458

459
    my $filter0 = &normalize_filter ($named_args{'filter0'});
460 461 462 463
    my $filter1 = &normalize_filter ($named_args{'filter1'} ||
				     $named_args{'filter'});
    my $filter2 = &normalize_filter ($named_args{'filter2'} ||
				     $named_args{'filter'});
464

465 466 467 468 469 470
    my $tmp = fileparse ($file);
    $tmp =~ s/\.([a-zA-Z0-9]+)$// or die "Must have extension for roundtrip test.";
    my $ext = $1;
    my $code;
    my $keep = 0;

471 472
    my $file_resized = $file;
    if ($resize) {
473
	$file_resized =~ s{^.*/}{};
474
	$file_resized =~ s/(\.gnumeric)$/-resize$1/;
475
	unlink $file_resized;
476
	my $cmd = &quotearg ($ssconvert, "--resize", $resize, $file, $file_resized);
477 478
	print STDERR "# $cmd\n" if $verbose;
	$code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
479
	&system_failure ($ssconvert, $code) if $code;
480
	die "Failed to produce $file_resized\n" unless -r $file_resized;
481 482
	&junkfile ($file_resized) unless $keep;
    }
483 484 485 486 487 488 489 490 491 492 493 494 495

    my $file_filtered = $file_resized;
    if ($filter0) {
	$file_filtered =~ s{^.*/}{};
	$file_filtered =~ s/(\.gnumeric)$/-filter$1/;
	unlink $file_filtered;
	my $cmd = "zcat " . &quotearg ($file_resized) . " | $filter0 >" . &quotearg ($file_filtered);
	print STDERR "# $cmd\n" if $verbose;
	$code = system ("($cmd) 2>&1 | sed -e 's/^/| /'");
	&system_failure ($ssconvert, $code) if $code;
	die "Failed to produce $file_filtered\n" unless -r $file_filtered;
	&junkfile ($file_filtered) unless $keep;
    }
496
    
497
    my $tmp1 = "$tmp.$newext";
498
    unlink $tmp1;
499
    &junkfile ($tmp1) unless $keep;
500
    {
501
	my $cmd = &quotearg ($ssconvert, "-T", $format, $file_filtered, $tmp1);
502 503 504
	print "# $cmd\n" if $verbose;
	my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
	&system_failure ($ssconvert, $code) if $code;
505
	die "Failed to produce $tmp1\n" unless -r $tmp1;
506
    }
507 508

    my $tmp2 = "$tmp-new.$ext";
509
    unlink $tmp2;
510
    &junkfile ($tmp2) unless $keep;
511
    {
512
	my $cmd = &quotearg ($ssconvert, $tmp1, $tmp2);
513 514 515
	print "# $cmd\n" if $verbose;
	my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
	&system_failure ($ssconvert, $code) if $code;
516
	die "Failed to produce $tmp2\n" unless -r $tmp2;
517
    }
518 519

    my $tmp_xml = "$tmp.xml";
520
    unlink $tmp_xml;
521
    &junkfile ($tmp_xml) unless $keep;
522
    $code = system ("zcat -f '$file_filtered' | $normalize_gnumeric | $filter1 >'$tmp_xml'");
523 524 525
    &system_failure ('zcat', $code) if $code;

    my $tmp2_xml = "$tmp-new.xml";
526
    unlink $tmp2_xml;
527
    &junkfile ($tmp2_xml) unless $keep;
528 529
    # print STDERR "zcat -f '$tmp2' | $normalize_gnumeric | $filter2 >'$tmp2_xml'\n";
    $code = system ("zcat -f '$tmp2' | $normalize_gnumeric | $filter2 >'$tmp2_xml'");
530 531 532
    &system_failure ('zcat', $code) if $code;

    $code = system ('diff', '-u', $tmp_xml, $tmp2_xml);
533
    &system_failure ('diff', $code) if $code && !$ignore_failure;
534 535 536 537 538

    print STDERR "Pass\n";
}

# -----------------------------------------------------------------------------
539

Morten Welinder's avatar
Morten Welinder committed
540 541 542
sub test_valgrind {
    my ($cmd,$uselibtool) = @_;

543
    local (%ENV) = %ENV;
Morten Welinder's avatar
Morten Welinder committed
544
    $ENV{'G_DEBUG'} .= ':gc-friendly:resident-modules';
545 546 547 548 549 550 551 552
    $ENV{'G_SLICE'} = 'always-malloc';
    delete $ENV{'VALGRIND_OPTS'};

    my $outfile = 'valgrind.log';
    unlink $outfile;
    die "Cannot remove $outfile.\n" if -f $outfile;
    &junkfile ($outfile);

553
    my $valhelp = `valgrind --help 2>&1`;
554
    &report_skip ("Valgrind is not available") unless defined $valhelp;
555 556
    die "Problem running valgrind.\n" unless $valhelp =~ /log-file/;

557 558
    my $valvers = `valgrind --version`;
    die "Problem running valgrind.\n"
559
	unless $valvers =~ /^valgrind-(\d+)\.(\d+)\.(\d+)/;
560
    $valvers = $1 * 10000 + $2 * 100 + $3;
561
    &report_skip ("Valgrind is too old") unless $valvers >= 30500;
562

563
    $cmd = "--gen-suppressions=all $cmd";
564

565
    {
566
	my $suppfile = "$topsrc/test/common.supp";
567
	&report_skip ("file $suppfile does not exist") unless -r $suppfile;
568 569 570 571 572 573 574 575 576
	$cmd = "--suppressions=$suppfile $cmd" if -r $suppfile;
    }

    {
	my $suppfile = $0;
	$suppfile =~ s/\.pl$/.supp/;
	$cmd = "--suppressions=$suppfile $cmd" if -r $suppfile;
    }

Morten Welinder's avatar
Morten Welinder committed
577
    # $cmd = "--show-reachable=yes $cmd";
578
    $cmd = "--show-below-main=yes $cmd";
Morten Welinder's avatar
Morten Welinder committed
579 580
    $cmd = "--leak-check=full $cmd";
    $cmd = "--num-callers=20 $cmd";
581
    $cmd = "--track-fds=yes $cmd";
582 583 584 585 586
    if ($valhelp =~ /--log-file-exactly=/) {
	$cmd = "--log-file-exactly=$outfile $cmd";
    } else {
	$cmd = "--log-file=$outfile $cmd";
    }
Morten Welinder's avatar
Morten Welinder committed
587 588 589
    $cmd = "valgrind $cmd";
    $cmd = "../libtool --mode=execute $cmd" if $uselibtool;

Morten Welinder's avatar
Morten Welinder committed
590 591
    my $code = system ($cmd);
    &system_failure ('valgrind', $code) if $code;
592 593 594

    my $txt = &read_file ($outfile);
    &removejunk ($outfile);
Morten Welinder's avatar
Morten Welinder committed
595
    my $errors = ($txt =~ /ERROR\s+SUMMARY:\s*(\d+)\s+errors?/i)
596 597 598
	? $1
	: -1;
    if ($errors == 0) {
Morten Welinder's avatar
Morten Welinder committed
599
	# &dump_indented ($txt);
600 601 602 603 604 605
	print STDERR "Pass\n";
	return;
    }

    &dump_indented ($txt);
    die "Fail\n";
Morten Welinder's avatar
Morten Welinder committed
606 607
}

608 609 610 611 612
# -----------------------------------------------------------------------------

sub test_ssindex {
    my ($file,$test) = @_;

613 614
    &report_skip ("file $file does not exist") unless -r $file;

615 616 617 618 619 620 621
    my $xmlfile = fileparse ($file);
    $xmlfile =~ s/\.[a-zA-Z0-9]+$/.xml/;
    unlink $xmlfile;
    die "Cannot remove $xmlfile.\n" if -f $xmlfile;
    &junkfile ($xmlfile);

    {
622
	my $cmd = &quotearg ($ssindex, "--index", $file);
623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659
	my $output = `$cmd 2>&1 >'$xmlfile'`;
	my $err = $?;
	&dump_indented ($output);
	die "Failed command: $cmd\n" if $err;
    }

    my $parser = new XML::Parser ('Style' => 'Tree');
    my $tree = $parser->parsefile ($xmlfile);
    &removejunk ($xmlfile);

    my @items;

    die "$0: Invalid parse tree from ssindex.\n"
	unless (ref ($tree) eq 'ARRAY' && $tree->[0] eq "gnumeric");
    my @children = @{$tree->[1]};
    my $attrs = shift @children;

    while (@children) {
	my $tag = shift @children;
	my $content = shift @children;

	if ($tag eq '0') {
	    # A text node
	    goto FAIL unless $content =~ /^\s*$/;
	} elsif ($tag eq 'data') {
	    my @dchildren = @$content;
	    my $dattrs = shift @dchildren;
	    die "$0: Unexpected attributes in data tag\n" if keys %$dattrs;
	    die "$0: Unexpected data tag content.\n" if @dchildren != 2;
	    die "$0: Unexpected data tag content.\n" if $dchildren[0] ne '0';
	    my $data = $dchildren[1];
	    push @items, $data;
	} else {
	    die "$0: Unexpected tag \"$tag\".\n";
	}
    }

660
    local $_ = \@items;
661 662 663 664 665 666 667
    if (&$test ($_)) {
	print STDERR "Pass\n";
    } else {
	die "Fail\n";
    }
}

668 669
# -----------------------------------------------------------------------------

670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692
sub quotearg {
    return join (' ', map { &quotearg1 ($_) } @_);
}

sub quotearg1 {
    my ($arg) = @_;

    return "''" if $arg eq '';
    my $res = '';
    while ($arg ne '') {
	if ($arg =~ m!^([-=/._a-zA-Z0-9]+)!) {
	    $res .= $1;
	    $arg = substr ($arg, length $1);
	} else {
	    $res .= "\\" . substr ($arg, 0, 1);
	    $arg = substr ($arg, 1);
	}
    }
    return $res;
}

# -----------------------------------------------------------------------------

693 694 695 696 697 698 699 700
sub report_skip {
    my ($txt) = @_;

    print "SKIP -- $txt\n";
    # 77 is magic for automake
    exit 77;
}

Morten Welinder's avatar
Morten Welinder committed
701 702 703
# -----------------------------------------------------------------------------
# Setup a consistent environment

Morten Welinder's avatar
Morten Welinder committed
704 705
&report_skip ("all tests skipped") if exists $ENV{'GNUMERIC_SKIP_TESTS'};

706 707 708
delete $ENV{'G_SLICE'};
$ENV{'G_DEBUG'} = 'fatal_criticals';

Morten Welinder's avatar
Morten Welinder committed
709
delete $ENV{'LANG'};
710
delete $ENV{'LANGUAGE'};
Morten Welinder's avatar
Morten Welinder committed
711 712 713
foreach (keys %ENV) { delete $ENV{$_} if /^LC_/; }
$ENV{'LC_ALL'} = 'C';

714 715 716
# libgsf listens for this
delete $ENV{'WINDOWS_LANGUAGE'};

717 718 719 720 721 722 723 724 725 726 727
while (1) {
    if (@ARGV && $ARGV[0] eq '--verbose') {
	$verbose = 1;
	scalar shift @ARGV;
	next;
    } elsif (@ARGV > 1 && $ARGV[0] eq '--subtests') {
	scalar shift @ARGV;
	$subtests = shift @ARGV;
    } else {
	last;
    }
Morten Welinder's avatar
Morten Welinder committed
728 729
}

Morten Welinder's avatar
Morten Welinder committed
730
1;