← Back to branch summary

~ubuntu-branches/ubuntu/vivid/libarchive-zip-perl/vivid-proposed

« back to all changes in this revision

Viewing changes to lib/Archive/Zip/Archive.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ernesto Hernández-Novich (USB)
  • Date: 2009-10-01 10:46:15 UTC
  • mfrom: (1.2.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20091001104615-vc511ocslcznks94
Tags: 1.30-1
http://bugs.debian.org/548963
http://bugs.debian.org/543659
* New upstream release (Closes: 548963).
* debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
  field (source stanza); Homepage field (source stanza);
  ${misc:Depends} to Depends: field. Changed: Maintainer set to Debian
  Perl Group <pkg-perl-maintainers@lists.alioth.debian.org> (was: Ben
  Burton <bab@debian.org>); Ben Burton <bab@debian.org> moved to
  Uploaders. Updated Standards-Version. Added myself in Uploaders.
  Added quilt to Build-Depends: field.
* debian/watch: use dist-based URL.
* debian/rules: delete /usr/lib/perl5 only if it exists.
* Added versioned dependencies on libcompress-raw-zlib-perl.
* Remove unneeded dependencies on libfile-which-perl.
* Added quilt patch to fix shebangs on example scripts (Closes: 543659).

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Archive/Zip/Archive.pm
13
13
use vars qw( $VERSION @ISA );
14
14
 
15
15
BEGIN {
16
 
    $VERSION = '1.18';
 
16
    $VERSION = '1.30';
17
17
    @ISA     = qw( Archive::Zip );
18
18
}
19
19
 
46
46
        $class
47
47
    );
48
48
    $self->{'members'} = [];
49
 
    if (@_) {
50
 
        my $status = $self->read(@_);
 
49
    my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift;
 
50
    if ($fileName) {
 
51
        my $status = $self->read($fileName);
51
52
        return $status == AZ_OK ? $self : undef;
52
53
    }
53
54
    return $self;
54
55
}
55
56
 
 
57
sub storeSymbolicLink {
 
58
    my $self = shift;
 
59
    $self->{'storeSymbolicLink'} = shift;
 
60
}
 
61
 
56
62
sub members {
57
63
    @{ shift->{'members'} };
58
64
}
68
74
 
69
75
# return ref to member with given name or undef
70
76
sub memberNamed {
71
 
    my ( $self, $fileName ) = @_;
 
77
    my $self     = shift;
 
78
    my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{zipName} : shift;
72
79
    foreach my $member ( $self->members() ) {
73
80
        return $member if $member->fileName() eq $fileName;
74
81
    }
76
83
}
77
84
 
78
85
sub membersMatching {
79
 
    my ( $self, $pattern ) = @_;
 
86
    my $self    = shift;
 
87
    my $pattern = ( ref( $_[0] ) eq 'HASH' ) ? shift->{regex} : shift;
80
88
    return grep { $_->fileName() =~ /$pattern/ } $self->members();
81
89
}
82
90
 
108
116
    my $self    = shift;
109
117
    my $comment = $self->{'zipfileComment'};
110
118
    if (@_) {
111
 
        $self->{'zipfileComment'} = pack( 'C0a*', shift() );    # avoid unicode
 
119
        my $new_comment = ( ref( $_[0] ) eq 'HASH' ) ? shift->{comment} : shift;
 
120
        $self->{'zipfileComment'} = pack( 'C0a*', $new_comment );    # avoid unicode
112
121
    }
113
122
    return $comment;
114
123
}
123
132
}
124
133
 
125
134
sub removeMember {
126
 
    my ( $self, $member ) = @_;
 
135
    my $self    = shift;
 
136
    my $member  = ( ref( $_[0] ) eq 'HASH' ) ? shift->{memberOrZipName} : shift;
127
137
    $member = $self->memberNamed($member) unless ref($member);
128
138
    return undef unless $member;
129
139
    my @newMembers = grep { $_ != $member } $self->members();
132
142
}
133
143
 
134
144
sub replaceMember {
135
 
    my ( $self, $oldMember, $newMember ) = @_;
 
145
    my $self = shift;
 
146
 
 
147
    my ( $oldMember, $newMember );
 
148
    if ( ref( $_[0] ) eq 'HASH' ) {
 
149
        $oldMember = $_[0]->{memberOrZipName};
 
150
        $newMember = $_[0]->{newMember};
 
151
    }
 
152
    else {
 
153
        ( $oldMember, $newMember ) = @_;
 
154
    }
 
155
 
136
156
    $oldMember = $self->memberNamed($oldMember) unless ref($oldMember);
137
157
    return undef unless $oldMember;
138
158
    return undef unless $newMember;
143
163
}
144
164
 
145
165
sub extractMember {
146
 
    my $self   = shift;
147
 
    my $member = shift;
 
166
    my $self = shift;
 
167
 
 
168
    my ( $member, $name );
 
169
    if ( ref( $_[0] ) eq 'HASH' ) {
 
170
        $member = $_[0]->{memberOrZipName};
 
171
        $name   = $_[0]->{name};
 
172
    }
 
173
    else {
 
174
        ( $member, $name ) = @_;
 
175
    }
 
176
 
148
177
    $member = $self->memberNamed($member) unless ref($member);
149
178
    return _error('member not found') unless $member;
150
179
    my $originalSize = $member->compressedSize();
151
 
    my $name         = shift;                       # local FS name if given
152
180
    my ( $volumeName, $dirName, $fileName );
153
181
    if ( defined($name) ) {
154
182
        ( $volumeName, $dirName, $fileName ) = File::Spec->splitpath($name);
172
200
}
173
201
 
174
202
sub extractMemberWithoutPaths {
175
 
    my $self   = shift;
176
 
    my $member = shift;
 
203
    my $self = shift;
 
204
 
 
205
    my ( $member, $name );
 
206
    if ( ref( $_[0] ) eq 'HASH' ) {
 
207
        $member = $_[0]->{memberOrZipName};
 
208
        $name   = $_[0]->{name};
 
209
    }
 
210
    else {
 
211
        ( $member, $name ) = @_;
 
212
    }
 
213
 
177
214
    $member = $self->memberNamed($member) unless ref($member);
178
215
    return _error('member not found') unless $member;
179
216
    my $originalSize = $member->compressedSize();
180
217
    return AZ_OK if $member->isDirectory();
181
 
    my $name = shift;
182
218
    unless ($name) {
183
219
        $name = $member->fileName();
184
220
        $name =~ s{.*/}{};    # strip off directories, if any
190
226
}
191
227
 
192
228
sub addMember {
193
 
    my ( $self, $newMember ) = @_;
 
229
    my $self       = shift;
 
230
    my $newMember  = ( ref( $_[0] ) eq 'HASH' ) ? shift->{member} : shift;
194
231
    push( @{ $self->{'members'} }, $newMember ) if $newMember;
195
232
    return $newMember;
196
233
}
197
234
 
198
235
sub addFile {
199
 
    my $self      = shift;
200
 
    my $fileName  = shift;
201
 
    my $newName   = shift;
 
236
    my $self = shift;
 
237
 
 
238
    my ( $fileName, $newName, $compressionLevel );
 
239
    if ( ref( $_[0] ) eq 'HASH' ) {
 
240
        $fileName         = $_[0]->{filename};
 
241
        $newName          = $_[0]->{zipName};
 
242
        $compressionLevel = $_[0]->{compressionLevel};
 
243
    }
 
244
    else {
 
245
        ( $fileName, $newName, $compressionLevel ) = @_;
 
246
    }
 
247
 
202
248
    my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName, $newName );
203
 
    $self->addMember($newMember) if defined($newMember);
 
249
    $newMember->desiredCompressionLevel($compressionLevel);
 
250
    if ( $self->{'storeSymbolicLink'} && -l $fileName ) {
 
251
        my $newMember = $self->ZIPMEMBERCLASS->newFromString(readlink $fileName, $newName);
 
252
        # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
 
253
        $newMember->{'externalFileAttributes'} = 0xA1FF0000;
 
254
        $self->addMember($newMember);
 
255
    } else {
 
256
        $self->addMember($newMember);
 
257
    }
204
258
    return $newMember;
205
259
}
206
260
 
207
261
sub addString {
208
 
    my $self      = shift;
209
 
    my $newMember = $self->ZIPMEMBERCLASS->newFromString(@_);
 
262
    my $self = shift;
 
263
 
 
264
    my ( $stringOrStringRef, $name, $compressionLevel );
 
265
    if ( ref( $_[0] ) eq 'HASH' ) {
 
266
        $stringOrStringRef = $_[0]->{string};
 
267
        $name              = $_[0]->{zipName};
 
268
        $compressionLevel  = $_[0]->{compressionLevel};
 
269
    }
 
270
    else {
 
271
        ( $stringOrStringRef, $name, $compressionLevel ) = @_;;
 
272
    }
 
273
 
 
274
    my $newMember = $self->ZIPMEMBERCLASS->newFromString(
 
275
        $stringOrStringRef, $name
 
276
    );
 
277
    $newMember->desiredCompressionLevel($compressionLevel);
210
278
    return $self->addMember($newMember);
211
279
}
212
280
 
213
281
sub addDirectory {
214
 
    my ( $self, $name, $newName ) = @_;
 
282
    my $self = shift;
 
283
 
 
284
    my ( $name, $newName );
 
285
    if ( ref( $_[0] ) eq 'HASH' ) {
 
286
        $name    = $_[0]->{directoryName};
 
287
        $newName = $_[0]->{zipName};
 
288
    }
 
289
    else {
 
290
        ( $name, $newName ) = @_;
 
291
    }
 
292
 
215
293
    my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name, $newName );
216
 
    $self->addMember($newMember);
 
294
    if ( $self->{'storeSymbolicLink'} && -l $name ) {
 
295
        my $link = readlink $name;
 
296
        ( $newName =~ s{/$}{} ) if $newName; # Strip trailing /
 
297
        my $newMember = $self->ZIPMEMBERCLASS->newFromString($link, $newName);
 
298
        # For symbolic links, External File Attribute is set to 0xA1FF0000 by Info-ZIP
 
299
        $newMember->{'externalFileAttributes'} = 0xA1FF0000;
 
300
        $self->addMember($newMember);
 
301
    } else {
 
302
        $self->addMember($newMember);
 
303
    }
217
304
    return $newMember;
218
305
}
219
306
 
220
307
# add either a file or a directory.
221
308
 
222
309
sub addFileOrDirectory {
223
 
    my ( $self, $name, $newName ) = @_;
 
310
    my $self = shift;
 
311
 
 
312
    my ( $name, $newName, $compressionLevel );
 
313
    if ( ref( $_[0] ) eq 'HASH' ) {
 
314
        $name             = $_[0]->{name};
 
315
        $newName          = $_[0]->{zipName};
 
316
        $compressionLevel = $_[0]->{compressionLevel};
 
317
    }
 
318
    else {
 
319
        ( $name, $newName, $compressionLevel ) = @_;
 
320
    }
 
321
 
 
322
    $name =~ s{/$}{};
 
323
    if ( $newName ) {
 
324
        $newName =~ s{/$}{};
 
325
    } else {
 
326
        $newName = $name;
 
327
    }
224
328
    if ( -f $name ) {
225
 
        ( $newName =~ s{/$}{} ) if $newName;
226
 
        return $self->addFile( $name, $newName );
 
329
        return $self->addFile( $name, $newName, $compressionLevel );
227
330
    }
228
331
    elsif ( -d $name ) {
229
 
        ( $newName =~ s{[^/]$}{&/} ) if $newName;
230
332
        return $self->addDirectory( $name, $newName );
231
333
    }
232
334
    else {
235
337
}
236
338
 
237
339
sub contents {
238
 
    my ( $self, $member, $newContents ) = @_;
 
340
    my $self = shift;
 
341
 
 
342
    my ( $member, $newContents );
 
343
    if ( ref( $_[0] ) eq 'HASH' ) {
 
344
        $member      = $_[0]->{memberOrZipName};
 
345
        $newContents = $_[0]->{contents};
 
346
    }
 
347
    else {
 
348
        ( $member, $newContents ) = @_;
 
349
    }
 
350
 
239
351
    return _error('No member name given') unless $member;
240
352
    $member = $self->memberNamed($member) unless ref($member);
241
353
    return undef unless $member;
243
355
}
244
356
 
245
357
sub writeToFileNamed {
246
 
    my $self     = shift;
247
 
    my $fileName = shift;    # local FS format
 
358
    my $self = shift;
 
359
    my $fileName =
 
360
      ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift;  # local FS format
248
361
    foreach my $member ( $self->members() ) {
249
362
        if ( $member->_usesFileNamed($fileName) ) {
250
363
            return _error( "$fileName is needed by member "
265
378
# perhaps to make a self-extracting archive.
266
379
sub writeToFileHandle {
267
380
    my $self = shift;
268
 
    my $fh   = shift;
 
381
 
 
382
    my ( $fh, $fhIsSeekable );
 
383
    if ( ref( $_[0] ) eq 'HASH' ) {
 
384
        $fh           = $_[0]->{fileHandle};
 
385
        $fhIsSeekable =
 
386
          exists( $_[0]->{seek} ) ? $_[0]->{seek} : _isSeekable($fh);
 
387
    }
 
388
    else {
 
389
        $fh           = shift;
 
390
        $fhIsSeekable = @_ ? shift : _isSeekable($fh);
 
391
    }
 
392
 
269
393
    return _error('No filehandle given')   unless $fh;
270
394
    return _ioError('filehandle not open') unless $fh->opened();
271
 
 
272
 
    my $fhIsSeekable = @_ ? shift: _isSeekable($fh);
273
395
    _binmode($fh);
274
396
 
275
397
    # Find out where the current position is.
276
398
    my $offset = $fhIsSeekable ? $fh->tell() : 0;
277
 
    $offset = 0 if $offset < 0;
 
399
    $offset    = 0 if $offset < 0;
278
400
 
279
401
    foreach my $member ( $self->members() ) {
280
402
        my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable, $offset );
305
427
# Returns AZ_OK if successful.
306
428
sub overwriteAs {
307
429
    my $self    = shift;
308
 
    my $zipName = shift;
 
430
    my $zipName = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{filename} : shift;
309
431
    return _error("no filename in overwriteAs()") unless defined($zipName);
310
432
 
311
433
    my ( $fh, $tempName ) = Archive::Zip::tempFile();
362
484
sub _writeEndOfCentralDirectory {
363
485
    my ( $self, $fh ) = @_;
364
486
 
365
 
    $fh->print(END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
 
487
    $self->_print($fh, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING)
366
488
      or return _ioError('writing EOCD Signature');
367
489
    my $zipfileCommentLength = length( $self->zipfileComment() );
368
490
 
376
498
        $self->_writeCentralDirectoryOffset(),
377
499
        $zipfileCommentLength
378
500
    );
379
 
    $fh->print($header)
 
501
    $self->_print($fh, $header)
380
502
      or return _ioError('writing EOCD header');
381
503
    if ($zipfileCommentLength) {
382
 
        $fh->print( $self->zipfileComment() )
 
504
        $self->_print($fh,  $self->zipfileComment() )
383
505
          or return _ioError('writing zipfile comment');
384
506
    }
385
507
    return AZ_OK;
387
509
 
388
510
# $offset can be specified to truncate a zip file.
389
511
sub writeCentralDirectory {
390
 
    my ( $self, $fh, $offset ) = @_;
 
512
    my $self = shift;
 
513
 
 
514
    my ( $fh, $offset );
 
515
    if ( ref( $_[0] ) eq 'HASH' ) {
 
516
        $fh     = $_[0]->{fileHandle};
 
517
        $offset = $_[0]->{offset};
 
518
    }
 
519
    else {
 
520
        ( $fh, $offset ) = @_;
 
521
    }
391
522
 
392
523
    if ( defined($offset) ) {
393
524
        $self->{'writeCentralDirectoryOffset'} = $offset;
409
540
 
410
541
sub read {
411
542
    my $self     = shift;
412
 
    my $fileName = shift;
 
543
    my $fileName = ( ref( $_[0] ) eq 'HASH' ) ? shift->{filename} : shift;
413
544
    return _error('No filename given') unless $fileName;
414
545
    my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
415
546
    return _ioError("opening $fileName for read") unless $status;
423
554
}
424
555
 
425
556
sub readFromFileHandle {
426
 
    my $self     = shift;
427
 
    my $fh       = shift;
428
 
    my $fileName = shift;
 
557
    my $self = shift;
 
558
 
 
559
    my ( $fh, $fileName );
 
560
    if ( ref( $_[0] ) eq 'HASH' ) {
 
561
        $fh       = $_[0]->{fileHandle};
 
562
        $fileName = $_[0]->{filename};
 
563
    }
 
564
    else {
 
565
        ( $fh, $fileName ) = @_;
 
566
    }
 
567
 
429
568
    $fileName = $fh unless defined($fileName);
430
569
    return _error('No filehandle given')   unless $fh;
431
570
    return _ioError('filehandle not open') unless $fh->opened();
569
708
 
570
709
sub addTree {
571
710
    my $self = shift;
572
 
    my $root = shift or return _error("root arg missing in call to addTree()");
573
 
    my $dest = shift;
 
711
 
 
712
    my ( $root, $dest, $pred, $compressionLevel );
 
713
    if ( ref( $_[0] ) eq 'HASH' ) {
 
714
        $root             = $_[0]->{root};
 
715
        $dest             = $_[0]->{zipName};
 
716
        $pred             = $_[0]->{select};
 
717
        $compressionLevel = $_[0]->{compressionLevel};
 
718
    }
 
719
    else {
 
720
        ( $root, $dest, $pred, $compressionLevel ) = @_;
 
721
    }
 
722
 
 
723
    return _error("root arg missing in call to addTree()")
 
724
      unless defined($root);
574
725
    $dest = '' unless defined($dest);
575
 
    my $pred = shift || sub { -r };
 
726
    $pred = sub { -r } unless defined($pred);
 
727
 
576
728
    my @files;
577
729
    my $startDir = _untaintDir( cwd() );
578
730
 
607
759
        my $member = $isDir
608
760
          ? $self->addDirectory( $fileName, $archiveName )
609
761
          : $self->addFile( $fileName, $archiveName );
 
762
        $member->desiredCompressionLevel($compressionLevel);
 
763
 
610
764
        return _error("add $fileName failed in addTree()") if !$member;
611
765
    }
612
766
    return AZ_OK;
614
768
 
615
769
sub addTreeMatching {
616
770
    my $self = shift;
617
 
    my $root = shift
618
 
      or return _error("root arg missing in call to addTreeMatching()");
619
 
    my $dest = shift;
 
771
 
 
772
    my ( $root, $dest, $pattern, $pred, $compressionLevel );
 
773
    if ( ref( $_[0] ) eq 'HASH' ) {
 
774
        $root             = $_[0]->{root};
 
775
        $dest             = $_[0]->{zipName};
 
776
        $pattern          = $_[0]->{pattern};
 
777
        $pred             = $_[0]->{select};
 
778
        $compressionLevel = $_[0]->{compressionLevel};
 
779
    }
 
780
    else {
 
781
        ( $root, $dest, $pattern, $pred, $compressionLevel ) = @_;
 
782
    }
 
783
 
 
784
    return _error("root arg missing in call to addTreeMatching()")
 
785
      unless defined($root);
620
786
    $dest = '' unless defined($dest);
621
 
    my $pattern = shift
622
 
      or return _error("pattern missing in call to addTreeMatching()");
623
 
    my $pred = shift;
 
787
    return _error("pattern missing in call to addTreeMatching()")
 
788
      unless defined($pattern);
624
789
    my $matcher =
625
790
      $pred ? sub { m{$pattern} && &$pred } : sub { m{$pattern} && -r };
626
 
    return $self->addTree( $root, $dest, $matcher );
 
791
    return $self->addTree( $root, $dest, $matcher, $compressionLevel );
627
792
}
628
793
 
629
794
# $zip->extractTree( $root, $dest [, $volume] );
633
798
#
634
799
sub extractTree {
635
800
    my $self = shift;
636
 
    my $root = shift;    # Zip format
 
801
 
 
802
    my ( $root, $dest, $volume );
 
803
    if ( ref( $_[0] ) eq 'HASH' ) {
 
804
        $root   = $_[0]->{root};
 
805
        $dest   = $_[0]->{zipName};
 
806
        $volume = $_[0]->{volume};
 
807
    }
 
808
    else {
 
809
        ( $root, $dest, $volume ) = @_;
 
810
    }
 
811
 
637
812
    $root = '' unless defined($root);
638
 
    my $dest = shift;    # Zip format
639
813
    $dest = './' unless defined($dest);
640
 
    my $volume  = shift;                              # optional
641
814
    my $pattern = "^\Q$root";
642
815
    my @members = $self->membersMatching($pattern);
643
816
 
656
829
# Returns (possibly updated) member, if any; undef on errors.
657
830
 
658
831
sub updateMember {
659
 
    my $self      = shift;
660
 
    my $oldMember = shift;
661
 
    my $fileName  = shift;
 
832
    my $self = shift;
 
833
 
 
834
    my ( $oldMember, $fileName );
 
835
    if ( ref( $_[0] ) eq 'HASH' ) {
 
836
        $oldMember = $_[0]->{memberOrZipName};
 
837
        $fileName  = $_[0]->{name};
 
838
    }
 
839
    else {
 
840
        ( $oldMember, $fileName ) = @_;
 
841
    }
662
842
 
663
843
    if ( !defined($fileName) ) {
664
844
        _error("updateMember(): missing fileName argument");
722
902
 
723
903
sub updateTree {
724
904
    my $self = shift;
725
 
    my $root = shift
726
 
      or return _error("root arg missing in call to updateTree()");
727
 
    my $dest = shift;
 
905
 
 
906
    my ( $root, $dest, $pred, $mirror, $compressionLevel );
 
907
    if ( ref( $_[0] ) eq 'HASH' ) {
 
908
        $root             = $_[0]->{root};
 
909
        $dest             = $_[0]->{zipName};
 
910
        $pred             = $_[0]->{select};
 
911
        $mirror           = $_[0]->{mirror};
 
912
        $compressionLevel = $_[0]->{compressionLevel};
 
913
    }
 
914
    else {
 
915
        ( $root, $dest, $pred, $mirror, $compressionLevel ) = @_;
 
916
    }
 
917
 
 
918
    return _error("root arg missing in call to updateTree()")
 
919
      unless defined($root);
728
920
    $dest = '' unless defined($dest);
 
921
    $pred = sub { -r } unless defined($pred);
 
922
 
729
923
    $dest = _asZipDirName( $dest, 1 );
730
 
    my $pred = shift || sub { -r };
731
 
    my $mirror = shift;
732
 
 
733
924
    my $rootZipName = _asZipDirName( $root, 1 );    # with trailing slash
734
925
    my $pattern = $rootZipName eq './' ? '^' : "^\Q$rootZipName\E";
735
926
 
767
958
 
768
959
        $done{$memberName} = 1;
769
960
        my $changedMember = $self->updateMember( $memberName, $fileName );
 
961
        $changedMember->desiredCompressionLevel($compressionLevel);
770
962
        return _error("updateTree failed to update $fileName")
771
963
          unless ref($changedMember);
772
964
    }