projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Update Archive::Tar to 1.31
[p5sagit/p5-mst-13.2.git] / lib / Archive / Tar / t / 02_methods.t
CommitLineData
39713df4 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 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 65 && length( cwd(). $LONG_FILE ) > 247;
66
67### warn if we are going to skip long file names
03998fa0 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 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 92my $COMPRESS_FILE = 'copy';
93$^O eq 'VMS' and $COMPRESS_FILE .= '.';
94copy( File::Basename::basename($0), $COMPRESS_FILE );
39713df4 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' );
c3745331 137
138 ### check that 'contains_file' doesn't warn about missing files.
139 { ### turn on warnings in general!
140 local $Archive::Tar::WARN = 1;
141
142 my $warnings = '';
143 local $SIG{__WARN__} = sub { $warnings .= "@_" };
144
145 my $rv = $tar->contains_file( $$ );
146 ok( !$rv, "Does not contain file '$$'" );
147 is( $warnings, '', " No warnings issued during lookup" );
148 }
39713df4 149}
150
151### read tests ###
152{ ### normal tar + gz compressed file
153 my $archive = $TAR_FILE;
154 my $compressed = $TGZ_FILE;
155 my $tar = Archive::Tar->new;
156 my $gzip = 0;
157
158 ### check we got the object
159 ok( $tar, "Object created" );
160 isa_ok( $tar, 'Archive::Tar');
161
162 for my $type( $archive, $compressed ) {
163 my $state = $gzip ? 'compressed' : 'uncompressed';
164
165 SKIP: {
166
167 ### skip gz compressed archives wihtout IO::Zlib
168 skip( "No IO::Zlib - cannot read compressed archives",
169 4 + 2 * (scalar @EXPECT_NORMAL)
170 ) if( $gzip and !$ZLIB);
171
172 ### ->read test
173 { my @list = $tar->read( $type );
174 my $cnt = scalar @list;
175 my $expect = scalar __PACKAGE__->get_expect();
176
177 ok( $cnt, "Reading $state file using 'read()'" );
178 is( $cnt, $expect, " All files accounted for" );
179
180 for my $file ( @list ) {
181 ok( $file, "Got File object" );
182 isa_ok( $file, "Archive::Tar::File" );
183
b30bcf62 184 ### whitebox test -- make sure find_entry gets the
185 ### right files
186 for my $test ( $file->full_path, $file ) {
187 is( $tar->_find_entry( $test ), $file,
188 " Found proper object" );
189 }
190
39713df4 191 next unless $file->is_file;
192
193 my $name = $file->full_path;
194 my($expect_name, $expect_content) =
195 get_expect_name_and_contents( $name, \@EXPECT_NORMAL );
196
197 ### ->fullname!
198 ok($expect_name," Found expected file '$name'" );
199
200 like($tar->get_content($name), $expect_content,
201 " Content OK" );
202 }
203 }
204
205
206 ### list_archive test
207 { my @list = Archive::Tar->list_archive( $archive );
208 my $cnt = scalar @list;
209 my $expect = scalar __PACKAGE__->get_expect();
210
211 ok( $cnt, "Reading $state file using 'list_archive'");
212 is( $cnt, $expect, " All files accounted for" );
213
214 for my $file ( @list ) {
215 next if __PACKAGE__->is_dir( $file ); # directories
216
217 my($expect_name, $expect_content) =
218 get_expect_name_and_contents( $file, \@EXPECT_NORMAL );
219
220 ok( $expect_name,
221 " Found expected file '$file'" );
222 }
223 }
224 }
225
226 ### now we try gz compressed archives
227 $gzip++;
228 }
229}
230
231### add files tests ###
232{ my @add = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
233 my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
234 my $tar = Archive::Tar->new;
235
236 ### check we got the object
237 ok( $tar, "Object created" );
238 isa_ok( $tar, 'Archive::Tar');
239
240 ### add the files
241 { my @files = $tar->add_files( @add );
242
243 is( scalar @files, scalar @add,
244 "Adding files");
245 is( $files[0]->name, 'b', " Proper name" );
b3200c5d 246
b30bcf62 247 SKIP: {
248 skip( "You are building perl using symlinks", 1)
249 if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/);
b3200c5d 250
b3200c5d 251 is( $files[0]->is_file, 1,
252 " Proper type" );
253 }
254
39713df4 255 like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/,
256 " Content OK" );
257
258 ### check if we have then in our tar object
259 for my $file ( @addunix ) {
260 ok( $tar->contains_file($file),
261 " File found in archive" );
262 }
263 }
264
265 ### check adding files doesn't conflict with a secondary archive
266 ### old A::T bug, we should keep testing for it
267 { my $tar2 = Archive::Tar->new;
268 my @added = $tar2->add_files( $COMPRESS_FILE );
269 my @count = $tar2->list_files;
270
271 is( scalar @added, 1, "Added files to secondary archive" );
272 is( scalar @added, scalar @count,
273 " Does not conflict with first archive" );
274
275 ### check the adding of directories
276 my @add_dirs = File::Spec->catfile( @ROOT );
277 my @dirs = $tar2->add_files( @add_dirs );
278 is( scalar @dirs, scalar @add_dirs,
279 "Adding dirs");
280 ok( $dirs[0]->is_dir, " Proper type" );
281 }
282}
283
284### add data tests ###
285{
286 { ### standard data ###
287 my @to_add = ( 'a', 'aaaaa' );
288 my $tar = Archive::Tar->new;
289
290 ### check we got the object
291 ok( $tar, "Object created" );
292 isa_ok( $tar, 'Archive::Tar');
293
294 ### add a new file item as data
295 my $obj = $tar->add_data( @to_add );
296
297 ok( $obj, "Adding data" );
298 is( $obj->name, $to_add[0], " Proper name" );
299 is( $obj->is_file, 1, " Proper type" );
300 like( $obj->get_content, qr/^$to_add[1]\s*$/,
301 " Content OK" );
302 }
303
304 { ### binary data +
305 ### dir/file structure -- x/y always went ok, x/x used to extract
306 ### in the wrong way -- this test catches that
307 for my $list ( [$TARBIN, \@EXPECTBIN],
308 [$TARX, \@EXPECTX],
309 ) {
310 ### XXX GLOBAL! changes may affect other tests!
311 my($tar,$struct) = @$list;
312
313 for my $aref ( @$struct ) {
314 my ($dirs,$file,$data) = @$aref;
315
316 my $path = File::Spec::Unix->catfile(
317 grep { length } @$dirs, $file );
318
319 my $obj = $tar->add_data( $path, $data );
320
321 ok( $obj, "Adding data '$file'" );
322 is( $obj->full_path, $path,
323 " Proper name" );
324 ok( $obj->is_file, " Proper type" );
325 is( $obj->get_content, $data,
326 " Content OK" );
327 }
328 }
329 }
330}
331
332### rename/replace_content tests ###
333{ my $tar = Archive::Tar->new;
334 my $from = 'c';
335 my $to = 'e';
336
337 ### read in the file, check the proper files are there
338 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
339 ok( $tar->get_files($from), " Found file '$from'" );
340 { local $Archive::Tar::WARN = 0;
341 ok(!$tar->get_files($to), " File '$to' not yet found" );
342 }
343
344 ### rename an entry, check the rename has happened
345 ok( $tar->rename( $from, $to ), " Renamed '$from' to '$to'" );
346 ok( $tar->get_files($to), " File '$to' now found" );
347 { local $Archive::Tar::WARN = 0;
348 ok(!$tar->get_files($from), " File '$from' no longer found'");
349 }
350
351 ### now, replace the content
352 my($expect_name, $expect_content) =
353 get_expect_name_and_contents( $from, \@EXPECT_NORMAL );
354
355 like( $tar->get_content($to), $expect_content,
356 "Original content of '$from' in '$to'" );
357 ok( $tar->replace_content( $to, $from ),
358 " Set content for '$to' to '$from'" );
359 is( $tar->get_content($to), $from,
360 " Content for '$to' is indeed '$from'" );
361}
362
363### remove tests ###
364{ my $remove = 'c';
365 my $tar = Archive::Tar->new;
366
367 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
368
369 ### remove returns the files left, which should be equal to list_files
370 is( scalar($tar->remove($remove)), scalar($tar->list_files),
371 "Removing file '$remove'" );
372
373 ### so what's left should be all expected files minus 1
374 is( scalar($tar->list_files), scalar(__PACKAGE__->get_expect) - 1,
375 " Proper files remaining" );
376}
377
378### write + read + extract tests ###
379SKIP: {
380 skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO &&
381 !$Archive::Tar::HAS_IO_STRING;
382
383 my $tar = Archive::Tar->new;
384 my $new = Archive::Tar->new;
385 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
386
387 for my $aref ( [$tar, \@EXPECT_NORMAL],
388 [$TARBIN, \@EXPECTBIN],
389 [$TARX, \@EXPECTX]
390 ) {
391 my($obj,$struct) = @$aref;
392
393 ### check if we stringify it ok
394 { my $string = $obj->write;
395 ok( $string, "Stringified tar file has size" );
396 cmp_ok( length($string) % BLOCK, '==', 0,
397 "Tar archive stringified" );
398 }
399
400 ### write tar tests
401 { my $out = $OUT_TAR_FILE;
402
403 { ### write()
404 ok( $obj->write($out),
405 "Wrote tarfile using 'write'" );
406 check_tar_file( $out );
407 check_tar_object( $obj, $struct );
408
409 ### now read it in again
410 ok( $new->read( $out ),
411 "Read '$out' in again" );
412
413 check_tar_object( $new, $struct );
414
415 ### now extract it again
416 ok( $new->extract, "Extracted '$out' with 'extract'" );
417 check_tar_extract( $new, $struct );
418
419 rm( $out ) unless $NO_UNLINK;
420 }
421
422
423 { ### create_archive()
424 ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
425 "Wrote tarfile using 'create_archive'" );
426 check_tar_file( $out );
427
428 ### now extract it again
429 ok( Archive::Tar->extract_archive( $out ),
430 "Extracted file using 'extract_archive'");
431 rm( $out ) unless $NO_UNLINK;
432 }
433 }
434
435 ## write tgz tests
436 { my $out = $OUT_TGZ_FILE;
437
438 SKIP: {
439
440 ### weird errors from scalar(@x,@y,@z), dot it this way...
441 my $file_cnt;
442 map { $file_cnt += scalar @$_ } \@EXPECT_NORMAL, \@EXPECTBIN,
443 \@EXPECTX;
444
445 my $cnt = 5 + # the tests below
446 (5*3*2) + # check_tgz_file
447 # check_tar_object fixed tests
448 (3 * 2 * (2 + $file_cnt)) +
449 ((4*$file_cnt) + 1);# check_tar_extract tests
450
451 skip( "No IO::Zlib - cannot write compressed archives", $cnt )
452 unless $ZLIB;
453
454 { ### write()
455 ok($obj->write($out, 1),
456 "Writing compressed file using 'write'" );
457 check_tgz_file( $out );
458 check_tar_object( $obj, $struct );
459
460 ### now read it in again
461 ok( $new->read( $out ),
462 "Read '$out' in again" );
463 check_tar_object( $new, $struct );
464
465 ### now extract it again
466 ok( $new->extract,
467 "Extracted '$out' again" );
468 check_tar_extract( $new, $struct );
469
470 rm( $out ) unless $NO_UNLINK;
471 }
472
473 { ### create_archive()
474 ok( Archive::Tar->create_archive( $out, 1, $COMPRESS_FILE ),
475 "Wrote gzip file using 'create_archive'" );
476 check_tgz_file( $out );
477
478 ### now extract it again
479 ok( Archive::Tar->extract_archive( $out, 1 ),
480 "Extracted file using 'extract_archive'");
481 rm( $out ) unless $NO_UNLINK;
482 }
483 }
484 }
485 }
486}
487
488
489### limited read + extract tests ###
490{ my $tar = Archive::Tar->new;
491 my @files = $tar->read( $TAR_FILE, 0, { limit => 1 } );
492 my $obj = $files[0];
493
494 is( scalar @files, 1, "Limited read" );
495
496 my ($name,$content) = get_expect_name_and_contents(
497 $obj->full_path, \@EXPECT_NORMAL );
498
499 is( $obj->name, $name, " Expected file found" );
500
b30bcf62 501
39713df4 502 ### extract this single file to cwd()
503 for my $meth (qw[extract extract_file]) {
b30bcf62 504
505 ### extract it by full path and object
506 for my $arg ( $obj, $obj->full_path ) {
507
508 ok( $tar->$meth( $arg ),
39713df4 509 "Extracted '$name' to cwd() with $meth" );
b30bcf62 510 ok( -e $obj->full_path, " Extracted file exists" );
511 rm( $obj->full_path ) unless $NO_UNLINK;
512 }
39713df4 513 }
514
515 ### extract this file to @ROOT
516 ### can only do that with 'extract_file', not with 'extract'
517 for my $meth (qw[extract_file]) {
518 my $outpath = File::Spec->catdir( @ROOT );
519 my $outfile = File::Spec->catfile( $outpath, $$ ); #$obj->full_path );
520
521 ok( $tar->$meth( $obj->full_path, $outfile ),
522 "Extracted file '$name' to $outpath with $meth" );
523 ok( -e $outfile, " Extracted file '$outfile' exists" );
524 rm( $outfile ) unless $NO_UNLINK;
525 }
526
527}
528
529
530### clear tests ###
531{ my $tar = Archive::Tar->new;
532 my @files = $tar->read( $TAR_FILE );
533
534 my $cnt = $tar->list_files();
535 ok( $cnt, "Found old data" );
536 ok( $tar->clear, " Clearing old data" );
537
538 my $new_cnt = $tar->list_files;
539 ok( !$new_cnt, " Old data cleared" );
540}
541
542### $DO_NOT_USE_PREFIX tests
543{ my $tar = Archive::Tar->new;
544
545
546 ### first write a tar file without prefix
547 { my ($obj) = $tar->add_files( $COMPRESS_FILE );
548 my $dir = ''; # dir is empty!
549 my $file = File::Basename::basename( $COMPRESS_FILE );
550
551 ok( $obj, "File added" );
552 isa_ok( $obj, "Archive::Tar::File" );
553
554 ### internal storage ###
555 is( $obj->name, $file, " Name set to '$file'" );
556 is( $obj->prefix, $dir, " Prefix set to '$dir'" );
557
558 ### write the tar file without a prefix in it
559 local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
560 ok( $tar->write( $OUT_TAR_FILE ),
561 " Tar file written" );
562
563 ### and forget all about it...
564 $tar->clear;
565 }
566
567 ### now read it back in, there should be no prefix
568 { ok( $tar->read( $OUT_TAR_FILE ),
569 "Tar file read in again" );
570
571 my ($obj) = $tar->get_files;
572 ok( $obj, " File retrieved" );
573 isa_ok( $obj, "Archive::Tar::File" );
574
575 is( $obj->name, $COMPRESS_FILE,
576 " Name now set to '$COMPRESS_FILE'" );
577 is( $obj->prefix, '', " Prefix now empty" );
578
579 my $re = quotemeta $COMPRESS_FILE;
580 like( $obj->raw, qr/^$re/, " Prefix + name in name slot of header" );
581 }
582
583 rm( $OUT_TAR_FILE ) unless $NO_UNLINK;
584}
585
586### clean up stuff
587END {
588 for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) {
589 for my $aref (@$struct) {
590
591 my $dir = $aref->[0]->[0];
592 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
593 }
594 }
595
596 my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE );
597 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
81a5970e 598 1 while unlink $COMPRESS_FILE;
39713df4 599}
600
601###########################
602### helper subs ###
603###########################
604sub get_expect {
605 return map {
606 split '/', $_
607 } map {
608 File::Spec::Unix->catfile(
609 grep { defined } @{$_->[0]}, $_->[1]
610 )
611 } @EXPECT_NORMAL;
612}
613
614sub is_dir {
615 my $file = pop();
616 return $file =~ m|/$| ? 1 : 0;
617}
618
619sub rm {
620 my $x = shift;
81a5970e 621 if ( is_dir($x) ) {
622 rmtree($x);
623 } else {
624 1 while unlink $x;
625 }
39713df4 626}
627
628sub check_tar_file {
629 my $file = shift;
630 my $filesize = -s $file;
631 my $contents = slurp_binfile( $file );
632
633 ok( defined( $contents ), " File read" );
634 ok( $filesize, " File written size=$filesize" );
635
636 cmp_ok( $filesize % BLOCK, '==', 0,
637 " File size is a multiple of 512" );
638
639 cmp_ok( length($contents), '==', $filesize,
640 " File contents match size" );
641
642 is( TAR_END x 2, substr( $contents, -(BLOCK*2) ),
643 " Ends with 1024 null bytes" );
644
645 return $contents;
646}
647
648sub check_tgz_file {
649 my $file = shift;
650 my $filesize = -s $file;
651 my $contents = slurp_gzfile( $file );
652 my $uncompressedsize = length $contents;
653
654 ok( defined( $contents ), " File read and uncompressed" );
655 ok( $filesize, " File written size=$filesize uncompressed size=$uncompressedsize" );
656
657 cmp_ok( $uncompressedsize % BLOCK, '==', 0,
658 " Uncompressed size is a multiple of 512" );
659
660 is( TAR_END x 2, substr($contents, -(BLOCK*2)),
661 " Ends with 1024 null bytes" );
662
663 cmp_ok( $filesize, '<', $uncompressedsize,
664 " Compressed size < uncompressed size" );
665
666 return $contents;
667}
668
669sub check_tar_object {
670 my $obj = shift;
671 my $struct = shift or return;
672
673 ### amount of files (not dirs!) there should be in the object
674 my $expect = scalar @$struct;
675 my @files = grep { $_->is_file } $obj->get_files;
676
677 ### count how many files there are in the object
678 ok( scalar @files, " Found some files in the archive" );
679 is( scalar @files, $expect, " Found expected number of files" );
680
681 for my $file (@files) {
682
683 ### XXX ->fullname
684 #my $path = File::Spec::Unix->catfile(
685 # grep { length } $file->prefix, $file->name );
686 my($ename,$econtent) =
687 get_expect_name_and_contents( $file->full_path, $struct );
688
689 ok( $file->is_file, " It is a file" );
690 is( $file->full_path, $ename,
691 " Name matches expected name" );
692 like( $file->get_content, $econtent,
693 " Content as expected" );
694 }
695}
696
697sub check_tar_extract {
698 my $tar = shift;
699 my $struct = shift;
700
701 my @dirs;
702 for my $file ($tar->get_files) {
703 push @dirs, $file && next if $file->is_dir;
704
705
706 my $path = $file->full_path;
707 my($ename,$econtent) =
708 get_expect_name_and_contents( $path, $struct );
709
710
711 is( $ename, $path, " Expected file found" );
712 ok( -e $path, " File '$path' exists" );
713
714 my $fh;
715 open $fh, "$path" or warn "Error opening file '$path': $!\n";
716 binmode $fh;
717
718 ok( $fh, " Opening file" );
719
720 my $content = do{local $/;<$fh>}; chomp $content;
721 like( $content, qr/$econtent/,
722 " Contents OK" );
723
d78ab5f9 724 close $fh;
81a5970e 725 $NO_UNLINK or 1 while unlink $path;
39713df4 726
727 ### alternate extract path tests
728 ### to abs and rel paths
729 { for my $outpath ( File::Spec->catdir( @ROOT ),
730 File::Spec->rel2abs(
731 File::Spec->catdir( @ROOT )
732 )
733 ) {
81a5970e 734
735 my $outfile = File::Spec->catfile( $outpath, $$ );
39713df4 736
737 ok( $tar->extract_file( $file->full_path, $outfile ),
738 " Extracted file '$path' to $outfile" );
739 ok( -e $outfile," Extracted file '$outfile' exists" );
740
741 rm( $outfile ) unless $NO_UNLINK;
742 }
743 }
744 }
745
746 ### now check if list_files is returning the same info as get_files
747 is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files],
748 " Verified via list_files as well" );
749
750 #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK }
751 # for @dirs;
752}
753
754sub slurp_binfile {
755 my $file = shift;
756 my $fh = IO::File->new;
757
758 $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef;
759
760 binmode $fh;
761 local $/;
762 return <$fh>;
763}
764
765sub slurp_gzfile {
766 my $file = shift;
767 my $str;
768 my $buff;
769
770 require IO::Zlib;
771 my $fh = new IO::Zlib;
772 $fh->open( $file, READ_ONLY->(1) )
773 or warn( "Error opening '$file' with IO::Zlib" ), return undef;
774
775 $str .= $buff while $fh->read( $buff, 4096 ) > 0;
776 $fh->close();
777 return $str;
778}
779
780sub get_expect_name_and_contents {
781 my $find = shift;
782 my $struct = shift or return;
783
784 ### find the proper name + contents for this file from
785 ### the expect structure
786 my ($name, $content) =
787 map {
788 @$_;
789 } grep {
790 $_->[0] eq $find
791 } map {
792 [ ### full path ###
793 File::Spec::Unix->catfile(
794 grep { length } @{$_->[0]}, $_->[1]
795 ),
796 ### regex
797 $_->[2],
798 ]
799 } @$struct;
800
801 ### not a qr// yet?
802 unless( ref $content ) {
803 my $x = quotemeta ($content || '');
804 $content = qr/$x/;
805 }
806
807 unless( $name ) {
808 warn "Could not find '$find' in " . Dumper $struct;
809 }
810
811 return ($name, $content);
812}
813
814__END__
Unnamed repository; edit this file to name it for gitweb.