File Coverage

blib/lib/Archive/Zip/Member.pm
Criterion Covered Total %
statement 362 405 89.4
branch 107 178 60.1
condition 27 45 60.0
subroutine 79 84 94.0
pod 41 41 100.0
total 616 753 81.8


line stmt bran cond sub pod time code
1             package Archive::Zip::Member;
2              
3             # A generic membet of an archive
4              
5 6     6   114 use strict;
  6         58  
  6         100  
6 6     6   239 use vars qw( $VERSION @ISA );
  6         75  
  6         100  
7              
8             BEGIN {
9 6     6   81     $VERSION = '1.18';
10 6         81     @ISA = qw( Archive::Zip );
11             }
12              
13 6         119 use Archive::Zip qw(
14             :CONSTANTS
15             :MISC_CONSTANTS
16             :ERROR_CODES
17             :PKZIP_CONSTANTS
18             :UTILITY_METHODS
19 6     6   100 );
  6         55  
20              
21 6     6   243 use Time::Local ();
  6         61  
  6         61  
22 6     6   102 use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
  6         54  
  6         161  
23 6     6   102 use File::Path;
  6         53  
  6         102  
24 6     6   108 use File::Basename;
  6         57  
  6         103  
25              
26 6     6   102 use constant ZIPFILEMEMBERCLASS => 'Archive::Zip::ZipFileMember';
  6         88  
  6         90  
27 6     6   100 use constant NEWFILEMEMBERCLASS => 'Archive::Zip::NewFileMember';
  6         56  
  6         77  
28 6     6   90 use constant STRINGMEMBERCLASS => 'Archive::Zip::StringMember';
  6         58  
  6         104  
29 6     6   110 use constant DIRECTORYMEMBERCLASS => 'Archive::Zip::DirectoryMember';
  6         63  
  6         77  
30              
31             # Unix perms for default creation of files/dirs.
32 6     6   150 use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
  6         56  
  6         74  
33 6     6   90 use constant DEFAULT_FILE_PERMISSIONS => 0100666;
  6         55  
  6         69  
34 6     6   129 use constant DIRECTORY_ATTRIB => 040000;
  6         107  
  6         87  
35 6     6   92 use constant FILE_ATTRIB => 0100000;
  6         56  
  6         70  
36              
37             # Returns self if successful, else undef
38             # Assumes that fh is positioned at beginning of central directory file header.
39             # Leaves fh positioned immediately after file header or EOCD signature.
40             sub _newFromZipFile {
41 6     6   55     my $class = shift;
42 6         157     my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile(@_);
43 6         65     return $self;
44             }
45              
46             sub newFromString {
47 4     4 1 74     my $class = shift;
48 4         3021     my $self = $class->STRINGMEMBERCLASS->_newFromString(@_);
49 4         55     return $self;
50             }
51              
52             sub newFromFile {
53 64     64 1 665     my $class = shift;
54 64         1849     my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed(@_);
55 64         852     return $self;
56             }
57              
58             sub newDirectoryNamed {
59 2     2 1 28     my $class = shift;
60 2         248     my $self = $class->DIRECTORYMEMBERCLASS->_newNamed(@_);
61 2         25     return $self;
62             }
63              
64             sub new {
65 76     76 1 698     my $class = shift;
66 76         7088     my $self = {
67                     'lastModFileDateTime' => 0,
68                     'fileAttributeFormat' => FA_UNIX,
69                     'versionMadeBy' => 20,
70                     'versionNeededToExtract' => 20,
71                     'bitFlag' => 0,
72                     'compressionMethod' => COMPRESSION_STORED,
73                     'desiredCompressionMethod' => COMPRESSION_STORED,
74                     'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
75                     'internalFileAttributes' => 0,
76                     'externalFileAttributes' => 0, # set later
77                     'fileName' => '',
78                     'cdExtraField' => '',
79                     'localExtraField' => '',
80                     'fileComment' => '',
81                     'crc32' => 0,
82                     'compressedSize' => 0,
83                     'uncompressedSize' => 0,
84                     @_
85                 };
86 76         2077     bless( $self, $class );
87 76         1723     $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
88 76         1293     return $self;
89             }
90              
91             sub _becomeDirectoryIfNecessary {
92 5     5   44     my $self = shift;
93 5 100       57     $self->_become(DIRECTORYMEMBERCLASS)
94                   if $self->isDirectory();
95 5         55     return $self;
96             }
97              
98             # Morph into given class (do whatever cleanup I need to do)
99             sub _become {
100 3     3   182     return bless( $_[0], $_[1] );
101             }
102              
103             sub versionMadeBy {
104 71     71 1 955     shift->{'versionMadeBy'};
105             }
106              
107             sub fileAttributeFormat {
108 71 50   71 1 895     ( $#_ > 0 )
109                   ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
110                   : $_[0]->{'fileAttributeFormat'};
111             }
112              
113             sub versionNeededToExtract {
114 168     168 1 1961     shift->{'versionNeededToExtract'};
115             }
116              
117             sub bitFlag {
118 190     190 1 2613     shift->{'bitFlag'};
119             }
120              
121             sub compressionMethod {
122 545     545 1 8802     shift->{'compressionMethod'};
123             }
124              
125             sub desiredCompressionMethod {
126 456     456 1 7725     my $self = shift;
127 456         4681     my $newDesiredCompressionMethod = shift;
128 456         4410     my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
129 456 100       5179     if ( defined($newDesiredCompressionMethod) ) {
130 119         1261         $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
131 119 100       2147         if ( $newDesiredCompressionMethod == COMPRESSION_STORED ) {
    100          
132 44         418             $self->{'desiredCompressionLevel'} = 0;
133                     }
134                     elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED ) {
135 74         697             $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
136                     }
137                 }
138 456         9045     return $oldDesiredCompressionMethod;
139             }
140              
141             sub desiredCompressionLevel {
142 19     19 1 346     my $self = shift;
143 19         159     my $newDesiredCompressionLevel = shift;
144 19         255     my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
145 19 50       537     if ( defined($newDesiredCompressionLevel) ) {
146 0         0         $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
147 0 0       0         $self->{'desiredCompressionMethod'} = (
148                         $newDesiredCompressionLevel
149                         ? COMPRESSION_DEFLATED
150                         : COMPRESSION_STORED
151                     );
152                 }
153 19         516     return $oldDesiredCompressionLevel;
154             }
155              
156             sub fileName {
157 1118     1118 1 13590     my $self = shift;
158 1118         10273     my $newName = shift;
159 1118 100       14552     if ($newName) {
160 77         967         $newName =~ s{[\\/]+}{/}g; # deal with dos/windoze problems
161 77         969         $self->{'fileName'} = $newName;
162                 }
163 1118         18936     return $self->{'fileName'};
164             }
165              
166             sub lastModFileDateTime {
167 231     231 1 2553     my $modTime = shift->{'lastModFileDateTime'};
168 231         3965     $modTime =~ m/^(\d+)$/; # untaint
169 231         4817     return $1;
170             }
171              
172             sub lastModTime {
173 61     61 1 834     my $self = shift;
174 61         899     return _dosToUnixTime( $self->lastModFileDateTime() );
175             }
176              
177             sub setLastModFileDateTimeFromUnix {
178 70     70 1 635     my $self = shift;
179 70         623     my $time_t = shift;
180 70         1212     $self->{'lastModFileDateTime'} = _unixToDosTime($time_t);
181             }
182              
183             sub internalFileAttributes {
184 153     153 1 1800     shift->{'internalFileAttributes'};
185             }
186              
187             sub externalFileAttributes {
188 71     71 1 822     shift->{'externalFileAttributes'};
189             }
190              
191             # Convert UNIX permissions into proper value for zip file
192             # NOT A METHOD!
193             sub _mapPermissionsFromUnix {
194 146     146   8873     my $perms = shift;
195 146         1780     return $perms << 16;
196              
197             # TODO: map MS-DOS perms too (RHSA?)
198             }
199              
200             # Convert ZIP permissions into Unix ones
201             #
202             # This was taken from Info-ZIP group's portable UnZip
203             # zipfile-extraction program, version 5.50.
204             # http://www.info-zip.org/pub/infozip/
205             #
206             # See the mapattr() function in unix/unix.c
207             # See the attribute format constants in unzpriv.h
208             #
209             # XXX Note that there's one situation that isn't implemented
210             # yet that depends on the "extra field."
211             sub _mapPermissionsToUnix {
212 149     149   1333     my $self = shift;
213              
214 149         1433     my $format = $self->{'fileAttributeFormat'};
215 149         2393     my $attribs = $self->{'externalFileAttributes'};
216              
217 149         2676     my $mode = 0;
218              
219 149 50       1544     if ( $format == FA_AMIGA ) {
220 0         0         $attribs = $attribs >> 17 & 7; # Amiga RWE bits
221 0         0         $mode = $attribs << 6 | $attribs << 3 | $attribs;
222 0         0         return $mode;
223                 }
224              
225 149 50       1378     if ( $format == FA_THEOS ) {
226 0         0         $attribs &= 0xF1FFFFFF;
227 0 0       0         if ( ( $attribs & 0xF0000000 ) != 0x40000000 ) {
228 0         0             $attribs &= 0x01FFFFFF; # not a dir, mask all ftype bits
229                     }
230                     else {
231 0         0             $attribs &= 0x41FFFFFF; # leave directory bit as set
232                     }
233                 }
234              
235 149 50 33     2623     if ( $format == FA_UNIX
      33        
      33        
      33        
      33        
      33        
236                     || $format == FA_VAX_VMS
237                     || $format == FA_ACORN
238                     || $format == FA_ATARI_ST
239                     || $format == FA_BEOS
240                     || $format == FA_QDOS
241                     || $format == FA_TANDEM )
242                 {
243 149         1739         $mode = $attribs >> 16;
244 149 50 66     2692         return $mode if $mode != 0 or not $self->localExtraField;
245              
246             # warn("local extra field is: ", $self->localExtraField, "\n");
247              
248             # XXX This condition is not implemented
249             # I'm just including the comments from the info-zip section for now.
250              
251             # Some (non-Info-ZIP) implementations of Zip for Unix and
252             # VMS (and probably others ??) leave 0 in the upper 16-bit
253             # part of the external_file_attributes field. Instead, they
254             # store file permission attributes in some extra field.
255             # As a work-around, we search for the presence of one of
256             # these extra fields and fall back to the MSDOS compatible
257             # part of external_file_attributes if one of the known
258             # e.f. types has been detected.
259             # Later, we might implement extraction of the permission
260             # bits from the VMS extra field. But for now, the work-around
261             # should be sufficient to provide "readable" extracted files.
262             # (For ASI Unix e.f., an experimental remap from the e.f.
263             # mode value IS already provided!)
264                 }
265              
266             # PKWARE's PKZip for Unix marks entries as FA_MSDOS, but stores the
267             # Unix attributes in the upper 16 bits of the external attributes
268             # field, just like Info-ZIP's Zip for Unix. We try to use that
269             # value, after a check for consistency with the MSDOS attribute
270             # bits (see below).
271 0 0       0     if ( $format == FA_MSDOS ) {
272 0         0         $mode = $attribs >> 16;
273                 }
274              
275             # FA_MSDOS, FA_OS2_HPFS, FA_WINDOWS_NTFS, FA_MACINTOSH, FA_TOPS20
276 0         0     $attribs = !( $attribs & 1 ) << 1 | ( $attribs & 0x10 ) >> 4;
277              
278             # keep previous $mode setting when its "owner"
279             # part appears to be consistent with DOS attribute flags!
280 0 0       0     return $mode if ( $mode & 0700 ) == ( 0400 | $attribs << 6 );
281 0         0     $mode = 0444 | $attribs << 6 | $attribs << 3 | $attribs;
282 0         0     return $mode;
283             }
284              
285             sub unixFileAttributes {
286 149     149 1 2084     my $self = shift;
287 149         4233     my $oldPerms = $self->_mapPermissionsToUnix();
288 149 100       2521     if (@_) {
289 146         1321         my $perms = shift;
290 146 100       8428         if ( $self->isDirectory() ) {
291 4         34             $perms &= ~FILE_ATTRIB;
292 4         36             $perms |= DIRECTORY_ATTRIB;
293                     }
294                     else {
295 142         1343             $perms &= ~DIRECTORY_ATTRIB;
296 142         1644             $perms |= FILE_ATTRIB;
297                     }
298 146         1565         $self->{'externalFileAttributes'} = _mapPermissionsFromUnix($perms);
299                 }
300 149         1563     return $oldPerms;
301             }
302              
303             sub localExtraField {
304 315 50   315 1 6957     ( $#_ > 0 )
305                   ? ( $_[0]->{'localExtraField'} = $_[1] )
306                   : $_[0]->{'localExtraField'};
307             }
308              
309             sub cdExtraField {
310 142 50   142 1 1961     ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] ) : $_[0]->{'cdExtraField'};
311             }
312              
313             sub extraFields {
314 0     0 1 0     my $self = shift;
315 0         0     return $self->localExtraField() . $self->cdExtraField();
316             }
317              
318             sub fileComment {
319 142 50   142