File Coverage

blib/lib/Archive/Zip/Archive.pm

Criterion	Covered	Total	%
statement	309	414	74.6
branch	102	222	45.9
condition	16	34	47.1
subroutine	45	58	77.6
pod	37	37	100.0
total	509	765	66.5

line	stmt	bran	cond	sub	pod	time	code
1							package Archive::Zip::Archive;
2
3							# Represents a generic ZIP archive
4
5	6			6		86	use strict;
	6					56
	6					123
6	6			6		108	use File::Path;
	6					55
	6					198
7	6			6		103	use File::Find ();
	6					56
	6					58
8	6			6		127	use File::Spec ();
	6					55
	6					56
9	6			6		240	use File::Copy ();
	6					62
	6					64
10	6			6		103	use File::Basename;
	6					53
	6					140
11	6			6		132	use Cwd;
	6					2811
	6					207
12
13	6			6		202	use vars qw( $VERSION @ISA );
	6					158
	6					96
14
15							BEGIN {
16	6			6		180	$VERSION = '1.18';
17	6					78	@ISA = qw( Archive::Zip );
18							}
19
20	6					195	use Archive::Zip qw(
21							:CONSTANTS
22							:ERROR_CODES
23							:PKZIP_CONSTANTS
24							:UTILITY_METHODS
25	6			6		4634	);
	6					57
26
27							# Note that this returns undef on read errors, else new zip object.
28
29							sub new {
30	7			7	1	72	my $class = shift;
31	7					310	my $self = bless(
32							{
33							'diskNumber' => 0,
34							'diskNumberWithStartOfCentralDirectory' => 0,
35							'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members
36							'numberOfCentralDirectories' => 0, # shld be # of members
37							'centralDirectorySize' => 0, # must re-compute on write
38							'centralDirectoryOffsetWRTStartingDiskNumber' =>
39							0, # must re-compute
40							'writeEOCDOffset' => 0,
41							'writeCentralDirectoryOffset' => 0,
42							'zipfileComment' => '',
43							'eocdOffset' => 0,
44							'fileName' => ''
45							},
46							$class
47							);
48	7					82	$self->{'members'} = [];
49	7	50				85	if (@_) {
50	0					0	my $status = $self->read(@_);
51	0	0				0	return $status == AZ_OK ? $self : undef;
52							}
53	7					81	return $self;
54							}
55
56							sub members {
57	219			219	1	3110	@{ shift->{'members'} };
	219					5164
58							}
59
60							sub numberOfMembers {
61	42			42	1	942	scalar( shift->members() );
62							}
63
64							sub memberNames {
65	5			5	1	558	my $self = shift;
66	5					174	return map { $_->fileName() } $self->members();
	27					394
67							}
68
69							# return ref to member with given name or undef
70							sub memberNamed {
71	67			67	1	833	my ( $self, $fileName ) = @_;
72	67					1169	foreach my $member ( $self->members() ) {
73	348	100				4868	return $member if $member->fileName() eq $fileName;
74							}
75	24					395	return undef;
76							}
77
78							sub membersMatching {
79	4			4	1	270	my ( $self, $pattern ) = @_;
80	4					63	return grep { $_->fileName() =~ /$pattern/ } $self->members();
	24					404
81							}
82
83							sub diskNumber {
84	0			0	1	0	shift->{'diskNumber'};
85							}
86
87							sub diskNumberWithStartOfCentralDirectory {
88	0			0	1	0	shift->{'diskNumberWithStartOfCentralDirectory'};
89							}
90
91							sub numberOfCentralDirectoriesOnThisDisk {
92	0			0	1	0	shift->{'numberOfCentralDirectoriesOnThisDisk'};
93							}
94
95							sub numberOfCentralDirectories {
96	0			0	1	0	shift->{'numberOfCentralDirectories'};
97							}
98
99							sub centralDirectorySize {
100	2			2	1	46	shift->{'centralDirectorySize'};
101							}
102
103							sub centralDirectoryOffsetWRTStartingDiskNumber {
104	1			1	1	10	shift->{'centralDirectoryOffsetWRTStartingDiskNumber'};
105							}
106
107							sub zipfileComment {
108	17			17	1	196	my $self = shift;
109	17					171	my $comment = $self->{'zipfileComment'};
110	17	50				168	if (@_) {
111	0					0	$self->{'zipfileComment'} = pack( 'C0a*', shift() ); # avoid unicode
112							}
113	17					182	return $comment;
114							}
115
116							sub eocdOffset {
117	6			6	1	151	shift->{'eocdOffset'};
118							}
119
120							# Return the name of the file last read.
121							sub fileName {
122	0			0	1	0	shift->{'fileName'};
123							}
124
125							sub removeMember {
126	4			4	1	280	my ( $self, $member ) = @_;
127	4	50				180	$member = $self->memberNamed($member) unless ref($member);
128	4	50				77	return undef unless $member;
129	4					201	my @newMembers = grep { $_ != $member } $self->members();
	28					341
130	4					122	$self->{'members'} = \@newMembers;
131	4					88	return $member;
132							}
133
134							sub replaceMember {
135	31			31	1	478	my ( $self, $oldMember, $newMember ) = @_;
136	31	50				486	$oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
137	31	50				303	return undef unless $oldMember;
138	31	50				322	return undef unless $newMember;
139	354	100				3737	my @newMembers =
140	31					373	map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
141	31					395	$self->{'members'} = \@newMembers;
142	31					445	return $oldMember;
143							}
144
145							sub extractMember {
146	15			15	1	1079	my $self = shift;
147	15					441	my $member = shift;
148	15	100				1082	$member = $self->memberNamed($member) unless ref($member);
149	15	50				308	return _error('member not found') unless $member;
150	15					687	my $originalSize = $member->compressedSize();
151	15					151	my $name = shift; # local FS name if given
152	15					197	my ( $volumeName, $dirName, $fileName );
153	15	100				219	if ( defined($name) ) {
154	2					438	( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
155	2					460	$dirName = File::Spec->catpath( $volumeName, $dirName, '' );
156							}
157							else {
158	13					242	$name = $member->fileName();
159	13					658	( $dirName = $name ) =~ s{[^/]*$}{};
160	13					1132	$dirName = Archive::Zip::_asLocalName($dirName);
161	13					758	$name = Archive::Zip::_asLocalName($name);
162							}
163	15	100	66			2683	if ( $dirName && !-d $dirName ) {
164	2					296	mkpath($dirName);
165	2	50				1488	return _ioError("can't create dir $dirName") if ( !-d $dirName );
166							}
167	15					1755	my $rc = $member->extractToFileNamed( $name, @_ );
168
169							# TODO refactor this fix into extractToFileNamed()
170	15					492	$member->{'compressedSize'} = $originalSize;
171	15					4341	return $rc;
172							}
173
174							sub extractMemberWithoutPaths {
175	0			0	1	0	my $self = shift;
176	0					0	my $member = shift;
177	0	0				0	$member = $self->memberNamed($member) unless ref($member);
178	0	0				0	return _error('member not found') unless $member;
179	0					0	my $originalSize = $member->compressedSize();
180	0	0				0	return AZ_OK if $member->isDirectory();
181	0					0	my $name = shift;
182	0	0				0	unless ($name) {
183	0					0	$name = $member->fileName();
184	0					0	$name =~ s{.*/}{}; # strip off directories, if any
185	0					0	$name = Archive::Zip::_asLocalName($name);
186							}
187	0					0	my $rc = $member->extractToFileNamed( $name, @_ );
188	0					0	$member->{'compressedSize'} = $originalSize;
189	0					0	return $rc;
190							}
191
192							sub addMember {
193	42			42	1	562	my ( $self, $newMember ) = @_;
194	42	50				676	push( @{ $self->{'members'} }, $newMember ) if $newMember;
	42					592
195	42					432	return $newMember;
196							}
197
198							sub addFile {
199	23			23	1	272	my $self = shift;
200	23					311	my $fileName = shift;
201	23					255	my $newName = shift;
202	23					1521	my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
203	23	50				391	$self->addMember($newMember) if defined($newMember);
204	23					224	return $newMember;
205							}
206
207							sub addString {
208	4			4	1	255	my $self = shift;
209	4					353	my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
210	4					74	return $self->addMember($newMember);
211							}
212
213							sub addDirectory {
214	1			1	1	233	my ( $self, $name, $newName ) = @_;
215	1					358	my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
216	1					31	$self->addMember($newMember);
217	1					12	return $newMember;
218							}
219
220							# add either a file or a directory.
221
222							sub addFileOrDirectory {
223	0			0	1	0	my ( $self, $name, $newName ) = @_;
224	0	0				0	if ( -f $name ) {
		0
225	0	0				0	( $newName =~ s{/$}{} ) if $newName;
226	0					0	return $self->addFile( $name, $newName );
227							}
228							elsif ( -d $name ) {
229	0	0				0	( $newName =~ s{[^/]$}{&/} ) if $newName;
230	0					0	return $self->addDirectory( $name, $newName );
231							}
232							else {
233	0					0	return _error("$name is neither a file nor a directory");
234							}
235							}
236
237							sub contents {
238	1			1	1	149	my ( $self, $member, $newContents ) = @_;
239	1	50				84	return _error('No member name given') unless $member;
240	1	50				14	$member = $self->memberNamed($member) unless ref($member);
241	1	50				65	return undef unless $member;
242	1					106	return $member->contents($newContents);
243							}
244
245							sub writeToFileNamed {
246	16			16	1	1225	my $self = shift;
247	16					412	my $fileName = shift; # local FS format
248	16					597	foreach my $member ( $self->members() ) {
249	62	50				1460	if ( $member->_usesFileNamed($fileName) ) {
250	0					0	return _error( "$fileName is needed by member "
251							. $member->fileName()
252							. "; consider using overwrite() or overwriteAs() instead." );
253							}
254							}
255	16					600	my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
256	16	50				681	return _ioError("Can't open $fileName for write") unless $status;
257	16					852	my $retval = $self->writeToFileHandle( $fh, 1 );
258	16					452	$fh->close();
259	16					1484	$fh = undef;
260
261	16					267	return $retval;
262							}
263
264							# It is possible to write data to the FH before calling this,
265							# perhaps to make a self-extracting archive.
266							sub writeToFileHandle {
267	17			17	1	616	my $self = shift;
268	17					3776	my $fh = shift;
269	17	50				302	return _error('No filehandle given') unless $fh;
270	17	50				602	return _ioError('filehandle not open') unless $fh->opened();
271
272	17	100				608	my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
273	17					224	_binmode($fh);
274
275							# Find out where the current position is.
276	17	100				1043	my $offset = $fhIsSeekable ? $fh->tell() : 0;
277	17	50				475	$offset = 0 if $offset < 0;
278
279	17					233	foreach my $member ( $self->members() ) {
280	71					1516	my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
281	71					1023	$member->endRead();
282	71	50				766	return $retval if $retval != AZ_OK;
283	71					1570	$offset += $member->_localHeaderSize() + $member->_writeOffset();
284	71	100				849	$offset +=
285							$member->hasDataDescriptor()
286							? DATA_DESCRIPTOR_LENGTH + SIGNATURE_LENGTH
287							: 0;
288
289							# changed this so it reflects the last successful position
290	71					1853	$self->{'writeCentralDirectoryOffset'} = $offset;
291							}
292	17					980	return $self->writeCentralDirectory($fh);
293							}
294
295							# Write zip back to the original file,
296							# as safely as possible.
297							# Returns AZ_OK if successful.
298							sub overwrite {
299	0			0	1	0	my $self = shift;
300	0					0	return $self->overwriteAs( $self->{'fileName'} );
301							}
302
303							# Write zip to the specified file,
304							# as safely as possible.
305							# Returns AZ_OK if successful.
306							sub overwriteAs {
307	0			0	1	0	my $self = shift;
308	0					0	my $zipName = shift;
309	0	0				0	return _error("no filename in overwriteAs()") unless defined($zipName);
310
311	0					0	my ( $fh, $tempName ) = Archive::Zip::tempFile();
312	0	0				0	return _error( "Can't open temp file", $! ) unless $fh;
313
314	0					0	( my $backupName = $zipName ) =~ s{(\.[^.]*)?$}{.zbk};
315
316	0					0	my $status = $self->writeToFileHandle($fh);
317	0					0	$fh->close();
318	0					0	$fh = undef;
319
320	0	0				0	if ( $status != AZ_OK ) {
321	0					0	unlink($tempName);
322	0					0	_printError("Can't write to $tempName");
323	0					0	return $status;
324							}
325
326	0					0	my $err;
327
328							# rename the zip
329	0	0	0			0	if ( -f $zipName && !rename( $zipName, $backupName ) ) {
330	0					0	$err = $!;
331	0					0	unlink($tempName);
332	0					0	return _error( "Can't rename $zipName as $backupName", $err );
333							}
334
335							# move the temp to the original name (possibly copying)
336	0	0				0	unless ( File::Copy::move( $tempName, $zipName ) ) {
337	0					0	$err = $!;
338	0					0	rename( $backupName, $zipName );
339	0					0	unlink($tempName);
340	0					0	return _error( "Can't move $tempName to $zipName", $err );
341							}
342
343							# unlink the backup
344	0	0	0			0	if ( -f $backupName && !unlink($backupName) ) {
345	0					0	$err = $!;
346	0					0	return _error( "Can't unlink $backupName", $err );
347							}
348
349	0					0	return AZ_OK;
350							}
351
352							# Used only during writing
353							sub _writeCentralDirectoryOffset {
354	51			51		841	shift->{'writeCentralDirectoryOffset'};
355							}
356
357							sub _writeEOCDOffset {
358	17			17		260	shift->{'writeEOCDOffset'};
359							}
360
361							# Expects to have _writeEOCDOffset() set
362							sub _writeEndOfCentralDirectory {
363	17			17		164	my ( $self, $fh ) = @_;
364
365	17	50				571	$fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
366							or return _ioError('writing EOCD Signature');
367	17					1007	my $zipfileCommentLength = length( $self->zipfileComment() );
368
369	17					555	my $header = pack(
370							END_OF_CENTRAL_DIRECTORY_FORMAT,
371							0, # {'diskNumber'},
372							0, # {'diskNumberWithStartOfCentralDirectory'},
373							$self->numberOfMembers(), # {'numberOfCentralDirectoriesOnThisDisk'},
374							$self->numberOfMembers(), # {'numberOfCentralDirectories'},
375							$self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
376							$self->_writeCentralDirectoryOffset(),
377							$zipfileCommentLength
378							);
379	17	50				457	$fh->print($header)
380							or return _ioError('writing EOCD header');
381	17	50				478	if ($zipfileCommentLength) {
382	0	0				0	$fh->print( $self->zipfileComment() )
383							or return _ioError('writing zipfile comment');
384							}
385	17					204	return AZ_OK;
386							}
387
388							# $offset can be specified to truncate a zip file.
389							sub writeCentralDirectory {
390	17			17	1	177	my ( $self, $fh, $offset ) = @_;
391
392	17	50				331	if ( defined($offset) ) {
393	0					0	$self->{'writeCentralDirectoryOffset'} = $offset;
394	0	0				0	$fh->seek( $offset, IO::Seekable::SEEK_SET )
395							or return _ioError('seeking to write central directory');
396							}
397							else {
398	17					457	$offset = $self->_writeCentralDirectoryOffset();
399							}
400
401	17					188	foreach my $member ( $self->members() ) {
402	71					2347	my $status = $member->_writeCentralDirectoryFileHeader($fh);
403	71	50				714	return $status if $status != AZ_OK;
404	71					1225	$offset += $member->_centralDirectoryHeaderSize();
405	71					1438	$self->{'writeEOCDOffset'} = $offset;
406							}
407	17					297	return $self->_writeEndOfCentralDirectory($fh);
408							}
409
410							sub read {
411	1			1	1	176	my $self = shift;
412	1					77	my $fileName = shift;
413	1	50				124	return _error('No filename given') unless $fileName;
414	1					133	my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
415	1	50				14	return _ioError("opening $fileName for read") unless $status;
416
417	1					47	$status = $self->readFromFileHandle( $fh, $fileName );
418	1	50				14	return $status if $status != AZ_OK;
419
420	1					55	$fh->close();
421	1					39	$self->{'fileName'} = $fileName;
422	1					12	return AZ_OK;
423							}
424
425							sub readFromFileHandle {
426	1			1	1	11	my $self = shift;
427	1					28	my $fh = shift;
428	1					26	my $fileName = shift;
429	1	50				46	$fileName = $fh unless defined($fileName);
430	1	50				29	return _error('No filehandle given') unless $fh;
431	1	50				48	return _ioError('filehandle not open') unless $fh->opened();
432
433	1					25	_binmode($fh);
434	1					57	$self->{'fileName'} = "$fh";
435
436							# TODO: how to support non-seekable zips?
437	1	50				76	return _error('file not seekable')
438							unless _isSeekable($fh);
439
440	1					46	$fh->seek( 0, 0 ); # rewind the file
441
442	1					96	my $status = $self->_findEndOfCentralDirectory($fh);
443	1	50				13	return $status if $status != AZ_OK;
444
445	1					19	my $eocdPosition = $fh->tell();
446
447	1					24	$status = $self->_readEndOfCentralDirectory($fh);
448	1	50				28	return $status if $status != AZ_OK;
449
450	1	50				71	$fh->seek( $eocdPosition - $self->centralDirectorySize(),
451							IO::Seekable::SEEK_SET )
452							or return _ioError("Can't seek $fileName");
453
454							# Try to detect garbage at beginning of archives
455							# This should be 0
456	1					63	$self->{'eocdOffset'} = $eocdPosition - $self->centralDirectorySize() # here
457							- $self->centralDirectoryOffsetWRTStartingDiskNumber();
458
459	1					10	for ( ; ; ) {
460	6					247	my $newMember =
461							$self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName,
462							$self->eocdOffset() );
463	6					53	my $signature;
464	6					109	( $status, $signature ) = _readSignature( $fh, $fileName );
465	6	50				85	return $status if $status != AZ_OK;
466	6	100				63	last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
467	5					120	$status = $newMember->_readCentralDirectoryFileHeader();
468	5	50				78	return $status if $status != AZ_OK;
469	5					125	$status = $newMember->endRead();
470	5	50				85	return $status if $status != AZ_OK;
471	5					95	$newMember->_becomeDirectoryIfNecessary();
472	5					41	push( @{ $self->{'members'} }, $newMember );
	5					139
473							}
474
475	1					13	return AZ_OK;
476							}
477
478							# Read EOCD, starting from position before signature.
479							# Return AZ_OK on success.
480							sub _readEndOfCentralDirectory {
481	1			1		9	my $self = shift;
482	1					10	my $fh = shift;
483
484							# Skip past signature
485	1	50				12	$fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
486							or return _ioError("Can't seek past EOCD signature");
487
488	1					69	my $header = '';
489	1					35	my $bytesRead = $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH );
490	1	50				87	if ( $bytesRead != END_OF_CENTRAL_DIRECTORY_LENGTH ) {
491	0					0	return _ioError("reading end of central directory");
492							}
493
494	1					12	my $zipfileCommentLength;
495							(
496	1					95	$self->{'diskNumber'},
497							$self->{'diskNumberWithStartOfCentralDirectory'},
498							$self->{'numberOfCentralDirectoriesOnThisDisk'},
499							$self->{'numberOfCentralDirectories'},
500							$self->{'centralDirectorySize'},
501							$self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
502							$zipfileCommentLength
503							) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
504
505	1	50				15	if ($zipfileCommentLength) {
506	0					0	my $zipfileComment = '';
507	0					0	$bytesRead = $fh->read( $zipfileComment, $zipfileCommentLength );
508	0	0				0	if ( $bytesRead != $zipfileCommentLength ) {
509	0					0	return _ioError("reading zipfile comment");
510							}
511	0					0	$self->{'zipfileComment'} = $zipfileComment;
512							}
513
514	1					18	return AZ_OK;
515							}
516
517							# Seek in my file to the end, then read backwards until we find the
518							# signature of the central directory record. Leave the file positioned right
519							# before the signature. Returns AZ_OK if success.
520							sub _findEndOfCentralDirectory {
521	1			1		9	my $self = shift;
522	1					10	my $fh = shift;
523	1					10	my $data = '';
524	1	50				810	$fh->seek( 0, IO::Seekable::SEEK_END )
525							or return _ioError("seeking to end");
526
527	1					97	my $fileLength = $fh->tell();
528	1	50				24	if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 ) {
529	0					0	return _formatError("file is too short");
530							}
531
532	1					9	my $seekOffset = 0;
533	1					10	my $pos = -1;
534	1					9	for ( ; ; ) {
535	1					11	$seekOffset += 512;
536	1	50				12	$seekOffset = $fileLength if ( $seekOffset > $fileLength );
537	1	50				13	$fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
538							or return _ioError("seek failed");
539	1					90	my $bytesRead = $fh->read( $data, $seekOffset );
540	1	50				185	if ( $bytesRead != $seekOffset ) {
541	0					0	return _ioError("read failed");
542							}
543	1					19	$pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
544							last
545	1	50	33			60	if ( $pos >= 0
			33
546							or $seekOffset == $fileLength
547							or $seekOffset >= $Archive::Zip::ChunkSize );
548							}
549
550	1	50				14	if ( $pos >= 0 ) {
551	1	50				30	$fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
552							or return _ioError("seeking to EOCD");
553	1					39	return AZ_OK;
554							}
555							else {
556	0					0	return _formatError("can't find EOCD signature");
557							}
558							}
559
560							# Used to avoid taint problems when chdir'ing.
561							# Not intended to increase security in any way; just intended to shut up the -T
562							# complaints. If your Cwd module is giving you unreliable returns from cwd()
563							# you have bigger problems than this.
564							sub _untaintDir {
565	348			348		189600	my $dir = shift;
566	348					4361	$dir =~ m/\A(.+)\z/s;
567	348					7513	return $1;
568							}
569
570							sub addTree {
571	3			3	1	138	my $self = shift;
572	3	50				34	my $root = shift or return _error("root arg missing in call to addTree()");
573	3					27	my $dest = shift;
574	3	50				31	$dest = '' unless defined($dest);
575	3		50	0		52	my $pred = shift \|\| sub { -r };
	0					0
576	3					27	my @files;
577	3					121	my $startDir = _untaintDir( cwd() );
578
579	3	50				178	return _error( 'undef returned by _untaintDir on cwd ', cwd() )
580							unless $startDir;
581
582							# This avoids chdir'ing in Find, in a way compatible with older
583							# versions of File::Find.
584							my $wanted = sub {
585	292			292		27357	local $main::_ = $File::Find::name;
586	292					6722	my $dir = _untaintDir($File::Find::dir);
587	292					6674	chdir($startDir);
588	292	100				3092	push( @files, $File::Find::name ) if (&$pred);
589	292					12077	chdir($dir);
590	3					339	};
591
592	3					222	File::Find::find( $wanted, $root );
593
594	3					526	my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
595	3	100				132	my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
596
597	3					39	$dest = _asZipDirName( $dest, 1 ); # with trailing slash
598
599	3					102	foreach my $fileName (@files) {
600	21					415	my $isDir = -d $fileName;
601
602							# normalize, remove leading ./
603	21					250	my $archiveName = _asZipDirName( $fileName, $isDir );
604	21	50				208	if ( $archiveName eq $rootZipName ) { $archiveName = $dest }
	0					0
605	21					261	else { $archiveName =~ s{$pattern}{$dest} }
606	21	50				333	next if $archiveName =~ m{^\.?/?$}; # skip current dir
607	21	50				428	my $member = $isDir
608							? $self->addDirectory( $fileName, $archiveName )
609							: $self->addFile( $fileName, $archiveName );
610	21	50				238	return _error("add $fileName failed in addTree()") if !$member;
611							}
612	3					58	return AZ_OK;
613							}
614
615							sub addTreeMatching {
616	0			0	1	0	my $self = shift;
617	0	0				0	my $root = shift
618							or return _error("root arg missing in call to addTreeMatching()");
619	0					0	my $dest = shift;
620	0	0				0	$dest = '' unless defined($dest);
621	0	0				0	my $pattern = shift
622							or return _error("pattern missing in call to addTreeMatching()");
623	0					0	my $pred = shift;
624							my $matcher =
625	0	0		0		0	$pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
	0	0				0
	0	0				0
626	0					0	return $self->addTree( $root, $dest, $matcher );
627							}
628
629							# $zip->extractTree( $root, $dest [, $volume] );
630							#
631							# $root and $dest are Unix-style.
632							# $volume is in local FS format.
633							#
634							sub extractTree {
635	0			0	1	0	my $self = shift;
636	0					0	my $root = shift; # Zip format
637	0	0				0	$root = '' unless defined($root);
638	0					0	my $dest = shift; # Zip format
639	0	0				0	$dest = './' unless defined($dest);
640	0					0	my $volume = shift; # optional
641	0					0	my $pattern = "^\Q$root";
642	0					0	my @members = $self->membersMatching($pattern);
643
644	0					0	foreach my $member (@members) {
645	0					0	my $fileName = $member->fileName(); # in Unix format
646	0					0	$fileName =~ s{$pattern}{$dest}; # in Unix format
647							# convert to platform format:
648	0					0	$fileName = Archive::Zip::_asLocalName( $fileName, $volume );
649	0					0	my $status = $member->extractToFileNamed($fileName);
650	0	0				0	return $status if $status != AZ_OK;
651							}
652	0					0	return AZ_OK;
653							}
654
655							# $zip->updateMember( $memberOrName, $fileName );
656							# Returns (possibly updated) member, if any; undef on errors.
657
658							sub updateMember {
659	45			45	1	639	my $self = shift;
660	45					467	my $oldMember = shift;
661	45					446	my $fileName = shift;
662
663	45	50				1500	if ( !defined($fileName) ) {
664	0					0	_error("updateMember(): missing fileName argument");
665	0					0	return undef;
666							}
667
668	45					1290	my @newStat = stat($fileName);
669	45	50				1782	if ( !@newStat ) {
670	0					0	_ioError("Can't stat $fileName");
671	0					0	return undef;
672							}
673
674	45					425	my $isDir = -d _;
675
676	45					390	my $memberName;
677
678	45	50				608	if ( ref($oldMember) ) {
679	0					0	$memberName = $oldMember->fileName();
680							}
681							else {
682	45		66			855	$oldMember = $self->memberNamed( $memberName = $oldMember )
683							\|\| $self->memberNamed( $memberName =
684							_asZipDirName( $oldMember, $isDir ) );
685							}
686
687	45	100	100			1142	unless ( defined($oldMember)
			66
			33
			66
688							&& $oldMember->lastModTime() == $newStat[9]
689							&& $oldMember->isDirectory() == $isDir
690							&& ( $isDir \|\| ( $oldMember->uncompressedSize() == $newStat[7] ) ) )
691							{
692
693							# create the new member
694	42	100				1126	my $newMember = $isDir
695							? $self->ZIPMEMBERCLASS->newDirectoryNamed( $fileName, $memberName )
696							: $self->ZIPMEMBERCLASS->newFromFile( $fileName, $memberName );
697
698	42	50				442	unless ( defined($newMember) ) {
699	0					0	_error("creation of member $fileName failed in updateMember()");
700	0					0	return undef;
701							}
702
703							# replace old member or append new one
704	42	100				509	if ( defined($oldMember) ) {
705	30					551	$self->replaceMember( $oldMember, $newMember );
706							}
707	12					334	else { $self->addMember($newMember); }
708
709	42					1354	return $newMember;
710							}
711
712	3					40	return $oldMember;
713							}
714
715							# $zip->updateTree( $root, [ $dest, [ $pred [, $mirror]]] );
716							#
717							# This takes the same arguments as addTree, but first checks to see
718							# whether the file or directory already exists in the zip file.
719							#
720							# If the fourth argument $mirror is true, then delete all my members
721							# if corresponding files weren't found.
722
723							sub updateTree {
724	4			4	1	125	my $self = shift;
725	4	50				109	my $root = shift
726							or return _error("root arg missing in call to updateTree()");
727	4					36	my $dest = shift;
728	4	50				46	$dest = '' unless defined($dest);
729	4					51	$dest = _asZipDirName( $dest, 1 );
730	4		50	49		86	my $pred = shift \|\| sub { -r };
	49					1357
731	4					40	my $mirror = shift;
732
733	4					44	my $rootZipName = _asZipDirName( $root, 1 ); # with trailing slash
734	4	50				50	my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
735
736	4					34	my @files;
737	4					122	my $startDir = _untaintDir( cwd() );
738
739	4	50				431	return _error( 'undef returned by _untaintDir on cwd ', cwd() )
740							unless $startDir;
741
742							# This avoids chdir'ing in Find, in a way compatible with older
743							# versions of File::Find.
744							my $wanted = sub {
745	49			49		9314	local $main::_ = $File::Find::name;
746	49					599	my $dir = _untaintDir($File::Find::dir);
747	49					1252	chdir($startDir);
748	49	50				567	push( @files, $File::Find::name ) if (&$pred);
749	49					907	chdir($dir);
750	4					549	};
751
752	4					543	File::Find::find( $wanted, $root );
753
754							# Now @files has all the files that I could potentially be adding to
755							# the zip. Only add the ones that are necessary.
756							# For each file (updated or not), add its member name to @done.
757	4					615	my %done;
758	4					104	foreach my $fileName (@files) {
759	49					1054	my @newStat = stat($fileName);
760	49					715	my $isDir = -d _;
761
762							# normalize, remove leading ./
763	49					1127	my $memberName = _asZipDirName( $fileName, $isDir );
764	49	100				527	if ( $memberName eq $rootZipName ) { $memberName = $dest }
	4					38
765	45					667	else { $memberName =~ s{$pattern}{$dest} }
766	49	100				909	next if $memberName =~ m{^\.?/?$}; # skip current dir
767
768	45					841	$done{$memberName} = 1;
769	45					665	my $changedMember = $self->updateMember( $memberName, $fileName );
770	45	50				848	return _error("updateTree failed to update $fileName")
771							unless ref($changedMember);
772							}
773
774							# @done now has the archive names corresponding to all the found files.
775							# If we're mirroring, delete all those members that aren't in @done.
776	4	100				45	if ($mirror) {
777	1					110	foreach my $member ( $self->members() ) {
778	12	100				164	$self->removeMember($member)
779							unless $done{ $member->fileName() };
780							}
781							}
782
783	4					630	return AZ_OK;
784							}
785
786							1;
787