This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence some diagnostic messages when running within the core tests.
[perl5.git] / lib / Archive / Tar / t / 02_methods.t
CommitLineData
39713df4
RGS
1BEGIN {
2 if( $ENV{PERL_CORE} ) {
3 chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
4 }
5 use lib '../../..';
6}
7
8BEGIN { chdir 't' if -d 't' }
9
10use Test::More 'no_plan';
11use strict;
12use lib '../lib';
13
14use Cwd;
b30bcf62 15use Config;
39713df4
RGS
16use IO::File;
17use File::Copy;
18use File::Path;
19use File::Spec ();
20use File::Spec::Unix ();
21use File::Basename ();
22use Data::Dumper;
23
24use Archive::Tar;
25use Archive::Tar::Constant;
26
27### XXX TODO:
28### * change to fullname
29### * add tests for global variables
30
31### set up the environment ###
32my @EXPECT_NORMAL = (
33 ### dirs filename contents
34 [ [], 'c', qr/^iiiiiiiiiiii\s*$/ ],
35 [ [], 'd', qr/^uuuuuuuu\s*$/ ],
36);
37
38### includes binary data
39my $ALL_CHARS = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";
40
41### @EXPECTBIN is used to ensure that $tarbin is written in the right
42### order and that the contents and order match exactly when extracted
43my @EXPECTBIN = (
44 ### dirs filename contents ###
45 [ [], 'bIn11', $ALL_CHARS x 11 ],
46 [ [], 'bIn3', $ALL_CHARS x 3 ],
47 [ [], 'bIn4', $ALL_CHARS x 4 ],
48 [ [], 'bIn1', $ALL_CHARS ],
49 [ [], 'bIn2', $ALL_CHARS x 2 ],
50);
51
52### @EXPECTX is used to ensure that $tarx is written in the right
53### order and that the contents and order match exactly when extracted
54### the 'x/x' extraction used to fail before A::T 1.08
55my @EXPECTX = (
56 ### dirs filename contents
57 [ [ 'x' ], 'k', '', ],
58 [ [ 'x' ], 'x', 'j', ], # failed before A::T 1.08
59);
60
61my $LONG_FILE = qq[directory/really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-long-directory-name/myfile];
62
63### wintendo can't deal with too long paths, so we might have to skip tests ###
81a5970e 64my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS')
39713df4
RGS
65 && length( cwd(). $LONG_FILE ) > 247;
66
67### warn if we are going to skip long file names
03998fa0
RGS
68if ($TOO_LONG) {
69 diag("No long filename support - long filename extraction disabled") if ! $ENV{PERL_CORE};
70} else {
71 push @EXPECT_NORMAL, [ [], $LONG_FILE, qr/^hello\s*$/];
72}
39713df4
RGS
73
74my @ROOT = grep { length } 'src', $TOO_LONG ? 'short' : 'long';
75
76my $ZLIB = eval { require IO::Zlib; 1 } ? 1 : 0;
77my $NO_UNLINK = $ARGV[0] ? 1 : 0;
78
79### enable debugging?
80$Archive::Tar::DEBUG = 1 if $ARGV[1];
81
82### tests for binary and x/x files
83my $TARBIN = Archive::Tar->new;
84my $TARX = Archive::Tar->new;
85
86### paths to a .tar and .tgz file to use for tests
87my $TAR_FILE = File::Spec->catfile( @ROOT, 'bar.tar' );
88my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' );
89my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' );
90my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' );
91
81a5970e
RGS
92my $COMPRESS_FILE = 'copy';
93$^O eq 'VMS' and $COMPRESS_FILE .= '.';
94copy( File::Basename::basename($0), $COMPRESS_FILE );
39713df4
RGS
95chmod 0644, $COMPRESS_FILE;
96
97### done setting up environment ###
98
99
100### did we probe IO::Zlib support ok? ###
101{ is( Archive::Tar->can_handle_compressed_files, $ZLIB,
102 "Proper IO::Zlib support detected" );
103}
104
105
106### tar error tests
107{ my $tar = Archive::Tar->new;
108
109 ok( $tar, "Object created" );
110 isa_ok( $tar, 'Archive::Tar');
111
112 local $Archive::Tar::WARN = 0;
113
114 ### should be empty to begin with
115 is( $tar->error, '', "The error string is empty" );
116
117 ### try a read on nothing
118 my @list = $tar->read();
119
120 ok(!(scalar @list), "Function read returns 0 files on error" );
121 ok( $tar->error, " error string is non empty" );
122 like( $tar->error, qr/No file to read from/,
123 " error string from create()" );
124 unlike( $tar->error, qr/add/, " error string does not contain add" );
125
126 ### now, add empty data
127 my $obj = $tar->add_data( '' );
128
129 ok( !$obj, "'add_data' returns undef on error" );
130 ok( $tar->error, " error string is non empty" );
131 like( $tar->error, qr/add/, " error string contains add" );
132 unlike( $tar->error, qr/create/," error string does not contain create" );
133
134 ### check if ->error eq $error
135 is( $tar->error, $Archive::Tar::error,
136 '$error matches error() method' );
137}
138
139### read tests ###
140{ ### normal tar + gz compressed file
141 my $archive = $TAR_FILE;
142 my $compressed = $TGZ_FILE;
143 my $tar = Archive::Tar->new;
144 my $gzip = 0;
145
146 ### check we got the object
147 ok( $tar, "Object created" );
148 isa_ok( $tar, 'Archive::Tar');
149
150 for my $type( $archive, $compressed ) {
151 my $state = $gzip ? 'compressed' : 'uncompressed';
152
153 SKIP: {
154
155 ### skip gz compressed archives wihtout IO::Zlib
156 skip( "No IO::Zlib - cannot read compressed archives",
157 4 + 2 * (scalar @EXPECT_NORMAL)
158 ) if( $gzip and !$ZLIB);
159
160 ### ->read test
161 { my @list = $tar->read( $type );
162 my $cnt = scalar @list;
163 my $expect = scalar __PACKAGE__->get_expect();
164
165 ok( $cnt, "Reading $state file using 'read()'" );
166 is( $cnt, $expect, " All files accounted for" );
167
168 for my $file ( @list ) {
169 ok( $file, "Got File object" );
170 isa_ok( $file, "Archive::Tar::File" );
171
b30bcf62
RGS
172 ### whitebox test -- make sure find_entry gets the
173 ### right files
174 for my $test ( $file->full_path, $file ) {
175 is( $tar->_find_entry( $test ), $file,
176 " Found proper object" );
177 }
178
39713df4
RGS
179 next unless $file->is_file;
180
181 my $name = $file->full_path;
182 my($expect_name, $expect_content) =
183 get_expect_name_and_contents( $name, \@EXPECT_NORMAL );
184
185 ### ->fullname!
186 ok($expect_name," Found expected file '$name'" );
187
188 like($tar->get_content($name), $expect_content,
189 " Content OK" );
190 }
191 }
192
193
194 ### list_archive test
195 { my @list = Archive::Tar->list_archive( $archive );
196 my $cnt = scalar @list;
197 my $expect = scalar __PACKAGE__->get_expect();
198
199 ok( $cnt, "Reading $state file using 'list_archive'");
200 is( $cnt, $expect, " All files accounted for" );
201
202 for my $file ( @list ) {
203 next if __PACKAGE__->is_dir( $file ); # directories
204
205 my($expect_name, $expect_content) =
206 get_expect_name_and_contents( $file, \@EXPECT_NORMAL );
207
208 ok( $expect_name,
209 " Found expected file '$file'" );
210 }
211 }
212 }
213
214 ### now we try gz compressed archives
215 $gzip++;
216 }
217}
218
219### add files tests ###
220{ my @add = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
221 my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
222 my $tar = Archive::Tar->new;
223
224 ### check we got the object
225 ok( $tar, "Object created" );
226 isa_ok( $tar, 'Archive::Tar');
227
228 ### add the files
229 { my @files = $tar->add_files( @add );
230
231 is( scalar @files, scalar @add,
232 "Adding files");
233 is( $files[0]->name, 'b', " Proper name" );
b3200c5d 234
b30bcf62
RGS
235 SKIP: {
236 skip( "You are building perl using symlinks", 1)
237 if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/);
b3200c5d 238
b3200c5d
SP
239 is( $files[0]->is_file, 1,
240 " Proper type" );
241 }
242
39713df4
RGS
243 like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/,
244 " Content OK" );
245
246 ### check if we have then in our tar object
247 for my $file ( @addunix ) {
248 ok( $tar->contains_file($file),
249 " File found in archive" );
250 }
251 }
252
253 ### check adding files doesn't conflict with a secondary archive
254 ### old A::T bug, we should keep testing for it
255 { my $tar2 = Archive::Tar->new;
256 my @added = $tar2->add_files( $COMPRESS_FILE );
257 my @count = $tar2->list_files;
258
259 is( scalar @added, 1, "Added files to secondary archive" );
260 is( scalar @added, scalar @count,
261 " Does not conflict with first archive" );
262
263 ### check the adding of directories
264 my @add_dirs = File::Spec->catfile( @ROOT );
265 my @dirs = $tar2->add_files( @add_dirs );
266 is( scalar @dirs, scalar @add_dirs,
267 "Adding dirs");
268 ok( $dirs[0]->is_dir, " Proper type" );
269 }
270}
271
272### add data tests ###
273{
274 { ### standard data ###
275 my @to_add = ( 'a', 'aaaaa' );
276 my $tar = Archive::Tar->new;
277
278 ### check we got the object
279 ok( $tar, "Object created" );
280 isa_ok( $tar, 'Archive::Tar');
281
282 ### add a new file item as data
283 my $obj = $tar->add_data( @to_add );
284
285 ok( $obj, "Adding data" );
286 is( $obj->name, $to_add[0], " Proper name" );
287 is( $obj->is_file, 1, " Proper type" );
288 like( $obj->get_content, qr/^$to_add[1]\s*$/,
289 " Content OK" );
290 }
291
292 { ### binary data +
293 ### dir/file structure -- x/y always went ok, x/x used to extract
294 ### in the wrong way -- this test catches that
295 for my $list ( [$TARBIN, \@EXPECTBIN],
296 [$TARX, \@EXPECTX],
297 ) {
298 ### XXX GLOBAL! changes may affect other tests!
299 my($tar,$struct) = @$list;
300
301 for my $aref ( @$struct ) {
302 my ($dirs,$file,$data) = @$aref;
303
304 my $path = File::Spec::Unix->catfile(
305 grep { length } @$dirs, $file );
306
307 my $obj = $tar->add_data( $path, $data );
308
309 ok( $obj, "Adding data '$file'" );
310 is( $obj->full_path, $path,
311 " Proper name" );
312 ok( $obj->is_file, " Proper type" );
313 is( $obj->get_content, $data,
314 " Content OK" );
315 }
316 }
317 }
318}
319
320### rename/replace_content tests ###
321{ my $tar = Archive::Tar->new;
322 my $from = 'c';
323 my $to = 'e';
324
325 ### read in the file, check the proper files are there
326 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
327 ok( $tar->get_files($from), " Found file '$from'" );
328 { local $Archive::Tar::WARN = 0;
329 ok(!$tar->get_files($to), " File '$to' not yet found" );
330 }
331
332 ### rename an entry, check the rename has happened
333 ok( $tar->rename( $from, $to ), " Renamed '$from' to '$to'" );
334 ok( $tar->get_files($to), " File '$to' now found" );
335 { local $Archive::Tar::WARN = 0;
336 ok(!$tar->get_files($from), " File '$from' no longer found'");
337 }
338
339 ### now, replace the content
340 my($expect_name, $expect_content) =
341 get_expect_name_and_contents( $from, \@EXPECT_NORMAL );
342
343 like( $tar->get_content($to), $expect_content,
344 "Original content of '$from' in '$to'" );
345 ok( $tar->replace_content( $to, $from ),
346 " Set content for '$to' to '$from'" );
347 is( $tar->get_content($to), $from,
348 " Content for '$to' is indeed '$from'" );
349}
350
351### remove tests ###
352{ my $remove = 'c';
353 my $tar = Archive::Tar->new;
354
355 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
356
357 ### remove returns the files left, which should be equal to list_files
358 is( scalar($tar->remove($remove)), scalar($tar->list_files),
359 "Removing file '$remove'" );
360
361 ### so what's left should be all expected files minus 1
362 is( scalar($tar->list_files), scalar(__PACKAGE__->get_expect) - 1,
363 " Proper files remaining" );
364}
365
366### write + read + extract tests ###
367SKIP: {
368 skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO &&
369 !$Archive::Tar::HAS_IO_STRING;
370
371 my $tar = Archive::Tar->new;
372 my $new = Archive::Tar->new;
373 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
374
375 for my $aref ( [$tar, \@EXPECT_NORMAL],
376 [$TARBIN, \@EXPECTBIN],
377 [$TARX, \@EXPECTX]
378 ) {
379 my($obj,$struct) = @$aref;
380
381 ### check if we stringify it ok
382 { my $string = $obj->write;
383 ok( $string, "Stringified tar file has size" );
384 cmp_ok( length($string) % BLOCK, '==', 0,
385 "Tar archive stringified" );
386 }
387
388 ### write tar tests
389 { my $out = $OUT_TAR_FILE;
390
391 { ### write()
392 ok( $obj->write($out),
393 "Wrote tarfile using 'write'" );
394 check_tar_file( $out );
395 check_tar_object( $obj, $struct );
396
397 ### now read it in again
398 ok( $new->read( $out ),
399 "Read '$out' in again" );
400
401 check_tar_object( $new, $struct );
402
403 ### now extract it again
404 ok( $new->extract, "Extracted '$out' with 'extract'" );
405 check_tar_extract( $new, $struct );
406
407 rm( $out ) unless $NO_UNLINK;
408 }
409
410
411 { ### create_archive()
412 ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
413 "Wrote tarfile using 'create_archive'" );
414 check_tar_file( $out );
415
416 ### now extract it again
417 ok( Archive::Tar->extract_archive( $out ),
418 "Extracted file using 'extract_archive'");
419 rm( $out ) unless $NO_UNLINK;
420 }
421 }
422
423 ## write tgz tests
424 { my $out = $OUT_TGZ_FILE;
425
426 SKIP: {
427
428 ### weird errors from scalar(@x,@y,@z), dot it this way...
429 my $file_cnt;
430 map { $file_cnt += scalar @$_ } \@EXPECT_NORMAL, \@EXPECTBIN,
431 \@EXPECTX;
432
433 my $cnt = 5 + # the tests below
434 (5*3*2) + # check_tgz_file
435 # check_tar_object fixed tests
436 (3 * 2 * (2 + $file_cnt)) +
437 ((4*$file_cnt) + 1);# check_tar_extract tests
438
439 skip( "No IO::Zlib - cannot write compressed archives", $cnt )
440 unless $ZLIB;
441
442 { ### write()
443 ok($obj->write($out, 1),
444 "Writing compressed file using 'write'" );
445 check_tgz_file( $out );
446 check_tar_object( $obj, $struct );
447
448 ### now read it in again
449 ok( $new->read( $out ),
450 "Read '$out' in again" );
451 check_tar_object( $new, $struct );
452
453 ### now extract it again
454 ok( $new->extract,
455 "Extracted '$out' again" );
456 check_tar_extract( $new, $struct );
457
458 rm( $out ) unless $NO_UNLINK;
459 }
460
461 { ### create_archive()
462 ok( Archive::Tar->create_archive( $out, 1, $COMPRESS_FILE ),
463 "Wrote gzip file using 'create_archive'" );
464 check_tgz_file( $out );
465
466 ### now extract it again
467 ok( Archive::Tar->extract_archive( $out, 1 ),
468 "Extracted file using 'extract_archive'");
469 rm( $out ) unless $NO_UNLINK;
470 }
471 }
472 }
473 }
474}
475
476
477### limited read + extract tests ###
478{ my $tar = Archive::Tar->new;
479 my @files = $tar->read( $TAR_FILE, 0, { limit => 1 } );
480 my $obj = $files[0];
481
482 is( scalar @files, 1, "Limited read" );
483
484 my ($name,$content) = get_expect_name_and_contents(
485 $obj->full_path, \@EXPECT_NORMAL );
486
487 is( $obj->name, $name, " Expected file found" );
488
b30bcf62 489
39713df4
RGS
490 ### extract this single file to cwd()
491 for my $meth (qw[extract extract_file]) {
b30bcf62
RGS
492
493 ### extract it by full path and object
494 for my $arg ( $obj, $obj->full_path ) {
495
496 ok( $tar->$meth( $arg ),
39713df4 497 "Extracted '$name' to cwd() with $meth" );
b30bcf62
RGS
498 ok( -e $obj->full_path, " Extracted file exists" );
499 rm( $obj->full_path ) unless $NO_UNLINK;
500 }
39713df4
RGS
501 }
502
503 ### extract this file to @ROOT
504 ### can only do that with 'extract_file', not with 'extract'
505 for my $meth (qw[extract_file]) {
506 my $outpath = File::Spec->catdir( @ROOT );
507 my $outfile = File::Spec->catfile( $outpath, $$ ); #$obj->full_path );
508
509 ok( $tar->$meth( $obj->full_path, $outfile ),
510 "Extracted file '$name' to $outpath with $meth" );
511 ok( -e $outfile, " Extracted file '$outfile' exists" );
512 rm( $outfile ) unless $NO_UNLINK;
513 }
514
515}
516
517
518### clear tests ###
519{ my $tar = Archive::Tar->new;
520 my @files = $tar->read( $TAR_FILE );
521
522 my $cnt = $tar->list_files();
523 ok( $cnt, "Found old data" );
524 ok( $tar->clear, " Clearing old data" );
525
526 my $new_cnt = $tar->list_files;
527 ok( !$new_cnt, " Old data cleared" );
528}
529
530### $DO_NOT_USE_PREFIX tests
531{ my $tar = Archive::Tar->new;
532
533
534 ### first write a tar file without prefix
535 { my ($obj) = $tar->add_files( $COMPRESS_FILE );
536 my $dir = ''; # dir is empty!
537 my $file = File::Basename::basename( $COMPRESS_FILE );
538
539 ok( $obj, "File added" );
540 isa_ok( $obj, "Archive::Tar::File" );
541
542 ### internal storage ###
543 is( $obj->name, $file, " Name set to '$file'" );
544 is( $obj->prefix, $dir, " Prefix set to '$dir'" );
545
546 ### write the tar file without a prefix in it
547 local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
548 ok( $tar->write( $OUT_TAR_FILE ),
549 " Tar file written" );
550
551 ### and forget all about it...
552 $tar->clear;
553 }
554
555 ### now read it back in, there should be no prefix
556 { ok( $tar->read( $OUT_TAR_FILE ),
557 "Tar file read in again" );
558
559 my ($obj) = $tar->get_files;
560 ok( $obj, " File retrieved" );
561 isa_ok( $obj, "Archive::Tar::File" );
562
563 is( $obj->name, $COMPRESS_FILE,
564 " Name now set to '$COMPRESS_FILE'" );
565 is( $obj->prefix, '', " Prefix now empty" );
566
567 my $re = quotemeta $COMPRESS_FILE;
568 like( $obj->raw, qr/^$re/, " Prefix + name in name slot of header" );
569 }
570
571 rm( $OUT_TAR_FILE ) unless $NO_UNLINK;
572}
573
574### clean up stuff
575END {
576 for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) {
577 for my $aref (@$struct) {
578
579 my $dir = $aref->[0]->[0];
580 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
581 }
582 }
583
584 my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE );
585 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
81a5970e 586 1 while unlink $COMPRESS_FILE;
39713df4
RGS
587}
588
589###########################
590### helper subs ###
591###########################
592sub get_expect {
593 return map {
594 split '/', $_
595 } map {
596 File::Spec::Unix->catfile(
597 grep { defined } @{$_->[0]}, $_->[1]
598 )
599 } @EXPECT_NORMAL;
600}
601
602sub is_dir {
603 my $file = pop();
604 return $file =~ m|/$| ? 1 : 0;
605}
606
607sub rm {
608 my $x = shift;
81a5970e
RGS
609 if ( is_dir($x) ) {
610 rmtree($x);
611 } else {
612 1 while unlink $x;
613 }
39713df4
RGS
614}
615
616sub check_tar_file {
617 my $file = shift;
618 my $filesize = -s $file;
619 my $contents = slurp_binfile( $file );
620
621 ok( defined( $contents ), " File read" );
622 ok( $filesize, " File written size=$filesize" );
623
624 cmp_ok( $filesize % BLOCK, '==', 0,
625 " File size is a multiple of 512" );
626
627 cmp_ok( length($contents), '==', $filesize,
628 " File contents match size" );
629
630 is( TAR_END x 2, substr( $contents, -(BLOCK*2) ),
631 " Ends with 1024 null bytes" );
632
633 return $contents;
634}
635
636sub check_tgz_file {
637 my $file = shift;
638 my $filesize = -s $file;
639 my $contents = slurp_gzfile( $file );
640 my $uncompressedsize = length $contents;
641
642 ok( defined( $contents ), " File read and uncompressed" );
643 ok( $filesize, " File written size=$filesize uncompressed size=$uncompressedsize" );
644
645 cmp_ok( $uncompressedsize % BLOCK, '==', 0,
646 " Uncompressed size is a multiple of 512" );
647
648 is( TAR_END x 2, substr($contents, -(BLOCK*2)),
649 " Ends with 1024 null bytes" );
650
651 cmp_ok( $filesize, '<', $uncompressedsize,
652 " Compressed size < uncompressed size" );
653
654 return $contents;
655}
656
657sub check_tar_object {
658 my $obj = shift;
659 my $struct = shift or return;
660
661 ### amount of files (not dirs!) there should be in the object
662 my $expect = scalar @$struct;
663 my @files = grep { $_->is_file } $obj->get_files;
664
665 ### count how many files there are in the object
666 ok( scalar @files, " Found some files in the archive" );
667 is( scalar @files, $expect, " Found expected number of files" );
668
669 for my $file (@files) {
670
671 ### XXX ->fullname
672 #my $path = File::Spec::Unix->catfile(
673 # grep { length } $file->prefix, $file->name );
674 my($ename,$econtent) =
675 get_expect_name_and_contents( $file->full_path, $struct );
676
677 ok( $file->is_file, " It is a file" );
678 is( $file->full_path, $ename,
679 " Name matches expected name" );
680 like( $file->get_content, $econtent,
681 " Content as expected" );
682 }
683}
684
685sub check_tar_extract {
686 my $tar = shift;
687 my $struct = shift;
688
689 my @dirs;
690 for my $file ($tar->get_files) {
691 push @dirs, $file && next if $file->is_dir;
692
693
694 my $path = $file->full_path;
695 my($ename,$econtent) =
696 get_expect_name_and_contents( $path, $struct );
697
698
699 is( $ename, $path, " Expected file found" );
700 ok( -e $path, " File '$path' exists" );
701
702 my $fh;
703 open $fh, "$path" or warn "Error opening file '$path': $!\n";
704 binmode $fh;
705
706 ok( $fh, " Opening file" );
707
708 my $content = do{local $/;<$fh>}; chomp $content;
709 like( $content, qr/$econtent/,
710 " Contents OK" );
711
d78ab5f9 712 close $fh;
81a5970e 713 $NO_UNLINK or 1 while unlink $path;
39713df4
RGS
714
715 ### alternate extract path tests
716 ### to abs and rel paths
717 { for my $outpath ( File::Spec->catdir( @ROOT ),
718 File::Spec->rel2abs(
719 File::Spec->catdir( @ROOT )
720 )
721 ) {
81a5970e
RGS
722
723 my $outfile = File::Spec->catfile( $outpath, $$ );
39713df4
RGS
724
725 ok( $tar->extract_file( $file->full_path, $outfile ),
726 " Extracted file '$path' to $outfile" );
727 ok( -e $outfile," Extracted file '$outfile' exists" );
728
729 rm( $outfile ) unless $NO_UNLINK;
730 }
731 }
732 }
733
734 ### now check if list_files is returning the same info as get_files
735 is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files],
736 " Verified via list_files as well" );
737
738 #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK }
739 # for @dirs;
740}
741
742sub slurp_binfile {
743 my $file = shift;
744 my $fh = IO::File->new;
745
746 $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef;
747
748 binmode $fh;
749 local $/;
750 return <$fh>;
751}
752
753sub slurp_gzfile {
754 my $file = shift;
755 my $str;
756 my $buff;
757
758 require IO::Zlib;
759 my $fh = new IO::Zlib;
760 $fh->open( $file, READ_ONLY->(1) )
761 or warn( "Error opening '$file' with IO::Zlib" ), return undef;
762
763 $str .= $buff while $fh->read( $buff, 4096 ) > 0;
764 $fh->close();
765 return $str;
766}
767
768sub get_expect_name_and_contents {
769 my $find = shift;
770 my $struct = shift or return;
771
772 ### find the proper name + contents for this file from
773 ### the expect structure
774 my ($name, $content) =
775 map {
776 @$_;
777 } grep {
778 $_->[0] eq $find
779 } map {
780 [ ### full path ###
781 File::Spec::Unix->catfile(
782 grep { length } @{$_->[0]}, $_->[1]
783 ),
784 ### regex
785 $_->[2],
786 ]
787 } @$struct;
788
789 ### not a qr// yet?
790 unless( ref $content ) {
791 my $x = quotemeta ($content || '');
792 $content = qr/$x/;
793 }
794
795 unless( $name ) {
796 warn "Could not find '$find' in " . Dumper $struct;
797 }
798
799 return ($name, $content);
800}
801
802__END__