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