File Coverage

blib/lib/Archive/SevenZip.pm
Criterion Covered Total %
statement 113 292 38.7
branch 25 122 20.4
condition 5 29 17.2
subroutine 24 36 66.6
pod 11 20 55.0
total 178 499 35.6


line stmt bran cond sub pod time code
1             package Archive::SevenZip;
2 13     13   94531 use strict;
  13         80  
  13         375  
3 13     13   67 use warnings;
  13         27  
  13         374  
4 13     13   64 use Carp qw(croak);
  13         26  
  13         1056  
5 13     13   6068 use Encode qw( decode encode );
  13         116626  
  13         1035  
6 13     13   99 use File::Basename qw(dirname basename);
  13         31  
  13         1453  
7 13     13   5431 use Archive::SevenZip::Entry;
  13         54  
  13         523  
8 13     13   91 use File::Temp qw(tempfile tempdir);
  13         28  
  13         1007  
9 13     13   94 use File::Copy;
  13         29  
  13         674  
10 13     13   6817 use IPC::Open3 'open3';
  13         37437  
  13         787  
11 13     13   105 use Path::Class;
  13         30  
  13         643  
12 13     13   77 use Exporter 'import'; # for the error codes, in Archive::Zip API compatibility
  13         28  
  13         568  
13              
14             =head1 NAME
15              
16             Archive::SevenZip - Read/write 7z , zip , ISO9960 and other archives
17              
18             =head1 SYNOPSIS
19              
20             my $ar = Archive::SevenZip->new(
21             find => 1,
22             archivename => $archivename,
23             verbose => $verbose,
24             );
25              
26             for my $entry ( $ar->list ) {
27             my $target = join "/", "$target_dir", $entry->basename;
28             $ar->extractMember( $entry->fileName, $target );
29             };
30              
31             =head1 METHODS
32              
33             =cut
34              
35             our $VERSION= '0.19';
36              
37             # Archive::Zip API
38             # Error codes
39 13     13   78 use constant AZ_OK => 0;
  13         35  
  13         754  
40              
41 13     13   84 use constant COMPRESSION_STORED => 'Store'; # file is stored (no compression)
  13         36  
  13         581  
42 13     13   190 use constant COMPRESSION_DEFLATED => 'Deflate'; # file is Deflated
  13         74  
  13         21583  
43              
44             our @EXPORT_OK = (qw(AZ_OK COMPRESSION_STORED COMPRESSION_DEFLATED));
45             our %EXPORT_TAGS = (
46             ERROR_CODES => [
47             qw(
48             AZ_OK
49             )
50             #AZ_STREAM_END
51             #AZ_ERROR
52             #AZ_FORMAT_ERROR
53             #AZ_IO_ERROR
54             ],
55             CONSTANTS => [
56             qw(COMPRESSION_STORED COMPRESSION_DEFLATED)
57             ],
58             );
59              
60             our %sevenzip_charsetname = (
61             'UTF-8' => 'UTF-8',
62             'Latin-1' => 'WIN',
63             'ISO-8859-1' => 'WIN',
64             '' => 'DOS', # dunno what the appropriate name would be
65             );
66              
67             our %sevenzip_stdin_support = (
68             #'7z' => 1,
69             'xz' => 1,
70             'lzma' => 1,
71             'tar' => 1,
72             'gzip' => 1,
73             'bzip2' => 1,
74             );
75              
76             if( $^O !~ /MSWin/i ) {
77             # Wipe all filesystem encodings because my Debian 7z 9.20 doesn't understand them
78             $sevenzip_charsetname{ $_ } = ''
79             for keys %sevenzip_charsetname;
80             };
81              
82             our %class_defaults = (
83             '7zip' => '7z',
84             fs_encoding => 'UTF-8',
85             default_options => [ "-y", "-bd" ],
86             type => 'zip',
87             system_needs_quotes => scalar ($^O =~ /MSWin/i),
88             );
89              
90             =head2 C<< Archive::SevenZip->find_7z_executable >>
91              
92             my $version = Archive::SevenZip->find_7z_executable()
93             or die "No 7z found.";
94             print "Found 7z version '$version'";
95              
96             Finds the 7z executable in the path or in C<< $ENV{ProgramFiles} >>
97             or C<< $ENV{ProgramFiles(x86)} >>. This is called
98             when a C<< Archive::SevenZip >> instance is created with the C
99             parameter set to 1.
100              
101             If C<< $ENV{PERL_ARCHIVE_SEVENZIP_BIN} >> is set, this value will be used as
102             the 7z executable and the path will not be searched.
103              
104             =cut
105              
106             sub find_7z_executable {
107 10     10 1 14200 my($class) = @_;
108 10         45 my $old_default = $class_defaults{ '7zip' };
109 10 50       84 my $envsep = $^O =~ /MSWin/ ? ';' : ':';
110 10         33 my $found;
111 10 100       45 if( $ENV{PERL_ARCHIVE_SEVENZIP_BIN}) {
112 1         3 $class_defaults{'7zip'} = $ENV{PERL_ARCHIVE_SEVENZIP_BIN};
113 1   33     4 $found = $class->version || "7zip not found via environment '($ENV{PERL_ARCHIVE_SEVENZIP_BIN})'";
114             } else {
115 9         22 my @search;
116 9         175 push @search, split /$envsep/, $ENV{PATH};
117 9 50       68 if( $^O =~ /MSWin/i ) {
118 0         0 push @search, map { "$_\\7-Zip" } grep {defined} ($ENV{'ProgramFiles'}, $ENV{'ProgramFiles(x86)'});
  0         0  
  0         0  
119             };
120 9         42 $found = $class->version;
121              
122 9   33     340 while( ! defined $found and @search) {
123 0         0 my $dir = shift @search;
124 0 0       0 if ($^O eq 'MSWin32') {
125 0 0       0 next unless -e file("$dir", "7z.exe" );
126             }
127 0         0 $class_defaults{'7zip'} = "" . file("$dir", "7z" );
128 0         0 $found = $class->version;
129             };
130             };
131              
132 10 100       178 if( ! $found) {
133 9         135 $class_defaults{ '7zip' } = $old_default;
134             };
135 10 50       235 return defined $found ? $found : ()
136             }
137              
138             =head2 C<< Archive::SevenZip->new >>
139              
140             my $ar = Archive::SevenZip->new( $archivename );
141              
142             my $ar = Archive::SevenZip->new(
143             archivename => $archivename,
144             find => 1,
145             );
146              
147             Creates a new class instance.
148              
149             C - will try to find the executable using C<< ->find_7z_executable >>
150              
151             =cut
152              
153             sub new {
154 16     16 1 1765 my( $class, %options);
155 16 100       77 if( @_ == 2 ) {
156 1         5 ($class, $options{ archivename }) = @_;
157             } else {
158 15         69 ($class, %options) = @_;
159             };
160              
161 16 50       68 if( $options{ find }) {
162 0         0 $class->find_7z_executable();
163             };
164              
165 16         75 for( keys %class_defaults ) {
166             $options{ $_ } = $class_defaults{ $_ }
167 80 100       201 unless defined $options{ $_ };
168             };
169              
170 16         93 bless \%options => $class
171             }
172              
173             sub version {
174 10     10 0 37 my( $self_or_class, %options) = @_;
175 10         70 for( keys %class_defaults ) {
176             $options{ $_ } = $class_defaults{ $_ }
177 50 50       165 unless defined $options{ $_ };
178             };
179 10 50       87 my $self = ref $self_or_class ? $self_or_class : $self_or_class->new( %options );
180              
181 10         76 my $cmd = $self->get_command(
182             command => '',
183             archivename => undef,
184             options => [], # on Debian, 7z doesn't like any options...
185             fs_encoding => undef, # on Debian, 7z doesn't like any options...
186             default_options => [], # on Debian, 7z doesn't like any options...
187             );
188 10         29 my $fh = eval { $self->run($cmd, binmode => ':raw') };
  10         39  
189              
190 10 50       153083 if( ! $@ ) {
191 0         0 local $/ = "\n";
192 0         0 my @output = <$fh>;
193 0 0       0 if( @output >= 3) {
194             # 7-Zip 19.00 (x64) : Copyright (c) 1999-2022 Igor Pavlov : 2019-02-21
195             # 7-Zip [64] 16.02 : Copyright (c) 1999-2022 Igor Pavlov : 2016-05-21
196             # 7-Zip [64] 9.20 Copyright (c) 1999-2022 Igor Pavlov 2010-11-18
197 0 0       0 $output[1] =~ /^7-Zip\s+.*?\b(\d+\.\d+)\s+(?:\(x64\))?(?:\s*:\s*)?Copyright/
198             or return undef;
199 0         0 return $1;
200             } else {
201             return undef
202 0         0 }
203             }
204             }
205              
206             =head2 C<< $ar->open >>
207              
208             my @entries = $ar->open;
209             for my $entry (@entries) {
210             print $entry->fileName, "\n";
211             };
212              
213             Lists the entries in the archive. A fresh archive which does not
214             exist on disk yet has no entries. The returned entries
215             are L instances.
216              
217             This method will one day move to the Path::Class-compatibility
218             API.
219              
220             =cut
221             # Iterate over the entries in the archive
222             # Path::Class API
223             sub open {
224 0     0 1 0 my( $self )= @_;
225 0         0 my @contents = $self->list();
226             }
227              
228             =head2 C<< $ar->memberNamed >>
229              
230             my $entry = $ar->memberNamed('hello_world.txt');
231             print $entry->fileName, "\n";
232              
233             The path separator must be a forward slash ("/")
234              
235             This method will one day move to the Archive::Zip-compatibility
236             API.
237              
238             =cut
239              
240             # Archive::Zip API
241             sub memberNamed {
242 0     0 1 0 my( $self, $name, %options )= @_;
243              
244 0         0 my( $entry ) = grep { $_->fileName eq $name } $self->members( %options );
  0         0  
245 0         0 $entry
246             }
247              
248             # Archive::Zip API
249             sub list {
250 0     0 0 0 my( $self, %options )= @_;
251              
252 0 0       0 if( ! grep { defined $_ } $options{archivename}, $self->{archivename}) {
  0         0  
253             # We are an archive that does not exist on disk yet
254             return
255 0         0 };
256 0         0 my $cmd = $self->get_command( command => "l", options => ["-slt"], %options );
257              
258             my $fh = $self->run($cmd,
259             encoding => $options{ fs_encoding },
260             stdin_fh => $options{ fh },
261 0         0 );
262 0         0 my @output = <$fh>;
263 0         0 my %results = (
264             header => [],
265             archive => [],
266             );
267              
268             # Get/skip header
269 0   0     0 while( @output and $output[0] !~ /^--\s*$/ ) {
270 0         0 my $line = shift @output;
271 0         0 $line =~ s!\s+$!!;
272 0         0 push @{ $results{ header }}, $line;
  0         0  
273             };
274              
275             # Get/skip archive information
276 0   0     0 while( @output and $output[0] !~ /^----------\s*$/ ) {
277 0         0 my $line = shift @output;
278 0         0 $line =~ s!\s+$!!;
279 0         0 push @{ $results{ archive }}, $line;
  0         0  
280             };
281              
282 0 0       0 if( $output[0] =~ /^----------\s*$/ ) {
283 0         0 shift @output;
284             } else {
285 0         0 warn "Unexpected line in 7zip output, hope that's OK: [$output[0]]";
286             };
287              
288 0         0 my @members;
289              
290             # Split entries
291             my %entry_info;
292 0         0 for my $line (@output ) {
293 0 0       0 if( $line =~ /^([\w ]+) =(?: (.*?)|)\s*$/ ) {
    0          
    0          
294 0         0 $entry_info{ $1 } = $2;
295             } elsif($line =~ /^\s*$/) {
296 0 0       0 if( $entry_info{ 'Path' }) {
297 0         0 push @members, Archive::SevenZip::Entry->new(
298             %entry_info,
299             _Container => $self,
300             );
301             };
302 0         0 %entry_info = ();
303             } elsif( $line =~ /^Warnings: \d+\s+/) {
304             # ignore
305             # use Data::Dumper; warn Dumper \@output;
306             # croak "Unknown file entry [$line]";
307             } else {
308 0         0 croak "Unknown file entry [$line]";
309             };
310             };
311              
312             return @members
313 0         0 }
314 13     13   148 { no warnings 'once';
  13         29  
  13         31351  
315             *members = \&list;
316             }
317              
318             =head2 C<< $ar->openMemberFH >>
319              
320             my $fh = $ar->openMemberFH('test.txt');
321             while( <$fh> ) {
322             print "test.txt: $_";
323             };
324              
325             Reads the uncompressed content of the member from the archive.
326              
327             This method will one day move to the Archive::Zip-compatibility
328             API.
329              
330             =cut
331              
332             sub openMemberFH {
333 0     0 1 0 my( $self, %options );
334 0 0       0 if( @_ == 2 ) {
335 0         0 ($self,$options{ membername })= @_;
336             } else {
337 0         0 ($self,%options) = @_;
338             };
339 0 0       0 defined $options{ membername } or croak "Need member name to extract";
340              
341 0         0 my $cmd = $self->get_command( command => "e", options => ["-so"], members => [$options{membername}] );
342 0         0 my $fh = $self->run($cmd, encoding => $options{ encoding }, binmode => $options{ binmode });
343 0         0 return $fh
344             }
345              
346             sub content {
347 0     0 0 0 my( $self, %options ) = @_;
348 0         0 my $fh = $self->openMemberFH( %options );
349 0         0 binmode $fh;
350 0         0 local $/;
351             <$fh>
352 0         0 }
353             =head2 C<< $ar->extractMember >>
354              
355             $ar->extractMember('test.txt' => 'extracted_test.txt');
356              
357             Extracts the uncompressed content of the member from the archive.
358              
359             This method will one day move to the Archive::Zip-compatibility
360             API.
361              
362             =cut
363              
364             # Archive::Zip API
365             sub extractMember {
366 0     0 0 0 my( $self, $memberOrName, $extractedName, %_options ) = @_;
367 0 0       0 $extractedName = $memberOrName
368             unless defined $extractedName;
369              
370 0         0 my %options = (%$self, %_options);
371              
372 0         0 my $target_dir = dirname $extractedName;
373 0         0 my $target_name = basename $extractedName;
374             my $cmd = $self->get_command(
375             command => "e",
376             archivename => $options{ archivename },
377 0         0 members => [ $memberOrName ],
378             options => [ "-o$target_dir" ],
379             );
380 0         0 my $fh = $self->run($cmd, encoding => $options{ encoding });
381              
382 0         0 while( <$fh>) {
383 0 0       0 warn $_ if $options{ verbose };
384             };
385 0 0       0 if( basename $memberOrName ne $target_name ) {
386 0         0 my $org = basename($memberOrName);
387              
388             # Maybe, _maybe_, we need to look for the file using UTF-8
389             # encoded filenames, but also, maybe not. So let's try both...
390 0         0 my $src = "$target_dir/$org";
391 0 0       0 if( ! -f $src ) {
392 0         0 $src = "$target_dir/" . encode('UTF-8', $org);
393             }
394 0 0       0 rename $src => $extractedName
395             or croak "Couldn't move '$src' ('$memberOrName') to '$extractedName': $!";
396             };
397              
398 0         0 return AZ_OK;
399             };
400              
401             =head2 C<< $ar->removeMember >>
402              
403             $ar->removeMember('test.txt');
404              
405             Removes the member from the archive.
406              
407             =cut
408              
409             # strikingly similar to Archive::Zip API
410             sub removeMember {
411 0     0 1 0 my( $self, $name, %_options ) = @_;
412              
413 0         0 my %options = (%$self, %_options);
414              
415 0 0       0 if( $^O =~ /MSWin/ ) {
416 0         0 $name =~ s!/!\\!g;
417             }
418              
419             my $cmd = $self->get_command(
420             command => "d",
421             archivename => $options{ archivename },
422 0         0 members => [ $name ],
423             );
424 0         0 my $fh = $self->run($cmd, encoding => $options{ encoding } );
425 0         0 $self->wait($fh, %options);
426              
427 0         0 return AZ_OK;
428             };
429              
430             sub add_quotes {
431 40     40 0 68 my $quote = shift;
432              
433             $quote ?
434             map {
435 40 0 0     122 defined $_ && /\s/ ? qq{"$_"} : $_
  0 50       0  
436             } @_
437             : @_
438             };
439              
440             sub get_command {
441 10     10 0 69 my( $self, %options )= @_;
442 10   50     101 $options{ members } ||= [];
443             $options{ archivename } = $self->{ archivename }
444 10 50       136 unless defined $options{ archivename };
445 10 50       57 if( ! exists $options{ fs_encoding }) {
446 0 0       0 $options{ fs_encoding } = defined $self->{ fs_encoding } ? $self->{ fs_encoding } : $class_defaults{ fs_encoding };
447             };
448 10 50       37 if( ! defined $options{ default_options }) {
449 0 0       0 $options{ default_options } = defined $self->{ default_options } ? $self->{ default_options } : $class_defaults{ default_options };
450             };
451              
452 10         24 my @charset;
453 10 50       39 if( defined $options{ fs_encoding }) {
454             exists $sevenzip_charsetname{ $options{ fs_encoding }}
455 0 0       0 or croak "Unknown filesystem encoding '$options{ fs_encoding }'";
456 0 0       0 if( my $charset = $sevenzip_charsetname{ $options{ fs_encoding }}) {
457 0         0 push @charset, "-scs" . $sevenzip_charsetname{ $options{ fs_encoding }};
458             };
459             };
460 10         20 for(@{ $options{ members }}) {
  10         37  
461 0         0 $_ = encode $options{ fs_encoding }, $_;
462             };
463              
464 10         31 my $add_quote = $self->{system_needs_quotes};
465 30         103 return [grep {defined $_}
466             add_quotes($add_quote, $self->{ '7zip' }),
467 10         40 @{ $options{ default_options }},
468             $options{ command },
469             @charset,
470 10         39 add_quotes($add_quote, @{ $options{ options }} ),
471             # "--",
472             add_quotes($add_quote, $options{ archivename } ),
473 10         43 add_quotes($add_quote, @{ $options{ members }} ),
  10         26  
474             ];
475             }
476              
477             sub run {
478 10     10 0 43 my( $self, $cmd, %options )= @_;
479              
480 10         26 my $mode = '-|';
481 10 50 33     97 if( defined $options{ stdin } || defined $options{ stdin_fh }) {
482 0         0 $mode = '|-';
483             };
484              
485 10         25 my $fh;
486             warn "Opening [@$cmd]"
487 10 50 33     72 if $options{ verbose } || $self->{verbose};
488              
489 10 50       38 if( $self->{verbose} ) {
490 0 0       0 CORE::open( $fh, $mode, @$cmd)
491             or croak "Couldn't launch [$mode @$cmd]: $!/$?";
492             } else {
493 10 50       640 CORE::open( my $fh_err, '>', File::Spec->devnull )
494             or warn "Couldn't redirect child STDERR";
495 10         63 my $errh = fileno $fh_err;
496 10         26 my $fh_in = $options{ stdin_fh };
497             # We accumulate zombie PIDs here, ah well.
498 10         327 $SIG{'CHLD'} = 'IGNORE';
499 10 0       127 my $pid = open3( $fh_in, my $fh_out, '>&' . $errh, @$cmd)
500             or croak "Couldn't launch [$mode @$cmd]: $!/$?";
501 0 0       0 if( $mode eq '|-' ) {
502 0         0 $fh = $fh_in;
503             } else {
504 0         0 $fh = $fh_out
505             };
506             }
507 0 0       0 if( $options{ encoding }) {
    0          
508 0         0 binmode $fh, ":encoding($options{ encoding })";
509             } elsif( $options{ binmode } ) {
510 0         0 binmode $fh, $options{ binmode };
511             };
512              
513 0 0       0 if( $options{ stdin }) {
    0          
    0          
514 0         0 print {$fh} $options{ stdin };
  0         0  
515 0         0 close $fh;
516              
517             } elsif( $options{ stdin_fh } ) {
518 0         0 close $fh;
519              
520             } elsif( $options{ skip }) {
521 0         0 for( 1..$options{ skip }) {
522             # Read that many lines
523 0         0 local $/ = "\n";
524 0         0 scalar <$fh>;
525             };
526             };
527              
528 0         0 $fh;
529             }
530              
531             sub archive_or_temp {
532 1     1 0 3 my( $self ) = @_;
533 1 50       5 if( ! defined $self->{archivename} ) {
534 0         0 $self->{is_tempfile} = 1;
535 0         0 (my( $fh ),$self->{archivename}) = tempfile( SUFFIX => ".$self->{type}" );
536 0         0 close $fh;
537 0         0 unlink $self->{archivename};
538             };
539             $self->{archivename}
540 1         4 };
541              
542             sub wait {
543 0     0 0 0 my( $self, $fh, %options ) = @_;
544 0         0 while( <$fh>) {
545             warn $_ if ($options{ verbose } || $self->{verbose})
546 0 0 0     0 };
547 0         0 wait; # reap that child
548             }
549              
550             =head2 C<< $ar->add_scalar >>
551              
552             $ar->add_scalar( "Some name.txt", "This is the content" );
553              
554             Adds a scalar as an archive member.
555              
556             Unfortunately, 7zip only reads archive members from STDIN
557             for xz, lzma, tar, gzip and bzip2 archives.
558             In the other cases, the scalar will be written to a tempfile, added to the
559             archive and then renamed in the archive.
560              
561             This requires 7zip version 9.30+
562              
563             =cut
564              
565             sub add_scalar {
566 0     0 1 0 my( $self, $name, $scalar )= @_;
567              
568 0 0       0 if( $sevenzip_stdin_support{ $self->{type} } ) {
569 0         0 my $cmd = $self->get_command(
570             command => 'a',
571             archivename => $self->archive_or_temp,
572             members => ["-si$name"],
573             );
574 0         0 my $fh = $self->run( $cmd,
575             binmode => ':raw',
576             stdin => $scalar,
577             verbose => 1,
578             );
579              
580             } else {
581              
582             # 7zip doesn't really support reading archive members from STDIN :-(
583 0         0 my($fh, $tempname) = tempfile;
584 0         0 binmode $fh, ':raw';
585 0         0 print {$fh} $scalar;
  0         0  
586 0         0 close $fh;
587              
588             # Only supports 7z archive type?!
589             # 7zip will magically append .7z to the filename :-(
590 0         0 my $cmd = $self->get_command(
591             command => 'a',
592             archivename => $self->archive_or_temp,
593             members => [$tempname],
594             #options => ],
595             );
596 0         0 $fh = $self->run( $cmd );
597 0         0 $self->wait($fh);
598              
599 0 0       0 unlink $tempname
600             or warn "Couldn't unlink '$tempname': $!";
601              
602             # Hopefully your version of 7zip can rename members (9.30+):
603 0         0 $cmd = $self->get_command(
604             command => 'rn',
605             archivename => $self->archive_or_temp,
606             members => [basename($tempname), $name],
607             #options => ],
608             );
609 0         0 $fh = $self->run( $cmd );
610 0         0 $self->wait($fh);
611             };
612             };
613              
614             =head2 C<< $ar->add_directory >>
615              
616             $ar->add_directory( "real_etc", "etc" );
617              
618             Adds an empty directory
619              
620             This currently ignores the directory date and time if the directory
621             exists
622              
623             =cut
624              
625             sub add_directory {
626 0     0 1 0 my( $self, $localname, $target )= @_;
627              
628 0   0     0 $target ||= $localname;
629              
630             # Create an empty directory, add it to the archive,
631             # then rename that temp name to the wanted name:
632 0         0 my $tempname = tempdir;
633              
634 0         0 my $cmd = $self->get_command(
635             command => 'a',
636             archivename => $self->archive_or_temp,
637             members => [$tempname],
638             options => ['-r0'],
639             );
640 0         0 my $fh = $self->run( $cmd );
641 0         0 $self->wait($fh);
642              
643             # Hopefully your version of 7zip can rename members (9.30+):
644 0         0 $cmd = $self->get_command(
645             command => 'rn',
646             archivename => $self->archive_or_temp,
647             members => [basename($tempname), $target],
648             );
649 0         0 $fh = $self->run( $cmd );
650 0         0 $self->wait($fh);
651              
652             # Once 7zip supports reading from stdin, this will work again:
653             #my $fh = $self->run( $cmd,
654             # binmode => ':raw',
655             # stdin => $scalar,
656             # verbose => 1,
657             #);
658             };
659              
660             =head2 C<< $ar->add >>
661              
662             $ar->add( items => ["real_etc" => "name_in_archive" ] );
663              
664             Adds elements to an archive
665              
666             This currently ignores the directory date and time if the directory
667             exists
668              
669             =cut
670              
671             sub add {
672 0     0 1 0 my( $self, %options )= @_;
673              
674 0 0       0 my @items = @{ delete $options{ items } || [] };
  0         0  
675              
676             # Split up the list into one batch for the listfiles
677             # and the list of files we need to rename
678              
679 0         0 my @filelist;
680 0         0 for my $item (@items) {
681 0 0       0 if( ! ref $item ) {
682 0         0 $item = [ $item, $item ];
683             };
684 0         0 my( $name, $storedName ) = @$item;
685              
686 0 0       0 if( $name ne $storedName ) {
687             # We need to pipe to 7zip from stdin (no, we don't, we can rename afterwards)
688             # This still means we might overwrite an already existing file in the archive...
689             # But 7-zip seems to not like duplicate filenames anyway in "@"-listfiles...
690 0         0 my $cmd = $self->get_command(
691             command => 'a',
692             archivename => $self->archive_or_temp,
693             members => [$name],
694             #options => ],
695             );
696 0         0 my $fh = $self->run( $cmd );
697 0         0 $self->wait($fh, %options );
698              
699             # The stored name may contain a path, but we
700             # use basename() here. Hopefully that's simply OK for everybody.
701 0         0 my $sourceName = file($name);
702 0 0       0 if( $sourceName->is_absolute ) {
703 0         0 $sourceName = $sourceName->basename;
704             };
705 0         0 $cmd = $self->get_command(
706             command => 'rn',
707             archivename => $self->archive_or_temp,
708             members => [$sourceName, $storedName],
709             #options => ],
710             );
711 0         0 $fh = $self->run( $cmd );
712 0         0 $self->wait($fh, %options );
713              
714             } else {
715             # 7zip can read the file from disk
716             # Write the name to a tempfile to be read by 7zip for batching
717 0         0 push @filelist, $name;
718             };
719             };
720              
721 0 0       0 if( @filelist ) {
722 0         0 my( $fh, $name) = tempfile;
723 0         0 binmode $fh, ':raw';
724 0         0 print {$fh} join "\r\n", @filelist;
  0         0  
725 0         0 close $fh;
726              
727 0         0 my @options;
728 0 0       0 if( $options{ recursive }) {
729 0         0 push @options, '-r';
730             };
731 0         0 my $cmd = $self->get_command(
732             command => 'a',
733             archivename => $self->archive_or_temp,
734             members => ['@'.$name],
735             options => \@options
736             );
737 0         0 $fh = $self->run( $cmd );
738 0         0 $self->wait($fh, %options);
739             };
740             };
741              
742             =head2 C<< ->archiveZipApi >>
743              
744             my $ar = Archive::SevenZip->archiveZipApi(
745             find => 1,
746             archivename => $archivename,
747             verbose => $verbose,
748             );
749             print "$_\n" for $ar->list_files;
750              
751             This is an alternative constructor that gives you an API
752             that is somewhat compatible with the API of L.
753             See also L.
754              
755             =cut
756              
757             sub archiveZipApi {
758 1     1 1 7 my( $class, %options ) = @_;
759 1         507 require Archive::SevenZip::API::ArchiveZip;
760 1         11 Archive::SevenZip::API::ArchiveZip->new( %options )
761             }
762              
763             =head2 C<< ->archiveTarApi >>
764              
765             my $ar = Archive::SevenZip->archiveTarApi(
766             find => 1,
767             archivename => $archivename,
768             verbose => $verbose,
769             );
770             print "$_\n" for $ar->list_files;
771              
772             This is an alternative constructor that gives you an API
773             that is somewhat compatible with the API of L.
774             See also L.
775              
776             =cut
777              
778             sub archiveTarApi {
779 0     0 1   my( $class, %options ) = @_;
780 0           require Archive::SevenZip::API::ArchiveTar;
781 0           Archive::SevenZip::API::ArchiveTar->new( %options )
782             }
783              
784             package Path::Class::Archive::Handle;
785 13     13   117 use strict;
  13         47  
  13         782  
786              
787             =head1 NAME
788              
789             Path::Class::Archive::Handle - treat archives as directories
790              
791             =cut
792              
793             package Path::Class::Archive;
794              
795             1;
796              
797             __END__