← 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/Member.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/Member.pm
6
6
use vars qw( $VERSION @ISA );
7
7
 
8
8
BEGIN {
9
 
    $VERSION = '1.18';
 
9
    $VERSION = '1.30';
10
10
    @ISA     = qw( Archive::Zip );
11
11
}
12
12
 
19
19
);
20
20
 
21
21
use Time::Local ();
22
 
use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
 
22
use Compress::Raw::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
23
23
use File::Path;
24
24
use File::Basename;
25
25
 
45
45
 
46
46
sub newFromString {
47
47
    my $class = shift;
48
 
    my $self  = $class->STRINGMEMBERCLASS->_newFromString(@_);
 
48
 
 
49
    my ( $stringOrStringRef, $fileName );
 
50
    if ( ref( $_[0] ) eq 'HASH' ) {
 
51
        $stringOrStringRef = $_[0]->{string};
 
52
        $fileName          = $_[0]->{zipName};
 
53
    }
 
54
    else {
 
55
        ( $stringOrStringRef, $fileName ) = @_;
 
56
    }
 
57
 
 
58
    my $self  = $class->STRINGMEMBERCLASS->_newFromString( $stringOrStringRef,
 
59
        $fileName );
49
60
    return $self;
50
61
}
51
62
 
52
63
sub newFromFile {
53
64
    my $class = shift;
54
 
    my $self  = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
 
65
 
 
66
    my ( $fileName, $zipName );
 
67
    if ( ref( $_[0] ) eq 'HASH' ) {
 
68
        $fileName = $_[0]->{fileName};
 
69
        $zipName  = $_[0]->{zipName};
 
70
    }
 
71
    else {
 
72
        ( $fileName, $zipName ) = @_;
 
73
    }
 
74
 
 
75
    my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed( $fileName,
 
76
      $zipName );
55
77
    return $self;
56
78
}
57
79
 
58
80
sub newDirectoryNamed {
59
81
    my $class = shift;
60
 
    my $self  = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
 
82
 
 
83
    my ( $directoryName, $newName );
 
84
    if ( ref( $_[0] ) eq 'HASH' ) {
 
85
        $directoryName = $_[0]->{directoryName};
 
86
        $newName       = $_[0]->{zipName};
 
87
    }
 
88
    else {
 
89
        ( $directoryName, $newName ) = @_;
 
90
    }
 
91
 
 
92
    my $self  = $class->DIRECTORYMEMBERCLASS->_newNamed( $directoryName,
 
93
        $newName );
61
94
    return $self;
62
95
}
63
96
 
81
114
        'crc32'                    => 0,
82
115
        'compressedSize'           => 0,
83
116
        'uncompressedSize'         => 0,
 
117
        'isSymbolicLink'           => 0,
84
118
        @_
85
119
    };
86
120
    bless( $self, $class );
105
139
}
106
140
 
107
141
sub fileAttributeFormat {
108
 
    ( $#_ > 0 )
109
 
      ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
110
 
      : $_[0]->{'fileAttributeFormat'};
 
142
    my $self = shift;
 
143
 
 
144
    if (@_) {
 
145
        $self->{fileAttributeFormat} = ( ref( $_[0] ) eq 'HASH' )
 
146
        ? $_[0]->{format} : $_[0];
 
147
    }
 
148
    else {
 
149
        return $self->{fileAttributeFormat};
 
150
    }
111
151
}
112
152
 
113
153
sub versionNeededToExtract {
115
155
}
116
156
 
117
157
sub bitFlag {
118
 
    shift->{'bitFlag'};
 
158
    my $self = shift;
 
159
 
 
160
    # Set General Purpose Bit Flags according to the desiredCompressionLevel setting
 
161
    if ( $self->desiredCompressionLevel == 1 || $self->desiredCompressionLevel == 2 ) {
 
162
        $self->{'bitFlag'} = DEFLATING_COMPRESSION_FAST;
 
163
    } elsif ( $self->desiredCompressionLevel == 3 || $self->desiredCompressionLevel == 4
 
164
          || $self->desiredCompressionLevel == 5 || $self->desiredCompressionLevel == 6
 
165
          || $self->desiredCompressionLevel == 7 ) {
 
166
        $self->{'bitFlag'} = DEFLATING_COMPRESSION_NORMAL;
 
167
    } elsif ( $self->desiredCompressionLevel == 8 || $self->desiredCompressionLevel == 9 ) {
 
168
        $self->{'bitFlag'} = DEFLATING_COMPRESSION_MAXIMUM;
 
169
    }
 
170
    $self->{'bitFlag'};
119
171
}
120
172
 
121
173
sub compressionMethod {
123
175
}
124
176
 
125
177
sub desiredCompressionMethod {
126
 
    my $self                        = shift;
127
 
    my $newDesiredCompressionMethod = shift;
 
178
    my $self = shift;
 
179
    my $newDesiredCompressionMethod =
 
180
      ( ref( $_[0] ) eq 'HASH' ) ? shift->{compressionMethod} : shift;
128
181
    my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
129
182
    if ( defined($newDesiredCompressionMethod) ) {
130
183
        $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
131
184
        if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) {
132
185
            $self->{'desiredCompressionLevel'} = 0;
133
 
        }
134
 
        elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) {
 
186
            $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK;
 
187
 
 
188
        } elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) {
135
189
            $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
136
190
        }
137
191
    }
139
193
}
140
194
 
141
195
sub desiredCompressionLevel {
142
 
    my $self                       = shift;
143
 
    my $newDesiredCompressionLevel = shift;
 
196
    my $self = shift;
 
197
    my $newDesiredCompressionLevel =
 
198
      ( ref( $_[0] ) eq 'HASH' ) ? shift->{compressionLevel} : shift;
144
199
    my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
145
200
    if ( defined($newDesiredCompressionLevel) ) {
146
201
        $self->{'desiredCompressionLevel'}  = $newDesiredCompressionLevel;
189
244
}
190
245
 
191
246
# Convert UNIX permissions into proper value for zip file
192
 
# NOT A METHOD!
 
247
# Usable as a function or a method
193
248
sub _mapPermissionsFromUnix {
194
 
    my $perms = shift;
195
 
    return $perms << 16;
196
 
 
197
 
    # TODO: map MS-DOS perms too (RHSA?)
 
249
    my $self    = shift;
 
250
    my $mode    = shift;
 
251
    my $attribs = $mode << 16;
 
252
 
 
253
    # Microsoft Windows Explorer needs this bit set for directories
 
254
    if ( $mode & DIRECTORY_ATTRIB ) {
 
255
        $attribs |= 16;
 
256
    }
 
257
 
 
258
    return $attribs;
 
259
 
 
260
    # TODO: map more MS-DOS perms
198
261
}
199
262
 
200
263
# Convert ZIP permissions into Unix ones
284
347
 
285
348
sub unixFileAttributes {
286
349
    my $self     = shift;
287
 
    my $oldPerms = $self->_mapPermissionsToUnix();
288
 
    if (@_) {
289
 
        my $perms = shift;
290
 
        if ( $self->isDirectory() ) {
 
350
    my $oldPerms = $self->_mapPermissionsToUnix;
 
351
 
 
352
    my $perms;
 
353
    if ( @_ ) {
 
354
        $perms = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{attributes} : $_[0];
 
355
 
 
356
        if ( $self->isDirectory ) {
291
357
            $perms &= ~FILE_ATTRIB;
292
358
            $perms |= DIRECTORY_ATTRIB;
293
 
        }
294
 
        else {
 
359
        } else {
295
360
            $perms &= ~DIRECTORY_ATTRIB;
296
361
            $perms |= FILE_ATTRIB;
297
362
        }
298
 
        $self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
 
363
        $self->{externalFileAttributes} = $self->_mapPermissionsFromUnix($perms);
299
364
    }
 
365
 
300
366
    return $oldPerms;
301
367
}
302
368
 
303
369
sub localExtraField {
304
 
    ( $#_ > 0 )
305
 
      ? ( $_[0]->{'localExtraField'} = $_[1] )
306
 
      : $_[0]->{'localExtraField'};
 
370
    my $self = shift;
 
371
 
 
372
    if (@_) {
 
373
        $self->{localExtraField} = ( ref( $_[0] ) eq 'HASH' )
 
374
          ? $_[0]->{field} : $_[0];
 
375
    }
 
376
    else {
 
377
        return $self->{localExtraField};
 
378
    }
307
379
}
308
380
 
309
381
sub cdExtraField {
310
 
    ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) : $_[0]->{'cdExtraField'};
 
382
    my $self = shift;
 
383
 
 
384
    if (@_) {
 
385
        $self->{cdExtraField} = ( ref( $_[0] ) eq 'HASH' )
 
386
          ? $_[0]->{field} : $_[0];
 
387
    }
 
388
    else {
 
389
        return $self->{cdExtraField};
 
390
    }
311
391
}
312
392
 
313
393
sub extraFields {
316
396
}
317
397
 
318
398
sub fileComment {
319
 
    ( $#_ > 0 )
320
 
      ? ( $_[0]->{'fileComment'} = pack( 'C0a*', $_[1] ) )
321
 
      : $_[0]->{'fileComment'};
 
399
    my $self = shift;
 
400
 
 
401
    if (@_) {
 
402
        $self->{fileComment} = ( ref( $_[0] ) eq 'HASH' )
 
403
          ? pack( 'C0a*', $_[0]->{comment} ) : pack( 'C0a*', $_[0] );
 
404
    }
 
405
    else {
 
406
        return $self->{fileComment};
 
407
    }
322
408
}
323
409
 
324
410
sub hasDataDescriptor {
359
445
    my $self = shift;
360
446
    my $bit  = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
361
447
    if (@_) {
362
 
        my $flag = shift;
 
448
        my $flag = ( ref( $_[0] ) eq 'HASH' ) ? shift->{flag} : shift;
363
449
        $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
364
450
        $self->{'internalFileAttributes'} |=
365
451
          ( $flag ? IFA_TEXT_FILE: IFA_BINARY_FILE );
381
467
 
382
468
sub extractToFileNamed {
383
469
    my $self = shift;
384
 
    my $name = shift;    # local FS name
385
 
    return _error("encryption unsupported") if $self->isEncrypted();
386
 
    mkpath( dirname($name) );    # croaks on error
387
 
    my ( $status, $fh ) = _newFileHandle( $name, 'w' );
388
 
    return _ioError("Can't open file $name for write") unless $status;
 
470
 
 
471
    # local FS name
 
472
    my $name = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{name} : $_[0];
 
473
    $self->{'isSymbolicLink'} = 0;
 
474
 
 
475
    # Check if the file / directory is a symbolic link or not
 
476
    if ( $self->{'externalFileAttributes'} == 0xA1FF0000 ) {
 
477
        $self->{'isSymbolicLink'} = 1;
 
478
        $self->{'newName'} = $name;
 
479
        my ( $status, $fh ) = _newFileHandle( $name, 'r' );
 
480
        my $retval = $self->extractToFileHandle($fh);
 
481
        $fh->close();
 
482
    } else {
 
483
        #return _writeSymbolicLink($self, $name) if $self->isSymbolicLink();
 
484
        return _error("encryption unsupported") if $self->isEncrypted();
 
485
        mkpath( dirname($name) );    # croaks on error
 
486
        my ( $status, $fh ) = _newFileHandle( $name, 'w' );
 
487
        return _ioError("Can't open file $name for write") unless $status;
 
488
        my $retval = $self->extractToFileHandle($fh);
 
489
        $fh->close();
 
490
        chmod ($self->unixFileAttributes(), $name)
 
491
            or return _error("Can't chmod() ${name}: $!");
 
492
        utime( $self->lastModTime(), $self->lastModTime(), $name );
 
493
        return $retval;
 
494
    }
 
495
}
 
496
 
 
497
sub _writeSymbolicLink {
 
498
    my $self = shift;
 
499
    my $name = shift;
 
500
    my $chunkSize = $Archive::Zip::ChunkSize;
 
501
    #my ( $outRef, undef ) = $self->readChunk($chunkSize);
 
502
    my $fh;
389
503
    my $retval = $self->extractToFileHandle($fh);
390
 
    $fh->close();
391
 
    utime( $self->lastModTime(), $self->lastModTime(), $name );
392
 
    return $retval;
 
504
    my ( $outRef, undef ) = $self->readChunk(100);
 
505
}
 
506
 
 
507
sub isSymbolicLink {
 
508
    my $self = shift;
 
509
    if ( $self->{'externalFileAttributes'} == 0xA1FF0000 ) {
 
510
        $self->{'isSymbolicLink'} = 1;
 
511
    } else {
 
512
        return 0;
 
513
    }
 
514
    1;
393
515
}
394
516
 
395
517
sub isDirectory {
511
633
    my $fh   = shift;
512
634
 
513
635
    my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
514
 
    $fh->print($signatureData)
 
636
    $self->_print($fh, $signatureData)
515
637
      or return _ioError("writing local header signature");
516
638
 
517
639
    my $header = pack(
527
649
        length( $self->localExtraField() )
528
650
    );
529
651
 
530
 
    $fh->print($header) or return _ioError("writing local header");
531
 
    if ( $self->fileName() ) {
532
 
        $fh->print( $self->fileName() )
 
652
    $self->_print($fh, $header) or return _ioError("writing local header");
 
653
 
 
654
    # Check for a valid filename or a filename equal to a literal `0'
 
655
    if ( $self->fileName() || $self->fileName eq '0' ) {
 
656
        $self->_print($fh, $self->fileName() )
533
657
          or return _ioError("writing local header filename");
534
658
    }
535
659
    if ( $self->localExtraField() ) {
536
 
        $fh->print( $self->localExtraField() )
 
660
        $self->_print($fh, $self->localExtraField() )
537
661
          or return _ioError("writing local extra field");
538
662
    }
539
663
 
546
670
 
547
671
    my $sigData =
548
672
      pack( SIGNATURE_FORMAT, CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
549
 
    $fh->print($sigData)
 
673
    $self->_print($fh, $sigData)
550
674
      or return _ioError("writing central directory header signature");
551
675
 
552
676
    my $fileNameLength    = length( $self->fileName() );
573
697
        $self->writeLocalHeaderRelativeOffset()
574
698
    );
575
699
 
576
 
    $fh->print($header)
 
700
    $self->_print($fh, $header)
577
701
      or return _ioError("writing central directory header");
578
702
    if ($fileNameLength) {
579
 
        $fh->print( $self->fileName() )
 
703
        $self->_print($fh,  $self->fileName() )
580
704
          or return _ioError("writing central directory header signature");
581
705
    }
582
706
    if ($extraFieldLength) {
583
 
        $fh->print( $self->cdExtraField() )
 
707
        $self->_print($fh,  $self->cdExtraField() )
584
708
          or return _ioError("writing central directory extra field");
585
709
    }
586
710
    if ($fileCommentLength) {
587
 
        $fh->print( $self->fileComment() )
 
711
        $self->_print($fh,  $self->fileComment() )
588
712
          or return _ioError("writing central directory file comment");
589
713
    }
590
714
 
607
731
        $self->uncompressedSize()
608
732
    );
609
733
 
610
 
    $fh->print($header)
 
734
    $self->_print($fh, $header)
611
735
      or return _ioError("writing data descriptor");
612
736
    return AZ_OK;
613
737
}
637
761
        length( $self->localExtraField() )
638
762
    );
639
763
 
640
 
    $fh->print($header)
 
764
    $self->_print($fh, $header)
641
765
      or return _ioError("re-writing local header");
642
766
    $fh->seek( $here, IO::Seekable::SEEK_SET )
643
767
      or return _ioError("seeking after rewrite of local header");
646
770
}
647
771
 
648
772
sub readChunk {
649
 
    my ( $self, $chunkSize ) = @_;
 
773
    my $self = shift;
 
774
    my $chunkSize = ( ref( $_[0] ) eq 'HASH' ) ? $_[0]->{chunkSize} : $_[0];
650
775
 
651
776
    if ( $self->readIsDone() ) {
652
777
        $self->endRead();
703
828
# ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
704
829
sub _deflateChunk {
705
830
    my ( $self, $buffer ) = @_;
706
 
    my ( $out,  $status ) = $self->_deflater()->deflate($buffer);
 
831
    my ( $status ) = $self->_deflater()->deflate( $buffer, my $out );
707
832
 
708
833
    if ( $self->_readDataRemaining() == 0 ) {
709
834
        my $extraOutput;
710
 
        ( $extraOutput, $status ) = $self->_deflater()->flush();
 
835
        ( $status ) = $self->_deflater()->flush($extraOutput);
711
836
        $out .= $extraOutput;
712
837
        $self->endRead();
713
838
        return ( \$out, AZ_STREAM_END );
726
851
# ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
727
852
sub _inflateChunk {
728
853
    my ( $self, $buffer ) = @_;
729
 
    my ( $out,  $status ) = $self->_inflater()->inflate($buffer);
 
854
    my ( $status ) = $self->_inflater()->inflate( $buffer, my $out );
730
855
    my $retval;
731
856
    $self->endRead() unless $status == Z_OK;
732
857
    if ( $status == Z_OK || $status == Z_STREAM_END ) {
759
884
    if (    $self->compressionMethod() == COMPRESSION_STORED
760
885
        and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
761
886
    {
762
 
        ( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
 
887
        ( $self->{'deflater'}, $status ) = Compress::Raw::Zlib::Deflate->new(
763
888
            '-Level'      => $self->desiredCompressionLevel(),
764
889
            '-WindowBits' => -MAX_WBITS(),                     # necessary magic
765
890
            '-Bufsize'    => $Archive::Zip::ChunkSize,
772
897
    elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
773
898
        and $self->desiredCompressionMethod() == COMPRESSION_STORED )
774
899
    {
775
 
        ( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
 
900
        ( $self->{'inflater'}, $status ) = Compress::Raw::Zlib::Inflate->new(
776
901
            '-WindowBits' => -MAX_WBITS(),               # necessary magic
777
902
            '-Bufsize'    => $Archive::Zip::ChunkSize,
778
903
            @_
859
984
sub extractToFileHandle {
860
985
    my $self = shift;
861
986
    return _error("encryption unsupported") if $self->isEncrypted();
862
 
    my $fh = shift;
 
987
    my $fh = ( ref( $_[0] ) eq 'HASH' ) ? shift->{fileHandle} : shift;
863
988
    _binmode($fh);
864
989
    my $oldCompression = $self->desiredCompressionMethod(COMPRESSION_STORED);
865
990
    my $status         = $self->rewindData(@_);
877
1002
    my $offset       = shift;
878
1003
 
879
1004
    return _error("no member name given for $self")
880
 
      unless $self->fileName();
 
1005
      if $self->fileName() eq '';
881
1006
 
882
1007
    $self->{'writeLocalHeaderRelativeOffset'} = $offset;
883
1008
    $self->{'wasWritten'}                     = 0;
923
1048
    my $self    = shift;
924
1049
    my $writeFh = shift;
925
1050
 
926
 
    return AZ_OK if ( $self->uncompressedSize() == 0 );
927
 
    my $status;
928
 
    my $chunkSize = $Archive::Zip::ChunkSize;
929
 
    while ( $self->_readDataRemaining() > 0 ) {
930
 
        my $outRef;
931
 
        ( $outRef, $status ) = $self->readChunk($chunkSize);
932
 
        return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
933
 
 
934
 
        if ( length($$outRef) > 0 ) {
935
 
            $writeFh->print($$outRef)
936
 
              or return _ioError("write error during copy");
 
1051
    # If symbolic link, just create one if the operating system is Linux, Unix, BSD or VMS
 
1052
    # TODO: Add checks for other operating systems
 
1053
    if ( $self->{'isSymbolicLink'} == 1 && $^O eq 'linux' ) {
 
1054
        my $chunkSize = $Archive::Zip::ChunkSize;
 
1055
        my ( $outRef, $status ) = $self->readChunk($chunkSize);
 
1056
        symlink $$outRef, $self->{'newName'};
 
1057
    } else {
 
1058
        return AZ_OK if ( $self->uncompressedSize() == 0 );
 
1059
        my $status;
 
1060
        my $chunkSize = $Archive::Zip::ChunkSize;
 
1061
        while ( $self->_readDataRemaining() > 0 ) {
 
1062
            my $outRef;
 
1063
            ( $outRef, $status ) = $self->readChunk($chunkSize);
 
1064
            return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
 
1065
 
 
1066
            if ( length($$outRef) > 0 ) {
 
1067
                $self->_print($writeFh, $$outRef)
 
1068
                  or return _ioError("write error during copy");
 
1069
            }
 
1070
 
 
1071
            last if $status == AZ_STREAM_END;
937
1072
        }
938
 
 
939
 
        last if $status == AZ_STREAM_END;
 
1073
        $self->{'compressedSize'} = $self->_writeOffset();
940
1074
    }
941
 
    $self->{'compressedSize'} = $self->_writeOffset();
942
1075
    return AZ_OK;
943
1076
}
944
1077