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