test/GnumericTest.pm

   1 package GnumericTest;
   2 use strict;
   3 use Exporter;
   4 use File::Basename qw(fileparse);
   5 use Config;
   6 use XML::Parser;
   7
   8 $| = 1;
   9
  10 @GnumericTest::ISA = qw (Exporter);
  11 @GnumericTest::EXPORT = qw(test_sheet_calc test_valgrind
  12                            test_importer test_exporter test_roundtrip
  13                            test_csv_format_guessing
  14                            test_ssindex sstest test_command message subtest
  15                            test_tool
  16                            setup_python_environment
  17                            $ssconvert $sstest $ssdiff $ssgrep $gnumeric
  18                            $topsrc $top_builddir
  19                            $subtests $samples corpus $PERL $PYTHON);
  20 @GnumericTest::EXPORT_OK = qw(junkfile);
  21
  22 use vars qw($topsrc $top_builddir $samples $default_subtests $default_corpus $PERL $PYTHON $verbose);
  23 use vars qw($ssconvert $ssindex $sstest $ssdiff $ssgrep $gnumeric);
  24 use vars qw($normalize_gnumeric);
  25
  26 $PYTHON = undef;
  27
  28 $PERL = $Config{'perlpath'};
  29 $PERL .= $Config{'_exe'} if $^O ne 'VMS' && $PERL !~ m/$Config{'_exe'}$/i;
  30
  31 $topsrc = $0;
  32 $topsrc =~ s|/[^/]+$|/..|;
  33 $topsrc =~ s|/test/\.\.$||;
  34
  35 $top_builddir = "..";
  36 $samples = "$topsrc/samples"; $samples =~ s{^\./+}{};
  37 $ssconvert = "$top_builddir/src/ssconvert";
  38 $ssindex = "$top_builddir/src/ssindex";
  39 $sstest = "$top_builddir/src/sstest";
  40 $ssdiff = "$top_builddir/src/ssdiff";
  41 $ssgrep = "$top_builddir/src/ssgrep";
  42 $gnumeric = "$top_builddir/src/gnumeric";
  43 $normalize_gnumeric = "$PERL $topsrc/test/normalize-gnumeric";
  44 $verbose = 0;
  45 $default_subtests = '*';
  46 my $subtests = undef;
  47 $default_corpus = 'full';
  48 my $user_corpus = undef;
  49
  50 # -----------------------------------------------------------------------------
  51
  52 my @tempfiles;
  53 END {
  54     unlink @tempfiles;
  55 }
  56
  57 sub junkfile {
  58     my ($fn) = @_;
  59     push @tempfiles, $fn;
  60 }
  61
  62 sub removejunk {
  63     my ($fn) = @_;
  64     unlink $fn;
  65
  66     if (@tempfiles && $fn eq $tempfiles[-1]) {
  67         scalar (pop @tempfiles);
  68     }
  69 }
  70
  71 # -----------------------------------------------------------------------------
  72
  73 sub system_failure {
  74     my ($program,$code) = @_;
  75
  76     if ($code == -1) {
  77         die "failed to run $program: $!\n";
  78     } elsif ($code >> 8) {
  79         my $sig = $code >> 8;
  80         die "$program died due to signal $sig\n";
  81     } else {
  82         die "$program exited with exit code $code\n";
  83     }
  84 }
  85
  86 sub read_file {
  87     my ($fn) = @_;
  88
  89     local (*FIL);
  90     open (FIL, $fn) or die "Cannot open $fn: $!\n";
  91     local $/ = undef;
  92     my $lines = <FIL>;
  93     close FIL;
  94
  95     return $lines;
  96 }
  97
  98 sub write_file {
  99     my ($fn,$contents) = @_;
 100
 101     local (*FIL);
 102     open (FIL, ">$fn.tmp") or die "Cannot create $fn.tmp: $!\n";
 103     print FIL $contents;
 104     close FIL;
 105     rename "$fn.tmp", $fn;
 106 }
 107
 108 sub update_file {
 109     my ($fn,$contents) = @_;
 110
 111     my @stat = stat $fn;
 112     die "Cannot stat $fn: $!\n" unless @stat > 2;
 113
 114     &write_file ($fn,$contents);
 115
 116     chmod $stat[2], $fn or
 117         die "Cannot chmod $fn: $!\n";
 118 }
 119
 120 # Print a string with each line prefixed by "| ".
 121 sub dump_indented {
 122     my ($txt) = @_;
 123     return if $txt eq '';
 124     $txt =~ s/^/| /gm;
 125     $txt = "$txt\n" unless substr($txt, -1) eq "\n";
 126     print STDERR $txt;
 127 }
 128
 129 sub find_program {
 130     my ($p, $nofail) = @_;
 131
 132     if ($p =~ m{/}) {
 133         return $p if -x $p;
 134     } else {
 135         my $PATH = exists $ENV{'PATH'} ? $ENV{'PATH'} : '';
 136         foreach my $dir (split (':', $PATH)) {
 137             $dir = '.' if $dir eq '';
 138             my $tentative = "$dir/$p";
 139             return $tentative if -x $tentative;
 140         }
 141     }
 142
 143     return undef if $nofail;
 144
 145     &report_skip ("$p is missing");
 146 }
 147
 148 # -----------------------------------------------------------------------------
 149
 150 sub message {
 151     my ($message) = @_;
 152     print "-" x 79, "\n";
 153     my $me = $0;
 154     $me =~ s|^.*/||;
 155     foreach (split (/\n/, $message)) {
 156         print "$me: $_\n";
 157     }
 158 }
 159
 160 # -----------------------------------------------------------------------------
 161
 162 sub subtest {
 163     my ($q) = @_;
 164
 165     my $res = 0;
 166     foreach my $t (split (',', $subtests || $default_subtests)) {
 167         if ($t eq '*' || $t eq $q) {
 168             $res = 1;
 169             next;
 170         } elsif ($t eq '-*' || $t eq "-$q") {
 171             $res = 0;
 172             next;
 173         }
 174     }
 175     return $res;
 176 }
 177
 178 # -----------------------------------------------------------------------------
 179
 180 my @full_corpus =
 181     ("$samples/excel/address.xls",
 182      "$samples/excel/bitwise.xls",
 183      "$samples/excel/chart-tests-excel.xls",
 184      "$samples/excel/datefuns.xls",
 185      "$samples/excel/dbfuns.xls",
 186      "$samples/excel/engfuns.xls",
 187      "$samples/excel/finfuns.xls",
 188      "$samples/excel/functions.xls",
 189      "$samples/excel/infofuns.xls",
 190      "$samples/excel/logfuns.xls",
 191      "$samples/excel/lookfuns2.xls",
 192      "$samples/excel/lookfuns.xls",
 193      "$samples/excel/mathfuns.xls",
 194      "$samples/excel/objs.xls",
 195      "$samples/excel/operator.xls",
 196      "$samples/excel/sort.xls",
 197      "$samples/excel/statfuns.xls",
 198      "$samples/excel/textfuns.xls",
 199      "$samples/excel/yalta2008.xls",
 200      "$samples/excel12/cellstyle.xlsx",
 201      "$samples/excel12/database.xlsx",
 202      "$samples/excel12/ifs-funcs.xlsx",
 203      "$samples/excel12/countif.xlsx",
 204      "$samples/crlibm.gnumeric",
 205      "$samples/amath.gnumeric",
 206      "$samples/gamma.gnumeric",
 207      "$samples/linest.xls",
 208      "$samples/vba-725220.xls",
 209      "$samples/sumif.xls",
 210      "$samples/array-intersection.xls",
 211      "$samples/arrays.xls",
 212      "$samples/docs-samples.gnumeric",
 213      "$samples/ftest.xls",
 214      "$samples/ttest.xls",
 215      "$samples/chitest.xls",
 216      "$samples/vdb.gnumeric",
 217      "$samples/numbermatch.gnumeric",
 218      "$samples/numtheory.gnumeric",
 219      "$samples/solver/afiro.mps",
 220      "$samples/solver/blend.mps",
 221      "$samples/auto-filter-tests.gnumeric",
 222      "$samples/cell-comment-tests.gnumeric",
 223      "$samples/colrow-tests.gnumeric",
 224      "$samples/cond-format-tests.gnumeric",
 225      "$samples/format-tests.gnumeric",
 226      "$samples/formula-tests.gnumeric",
 227      "$samples/graph-tests.gnumeric",
 228      "$samples/hlink-tests.gnumeric",
 229      "$samples/merge-tests.gnumeric",
 230      "$samples/names-tests.gnumeric",
 231      "$samples/number-tests.gnumeric",
 232      "$samples/object-tests.gnumeric",
 233      "$samples/page-setup-tests.gnumeric",
 234      "$samples/rich-text-tests.gnumeric",
 235      "$samples/sheet-formatting-tests.gnumeric",
 236      "$samples/sheet-names-tests.gnumeric",
 237      "$samples/sheet-tab-tests.gnumeric",
 238      "$samples/solver-tests.gnumeric",
 239      "$samples/split-panes-tests.gnumeric",
 240      "$samples/string-tests.gnumeric",
 241      "$samples/merge-tests.gnumeric",
 242      "$samples/selection-tests.gnumeric",
 243      "$samples/style-tests.gnumeric",
 244      "$samples/validation-tests.gnumeric",
 245     );
 246
 247 sub corpus {
 248     my ($c) = @_;
 249
 250     my $corpus = ($c || $user_corpus || $default_corpus);
 251     if ($corpus eq 'full') {
 252         return @full_corpus;
 253     } elsif ($corpus =~ /^random:(\d+)$/) {
 254         my $n = $1;
 255         my @corpus = grep { -r $_; } @full_corpus;
 256         while ($n < @corpus) {
 257             my $i = int (rand() * @corpus);
 258             splice @corpus, $i, 1;
 259         }
 260         return @corpus;
 261     } elsif ($corpus =~ m{^/(.*)/$}) {
 262         my $rx = $1;
 263         my @corpus = grep { /$rx/ } @full_corpus;
 264         return @corpus;
 265     } else {
 266         die "Invalid corpus specification\n";
 267     }
 268 }
 269
 270 # -----------------------------------------------------------------------------
 271
 272 sub test_command {
 273     my ($cmd,$test) = @_;
 274
 275     print STDERR "# $cmd\n" if $verbose;
 276     my $output = `$cmd 2>&1`;
 277     my $err = $?;
 278     die "Failed command: $cmd\n" if $err;
 279
 280     &dump_indented ($output);
 281     local $_ = $output;
 282     if (&$test ($output)) {
 283         print STDERR "Pass\n";
 284     } else {
 285         die "Fail\n";
 286     }
 287 }
 288
 289 # -----------------------------------------------------------------------------
 290
 291 sub sstest {
 292     my $test = shift @_;
 293     my $expected = shift @_;
 294
 295     my $cmd = &quotearg ($sstest, $test);
 296     my $actual = `$cmd 2>&1`;
 297     my $err = $?;
 298     die "Failed command: $cmd\n" if $err;
 299
 300     my $ok;
 301     if (ref $expected) {
 302         local $_ = $actual;
 303         $ok = &$expected ($_);
 304         if (!$ok) {
 305             foreach (split ("\n", $actual)) {
 306                 print "| $_\n";
 307             }
 308         }
 309     } else {
 310         my @actual = split ("\n", $actual);
 311         chomp @actual;
 312         while (@actual > 0 && $actual[-1] eq '') {
 313             my $dummy = pop @actual;
 314         }
 315
 316         my @expected = split ("\n", $expected);
 317         chomp @expected;
 318         while (@expected > 0 && $expected[-1] eq '') {
 319             my $dummy = pop @expected;
 320         }
 321
 322         my $i = 0;
 323         while ($i < @actual && $i < @expected) {
 324             last if $actual[$i] ne $expected[$i];
 325             $i++;
 326         }
 327         if ($i < @actual || $i < @expected) {
 328             $ok = 0;
 329             print STDERR "Differences between actual and expected on line ", ($i + 1), ":\n";
 330             print STDERR "Actual  : ", ($i < @actual ? $actual[$i] : "-"), "\n";
 331             print STDERR "Expected: ", ($i < @expected ? $expected[$i] : "-"), "\n";
 332         } else {
 333             $ok = 1;
 334         }
 335     }
 336
 337     if ($ok) {
 338         print STDERR "Pass\n";
 339     } else {
 340         die "Fail.\n\n";
 341     }
 342 }
 343
 344 # -----------------------------------------------------------------------------
 345
 346 sub test_sheet_calc {
 347     my $file = shift @_;
 348     my $pargs = (ref $_[0]) ? shift @_ : [];
 349     my ($range,$expected) = @_;
 350
 351     &report_skip ("file $file does not exist") unless -r $file;
 352
 353     my $tmp = fileparse ($file);
 354     $tmp =~ s/\.[a-zA-Z0-9]+$/.csv/;
 355     &junkfile ($tmp);
 356
 357     my $cmd = "$ssconvert " . &quotearg (@$pargs, '--recalc', "--export-range=$range", $file, $tmp);
 358     print STDERR "# $cmd\n" if $verbose;
 359     my $code = system ("$cmd 2>&1 | sed -e 's/^/| /' ");
 360     &system_failure ($ssconvert, $code) if $code;
 361
 362     my $actual = &read_file ($tmp);
 363
 364     my $ok;
 365     if (ref $expected) {
 366         local $_ = $actual;
 367         $ok = &$expected ($_);
 368     } else {
 369         $ok = ($actual eq $expected);
 370     }
 371
 372     &removejunk ($tmp);
 373
 374     if ($ok) {
 375         print STDERR "Pass\n";
 376     } else {
 377         $actual =~ s/\s+$//;
 378         &dump_indented ($actual);
 379         die "Fail.\n\n";
 380     }
 381 }
 382
 383 # -----------------------------------------------------------------------------
 384
 385 my $import_db = 'import-db';
 386
 387 # Modes:
 388 #   check: check that conversion produces right file
 389 #   create-db: save the current corresponding .gnumeric
 390 #   diff: diff conversion against saved .gnumeric
 391 #   update-SHA-1: update $0 to show current SHA-1  [validate first!]
 392
 393 sub test_importer {
 394     my ($file,$sha1,$mode) = @_;
 395
 396     my $tmp = fileparse ($file);
 397     ($tmp =~ s/\.[a-zA-Z0-9]+$/.gnumeric/ ) or ($tmp .= '.gnumeric');
 398     if ($mode eq 'create-db') {
 399         -d $import_db or mkdir ($import_db, 0777) or
 400             die "Cannot create $import_db: $!\n";
 401         $tmp = "$import_db/$tmp";
 402     } else {
 403         &junkfile ($tmp);
 404     }
 405
 406     &report_skip ("file $file does not exist") unless -r $file;
 407
 408     my $code = system ("$ssconvert '$file' '$tmp' 2>&1 | sed -e 's/^/| /'");
 409     &system_failure ($ssconvert, $code) if $code;
 410
 411     my $htxt = `zcat -f '$tmp' | $normalize_gnumeric | sha1sum`;
 412     my $newsha1 = lc substr ($htxt, 0, 40);
 413     die "SHA-1 failure\n" unless $newsha1 =~ /^[0-9a-f]{40}$/;
 414
 415     if ($mode eq 'check') {
 416         if ($sha1 ne $newsha1) {
 417             die "New SHA-1 is $newsha1; expected was $sha1\n";
 418         }
 419         print STDERR "Pass\n";
 420     } elsif ($mode eq 'create-db') {
 421         if ($sha1 ne $newsha1) {
 422             warn ("New SHA-1 is $newsha1; expected was $sha1\n");
 423         }
 424         # No file to remove
 425         return;
 426     } elsif ($mode eq 'diff') {
 427         my $saved = "$import_db/$tmp";
 428         die "$saved not found\n" unless -r $saved;
 429
 430         my $tmp1 = "$tmp-old";
 431         &junkfile ($tmp1);
 432         my $code1 = system ("zcat -f '$saved' >'$tmp1'");
 433         &system_failure ('zcat', $code1) if $code1;
 434
 435         my $tmp2 = "$tmp-new";
 436         &junkfile ($tmp2);
 437         my $code2 = system ("zcat -f '$tmp' >'$tmp2'");
 438         &system_failure ('zcat', $code2) if $code2;
 439
 440         my $code3 = system ('diff', @ARGV, $tmp1, $tmp2);
 441
 442         &removejunk ($tmp2);
 443         &removejunk ($tmp1);
 444     } elsif ($mode =~ /^update-(sha|SHA)-?1/) {
 445         if ($sha1 ne $newsha1) {
 446             my $script = &read_file ($0);
 447             my $count = ($script =~ s/\b$sha1\b/$newsha1/g);
 448             die "SHA-1 found in script $count times\n" unless $count == 1;
 449             &update_file ($0, $script);
 450         }
 451         return;
 452     } else {
 453         die "Invalid mode \"$mode\"\n";
 454     }
 455
 456     &removejunk ($tmp);
 457 }
 458
 459 # -----------------------------------------------------------------------------
 460
 461 sub test_exporter {
 462     my ($file,$ext) = @_;
 463
 464     &report_skip ("file $file does not exist") unless -r $file;
 465
 466     my $tmp = fileparse ($file);
 467     $tmp =~ s/\.([a-zA-Z0-9]+)$//;
 468     $ext = $1 unless defined $ext;
 469     $ext or die "Must have extension for export test.";
 470     my $code;
 471     my $keep = 0;
 472
 473     my $tmp1 = "$tmp.gnumeric";
 474     &junkfile ($tmp1) unless $keep;
 475     {
 476         my $cmd = &quotearg ($ssconvert, $file, $tmp1);
 477         print STDERR "# $cmd\n" if $verbose;
 478         my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
 479         &system_failure ($ssconvert, $code) if $code;
 480     }
 481
 482     my $tmp2 = "$tmp-new.$ext";
 483     &junkfile ($tmp2) unless $keep;
 484     {
 485         my $cmd = &quotearg ($ssconvert, $file, $tmp2);
 486         print STDERR "# $cmd\n" if $verbose;
 487         my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
 488         &system_failure ($ssconvert, $code) if $code;
 489     }
 490
 491     my $tmp3 = "$tmp-new.gnumeric";
 492     &junkfile ($tmp3) unless $keep;
 493     {
 494         my $cmd = &quotearg ($ssconvert, $tmp2, $tmp3);
 495         print STDERR "# $cmd\n" if $verbose;
 496         my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
 497         &system_failure ($ssconvert, $code) if $code;
 498     }
 499
 500     my $tmp4 = "$tmp.xml";
 501     &junkfile ($tmp4) unless $keep;
 502     $code = system (&quotearg ("zcat", "-f", $tmp1) . "| $normalize_gnumeric >" . &quotearg ($tmp4));
 503     &system_failure ('zcat', $code) if $code;
 504
 505     my $tmp5 = "$tmp-new.xml";
 506     &junkfile ($tmp5) unless $keep;
 507     $code = system (&quotearg ("zcat" , "-f", $tmp3) . " | $normalize_gnumeric >" . &quotearg ($tmp5));
 508     &system_failure ('zcat', $code) if $code;
 509
 510     $code = system ('diff', '-u', $tmp4, $tmp5);
 511     &system_failure ('diff', $code) if $code;
 512
 513     print STDERR "Pass\n";
 514 }
 515
 516 # -----------------------------------------------------------------------------
 517
 518 sub test_csv_format_guessing {
 519     my (%args) = @_;
 520     my $data = $args{'data'};
 521
 522     my $keep = 0;
 523
 524     my $datafn = "test-data.csv";
 525     &junkfile ($datafn) unless $keep;
 526     &write_file ($datafn, $data);
 527
 528     my $outfn = "test-data.gnumeric";
 529     &junkfile ($outfn) unless $keep;
 530
 531     local $ENV{'GNM_DEBUG'} = 'stf';
 532     my $cmd = &quotearg ($ssconvert, $datafn, $outfn);
 533     print STDERR "# $cmd\n" if $verbose;
 534     my $out = `$cmd 2>&1`;
 535
 536     if ($out !~ m/^\s*fmt\.0\s*=\s*(\S+)\s*$/m) {
 537         die "Failed to guess any format\n";
 538     }
 539     my $guessed = $1;
 540
 541     my $ok;
 542     {
 543         local $_ = $guessed;
 544         $ok = &{$args{'format'}} ($_);
 545     }
 546
 547     if ($verbose || !$ok) {
 548         print STDERR "Data:\n";
 549         foreach (split ("\n", $data)) {
 550             print STDERR "| $_\n";
 551         }
 552         print STDERR "Result:\n";
 553         foreach (split ("\n", $out)) {
 554             print STDERR "| $_\n";
 555         }
 556     }
 557
 558     die "Guessed wrong format: $guessed\n" unless $ok;
 559
 560     if (exists $args{'decimal'}) {
 561         if ($out !~ m/^\s*fmt\.0\.dec\s*=\s*(\S+)\s*$/m) {
 562             die "Failed to guess any decimal separator\n";
 563         }
 564         my $guessed = $1;
 565         my $ok = ($1 eq $args{'decimal'});
 566
 567         die "Guessed wrong decimal separator: $guessed\n" unless $ok;
 568     }
 569
 570     if (exists $args{'thousand'}) {
 571         if ($out !~ m/^\s*fmt\.0\.thou\s*=\s*(\S+)\s*$/m) {
 572             die "Failed to guess any thousands separator\n";
 573         }
 574         my $guessed = $1;
 575         my $ok = ($1 eq $args{'thousand'});
 576
 577         die "Guessed wrong thousands separator: $guessed\n" unless $ok;
 578     }
 579
 580     &removejunk ($outfn) unless $keep;
 581     &removejunk ($datafn) unless $keep;
 582 }
 583
 584 # -----------------------------------------------------------------------------
 585
 586 # The BIFF formats leave us with a msole:codepage property
 587 my $drop_codepage_filter =
 588     "$PERL -p -e '\$_ = \"\" if m{<meta:user-defined meta:name=.msole:codepage.}'";
 589
 590 my $drop_generator_filter =
 591     "$PERL -p -e '\$_ = \"\" if m{<meta:generator>}'";
 592
 593 # BIFF7 doesn't store cell comment author
 594 my $no_author_filter = "$PERL -p -e 's{ Author=\"[^\"]*\"}{};'";
 595
 596 # BIFF7 cannot store rich text comments
 597 my $no_rich_comment_filter = "$PERL -p -e 'if (/gnm:CellComment/) { s{ TextFormat=\"[^\"]*\"}{}; }'";
 598
 599 # Excel cannot have superscript and subscript at the same time
 600 my $supersub_filter = "$PERL -p -e 's{\\[superscript=1:(\\d+):(\\d+)\\]\\[subscript=1:(\\d+):\\2\\]}{[superscript=1:\$1:\$3][subscript=1:\$3:\$2]};'";
 601
 602 my $noframe_filter = "$PERL -p -e '\$_ = \"\" if m{<gnm:SheetWidgetFrame .*/>}'";
 603
 604 my $noasindex_filter = "$PERL -p -e 'if (/gnm:SheetWidget(List|Combo)/) { s{( OutputAsIndex=)\"\\d+\"}{\$1\"0\"}; }'";
 605
 606 sub normalize_filter {
 607     my ($f) = @_;
 608     return 'cat' unless defined $f;
 609
 610     $f =~ s/\bstd:drop_codepage\b/$drop_codepage_filter/;
 611     $f =~ s/\bstd:drop_generator\b/$drop_generator_filter/;
 612     $f =~ s/\bstd:no_author\b/$no_author_filter/;
 613     $f =~ s/\bstd:no_rich_comment\b/$no_rich_comment_filter/;
 614     $f =~ s/\bstd:supersub\b/$supersub_filter/;
 615     $f =~ s/\bstd:noframewidget\b/$noframe_filter/;
 616     $f =~ s/\bstd:nocomboasindex\b/$noasindex_filter/;
 617
 618     return $f;
 619 }
 620
 621 # -----------------------------------------------------------------------------
 622
 623 sub test_roundtrip {
 624     my ($file,%named_args) = @_;
 625
 626     &report_skip ("file $file does not exist") unless -r $file;
 627
 628     my $format = $named_args{'format'};
 629     my $newext = $named_args{'ext'};
 630     my $resize = $named_args{'resize'};
 631     my $ignore_failure = $named_args{'ignore_failure'};
 632
 633     my $filter0 = &normalize_filter ($named_args{'filter0'});
 634     my $filter1 = &normalize_filter ($named_args{'filter1'} ||
 635                                      $named_args{'filter'});
 636     my $filter2 = &normalize_filter ($named_args{'filter2'} ||
 637                                      $named_args{'filter'});
 638
 639     my $tmp = fileparse ($file);
 640     $tmp =~ s/\.([a-zA-Z0-9]+)$// or die "Must have extension for roundtrip test.";
 641     my $ext = $1;
 642     my $code;
 643     my $keep = 0;
 644
 645     my $file_resized = $file;
 646     if ($resize) {
 647         $file_resized =~ s{^.*/}{};
 648         $file_resized =~ s/(\.gnumeric)$/-resize$1/;
 649         unlink $file_resized;
 650         my $cmd = &quotearg ($ssconvert, "--resize", $resize, $file, $file_resized);
 651         print STDERR "# $cmd\n" if $verbose;
 652         $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
 653         &system_failure ($ssconvert, $code) if $code;
 654         die "Failed to produce $file_resized\n" unless -r $file_resized;
 655         &junkfile ($file_resized) unless $keep;
 656     }
 657
 658     my $file_filtered = $file_resized;
 659     if ($filter0) {
 660         $file_filtered =~ s{^.*/}{};
 661         $file_filtered =~ s/(\.gnumeric)$/-filter$1/;
 662         unlink $file_filtered;
 663         my $cmd = "zcat " . &quotearg ($file_resized) . " | $filter0 >" . &quotearg ($file_filtered);
 664         print STDERR "# $cmd\n" if $verbose;
 665         $code = system ("($cmd) 2>&1 | sed -e 's/^/| /'");
 666         &system_failure ($ssconvert, $code) if $code;
 667         die "Failed to produce $file_filtered\n" unless -r $file_filtered;
 668         &junkfile ($file_filtered) unless $keep;
 669     }
 670
 671     my $tmp1 = "$tmp.$newext";
 672     unlink $tmp1;
 673     &junkfile ($tmp1) unless $keep;
 674     {
 675         my $cmd = &quotearg ($ssconvert, "-T", $format, $file_filtered, $tmp1);
 676         print "# $cmd\n" if $verbose;
 677         my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
 678         &system_failure ($ssconvert, $code) if $code;
 679         die "Failed to produce $tmp1\n" unless -r $tmp1;
 680     }
 681
 682     my $tmp2 = "$tmp-new.$ext";
 683     unlink $tmp2;
 684     &junkfile ($tmp2) unless $keep;
 685     {
 686         my $cmd = &quotearg ($ssconvert, $tmp1, $tmp2);
 687         print "# $cmd\n" if $verbose;
 688         my $code = system ("$cmd 2>&1 | sed -e 's/^/| /'");
 689         &system_failure ($ssconvert, $code) if $code;
 690         die "Failed to produce $tmp2\n" unless -r $tmp2;
 691     }
 692
 693     my $tmp_xml = "$tmp.xml";
 694     unlink $tmp_xml;
 695     &junkfile ($tmp_xml) unless $keep;
 696     $code = system ("zcat -f '$file_filtered' | $normalize_gnumeric | $filter1 >'$tmp_xml'");
 697     &system_failure ('zcat', $code) if $code;
 698
 699     my $tmp2_xml = "$tmp-new.xml";
 700     unlink $tmp2_xml;
 701     &junkfile ($tmp2_xml) unless $keep;
 702     # print STDERR "zcat -f '$tmp2' | $normalize_gnumeric | $filter2 >'$tmp2_xml'\n";
 703     $code = system ("zcat -f '$tmp2' | $normalize_gnumeric | $filter2 >'$tmp2_xml'");
 704     &system_failure ('zcat', $code) if $code;
 705
 706     $code = system ('diff', '-u', $tmp_xml, $tmp2_xml);
 707     &system_failure ('diff', $code) if $code && !$ignore_failure;
 708
 709     print STDERR "Pass\n";
 710 }
 711
 712 # -----------------------------------------------------------------------------
 713
 714 sub test_valgrind {
 715     my ($cmd,$uselibtool,$qreturn) = @_;
 716
 717     local (%ENV) = %ENV;
 718     $ENV{'G_DEBUG'} .= ':gc-friendly:resident-modules';
 719     $ENV{'G_SLICE'} = 'always-malloc';
 720     delete $ENV{'VALGRIND_OPTS'};
 721
 722     my $outfile = 'valgrind.log';
 723     unlink $outfile;
 724     die "Cannot remove $outfile.\n" if -f $outfile;
 725     &junkfile ($outfile);
 726
 727     my $valhelp = `valgrind --help 2>&1`;
 728     &report_skip ("Valgrind is not available") unless defined $valhelp;
 729     die "Problem running valgrind.\n" unless $valhelp =~ /log-file/;
 730
 731     my $valvers = `valgrind --version`;
 732     die "Problem running valgrind.\n"
 733         unless $valvers =~ /^valgrind-(\d+)\.(\d+)\.(\d+)/;
 734     $valvers = $1 * 10000 + $2 * 100 + $3;
 735     &report_skip ("Valgrind is too old") unless $valvers >= 30500;
 736
 737     $cmd = "--gen-suppressions=all $cmd";
 738
 739     {
 740         my $suppfile = "$topsrc/test/common.supp";
 741         &report_skip ("file $suppfile does not exist") unless -r $suppfile;
 742         $cmd = "--suppressions=$suppfile $cmd" if -r $suppfile;
 743     }
 744
 745     {
 746         my $suppfile = $0;
 747         $suppfile =~ s/\.pl$/.supp/;
 748         $cmd = "--suppressions=$suppfile $cmd" if -r $suppfile;
 749     }
 750
 751     # $cmd = "--show-reachable=yes $cmd";
 752     $cmd = "--show-below-main=yes $cmd";
 753     $cmd = "--leak-check=full $cmd";
 754     $cmd = "--num-callers=20 $cmd";
 755     $cmd = "--track-fds=yes $cmd";
 756     if ($valhelp =~ /--log-file-exactly=/) {
 757         $cmd = "--log-file-exactly=$outfile $cmd";
 758     } else {
 759         $cmd = "--log-file=$outfile $cmd";
 760     }
 761     $cmd = "valgrind $cmd";
 762     $cmd = "../libtool --mode=execute $cmd" if $uselibtool;
 763
 764     my $code = system ($cmd);
 765     &system_failure ('valgrind', $code) if $code;
 766
 767     my $txt = &read_file ($outfile);
 768     &removejunk ($outfile);
 769     my $errors = ($txt =~ /ERROR\s+SUMMARY:\s*(\d+)\s+errors?/i)
 770         ? $1
 771         : -1;
 772     if ($errors == 0) {
 773         # &dump_indented ($txt);
 774         print STDERR "Pass\n" unless $qreturn;
 775         return 0;
 776     }
 777
 778     &dump_indented ($txt);
 779     die "Fail\n" unless $qreturn;
 780     return 1;
 781 }
 782
 783 # -----------------------------------------------------------------------------
 784
 785 sub test_ssindex {
 786     my ($file,$test) = @_;
 787
 788     &report_skip ("file $file does not exist") unless -r $file;
 789
 790     my $xmlfile = fileparse ($file);
 791     $xmlfile =~ s/\.[a-zA-Z0-9]+$/.xml/;
 792     unlink $xmlfile;
 793     die "Cannot remove $xmlfile.\n" if -f $xmlfile;
 794     &junkfile ($xmlfile);
 795
 796     {
 797         my $cmd = &quotearg ($ssindex, "--index", $file);
 798         my $output = `$cmd 2>&1 >'$xmlfile'`;
 799         my $err = $?;
 800         &dump_indented ($output);
 801         die "Failed command: $cmd\n" if $err;
 802     }
 803
 804     my $parser = new XML::Parser ('Style' => 'Tree');
 805     my $tree = $parser->parsefile ($xmlfile);
 806     &removejunk ($xmlfile);
 807
 808     my @items;
 809
 810     die "$0: Invalid parse tree from ssindex.\n"
 811         unless (ref ($tree) eq 'ARRAY' && $tree->[0] eq "gnumeric");
 812     my @children = @{$tree->[1]};
 813     my $attrs = shift @children;
 814
 815     while (@children) {
 816         my $tag = shift @children;
 817         my $content = shift @children;
 818
 819         if ($tag eq '0') {
 820             # A text node
 821             goto FAIL unless $content =~ /^\s*$/;
 822         } elsif ($tag eq 'data') {
 823             my @dchildren = @$content;
 824             my $dattrs = shift @dchildren;
 825             die "$0: Unexpected attributes in data tag\n" if keys %$dattrs;
 826             die "$0: Unexpected data tag content.\n" if @dchildren != 2;
 827             die "$0: Unexpected data tag content.\n" if $dchildren[0] ne '0';
 828             my $data = $dchildren[1];
 829             push @items, $data;
 830         } else {
 831             die "$0: Unexpected tag \"$tag\".\n";
 832         }
 833     }
 834
 835     local $_ = \@items;
 836     if (&$test ($_)) {
 837         print STDERR "Pass\n";
 838     } else {
 839       FAIL:
 840         die "Fail\n";
 841     }
 842 }
 843
 844 # -----------------------------------------------------------------------------
 845
 846 sub test_tool {
 847     my ($file,$tool,$tool_args,$range,$test) = @_;
 848
 849     &report_skip ("file $file does not exist") unless -r $file;
 850
 851     my @args;
 852     push @args, "--export-range=$range" if defined $range;
 853     push @args, "--tool-test=$tool";
 854     for (my $i = 0; $i + 1 < @$tool_args; $i += 2) {
 855         my $k = $tool_args->[$i];
 856         my $v = $tool_args->[$i + 1];
 857         push @args, "--tool-test=$k:$v";
 858     }
 859
 860     my $tmp = "tool.csv";
 861     &junkfile ($tmp);
 862
 863     my $cmd = &quotearg ($ssconvert, @args, $file, $tmp);
 864     print STDERR "# $cmd\n" if $GnumericTest::verbose;
 865     my $code = system ($cmd);
 866     &system_failure ($ssconvert, $code) if $code;
 867     my $actual = &read_file ($tmp);
 868
 869     &removejunk ($tmp);
 870
 871     if (&$test ($actual)) {
 872         print STDERR "Pass\n";
 873     } else {
 874         &GnumericTest::dump_indented ($actual);
 875         die "Fail\n";
 876     }
 877 }
 878
 879 # -----------------------------------------------------------------------------
 880
 881 sub has_linear_solver {
 882     return (defined (&find_program ('lp_solve', 1)) ||
 883             defined (&find_program ('glpsol', 1)));
 884 }
 885
 886 # -----------------------------------------------------------------------------
 887
 888 sub setup_python_environment {
 889     $PYTHON = `grep '^#define PYTHON_INTERPRETER ' $top_builddir/gnumeric-config.h 2>&1`;
 890     chomp $PYTHON;
 891     $PYTHON =~ s/^[^"]*"(.*)"\s*$/$1/;
 892     &report_skip ("Missing python interpreter") unless -x $PYTHON;
 893
 894     # Make sure we load introspection preferentially from build directory
 895     my $v = 'GI_TYPELIB_PATH';
 896     my $dir = "$top_builddir/src";
 897     $ENV{$v} = ($ENV{$v} || '') eq '' ? $dir : $dir . ':' . $ENV{$v};
 898
 899     # Ditto for shared libraries
 900     $v = 'LD_LIBRARY_PATH';
 901     $dir = "$top_builddir/src/.libs";
 902     $ENV{$v} = ($ENV{$v} || '') eq '' ? $dir : $dir . ':' . $ENV{$v};
 903 }
 904
 905 # -----------------------------------------------------------------------------
 906
 907 sub quotearg {
 908     return join (' ', map { &quotearg1 ($_) } @_);
 909 }
 910
 911 sub quotearg1 {
 912     my ($arg) = @_;
 913
 914     return "''" if $arg eq '';
 915     my $res = '';
 916     while ($arg ne '') {
 917         if ($arg =~ m!^([-=/._a-zA-Z0-9:]+)!) {
 918             $res .= $1;
 919             $arg = substr ($arg, length $1);
 920         } else {
 921             $res .= "\\" . substr ($arg, 0, 1);
 922             $arg = substr ($arg, 1);
 923         }
 924     }
 925     return $res;
 926 }
 927
 928 # -----------------------------------------------------------------------------
 929
 930 sub report_skip {
 931     my ($txt) = @_;
 932
 933     print "SKIP -- $txt\n";
 934     # 77 is magic for automake
 935     exit 77;
 936 }
 937
 938 # -----------------------------------------------------------------------------
 939 # Setup a consistent environment
 940
 941 &report_skip ("all tests skipped") if exists $ENV{'GNUMERIC_SKIP_TESTS'};
 942
 943 delete $ENV{'G_SLICE'};
 944 $ENV{'G_DEBUG'} = 'fatal_criticals';
 945
 946 delete $ENV{'LANG'};
 947 delete $ENV{'LANGUAGE'};
 948 foreach (keys %ENV) { delete $ENV{$_} if /^LC_/; }
 949 $ENV{'LC_ALL'} = 'C';
 950
 951 # libgsf listens for this
 952 delete $ENV{'WINDOWS_LANGUAGE'};
 953
 954 my $seed = time();
 955
 956 while (1) {
 957     if (@ARGV && $ARGV[0] eq '--verbose') {
 958         $verbose = 1;
 959         scalar shift @ARGV;
 960         next;
 961     } elsif (@ARGV > 1 && $ARGV[0] eq '--subtests') {
 962         scalar shift @ARGV;
 963         $subtests = shift @ARGV;
 964     } elsif (@ARGV > 1 && $ARGV[0] eq '--corpus') {
 965         scalar shift @ARGV;
 966         $user_corpus = shift @ARGV;
 967     } else {
 968         last;
 969     }
 970 }
 971
 972 srand ($seed);
 973
 974 1;