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 { &quotearg1 ($_) } @_);
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 = &quotearg ($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 = &quotearg (@$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 = &quotearg ('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 = &quotearg (@$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 = &quotearg ($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