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