File Coverage

blib/lib/Filesys/POSIX/Userland/Tar/Header.pm
Criterion Covered Total %
statement 106 156 67.9
branch 32 40 80.0
condition 5 9 55.5
subroutine 14 27 51.8
pod 0 21 0.0
total 157 253 62.0


line stmt bran cond sub pod time code
1             # Copyright (c) 2014, cPanel, Inc.
2             # All rights reserved.
3             # http://cpanel.net/
4             #
5             # This is free software; you can redistribute it and/or modify it under the same
6             # terms as Perl itself. See the LICENSE file for further details.
7              
8             package Filesys::POSIX::Userland::Tar::Header;
9              
10 7     7   25 use strict;
  7         12  
  7         172  
11 7     7   21 use warnings;
  7         6  
  7         132  
12              
13 7     7   24 use Filesys::POSIX::Bits;
  7         3  
  7         1509  
14 7     7   24 use Filesys::POSIX::Path ();
  7         7  
  7         69  
15              
16 7     7   15 use Carp ();
  7         6  
  7         10052  
17              
18             our $BLOCK_SIZE = 512;
19              
20             my %TYPES = (
21             0 => $S_IFREG,
22             2 => $S_IFLNK,
23             3 => $S_IFCHR,
24             4 => $S_IFBLK,
25             5 => $S_IFDIR,
26             6 => $S_IFIFO
27             );
28              
29             sub inode_linktype {
30 81     81 0 74 my ($inode) = @_;
31              
32 81         316 foreach ( keys %TYPES ) {
33 238 100       562 return $_ if ( $inode->{'mode'} & $S_IFMT ) == $TYPES{$_};
34             }
35              
36 0         0 return 0;
37             }
38              
39             sub from_inode {
40 81     81 0 123 my ( $class, $inode, $path ) = @_;
41              
42 81         157 my $parts = Filesys::POSIX::Path->new($path);
43 81         161 my $cleanpath = $parts->full;
44 81 100       167 $cleanpath .= '/' if $inode->dir;
45              
46 81         200 my $path_components = split_path_components( $parts, $inode );
47 81 100       216 my $size = $inode->file ? $inode->{'size'} : 0;
48              
49 81         79 my $major = 0;
50 81         54 my $minor = 0;
51              
52 81 50 33     155 if ( $inode->char || $inode->block ) {
53 0         0 $major = $inode->major;
54 0         0 $minor = $inode->minor;
55             }
56              
57             return bless {
58             'path' => $cleanpath,
59             'prefix' => $path_components->{'prefix'},
60             'suffix' => $path_components->{'suffix'},
61             'truncated' => $path_components->{'truncated'},
62             'mode' => $inode->{'mode'},
63             'uid' => $inode->{'uid'},
64             'gid' => $inode->{'gid'},
65             'size' => $size,
66 81 100       231 'mtime' => $inode->{'mtime'},
67             'linktype' => inode_linktype($inode),
68             'linkdest' => $inode->link ? $inode->readlink : '',
69             'user' => '',
70             'group' => '',
71             'major' => $major,
72             'minor' => $minor
73             }, $class;
74             }
75              
76             sub decode {
77 0     0 0 0 my ( $class, $block ) = @_;
78              
79 0         0 my $suffix = read_str( $block, 0, 100 );
80 0         0 my $prefix = read_str( $block, 345, 155 );
81 0         0 my $checksum = read_oct( $block, 148, 8 );
82              
83 0         0 validate_block( $block, $checksum );
84              
85 0         0 return bless {
86             'suffix' => $suffix,
87             'mode' => read_oct( $block, 100, 8 ),
88             'uid' => read_oct( $block, 108, 8 ),
89             'gid' => read_oct( $block, 116, 8 ),
90             'size' => read_oct( $block, 124, 12 ),
91             'mtime' => read_oct( $block, 136, 12 ),
92             'linktype' => read_oct( $block, 156, 1 ),
93             'linkdest' => read_str( $block, 157, 100 ),
94             'user' => read_str( $block, 265, 32 ),
95             'group' => read_str( $block, 297, 32 ),
96             'major' => read_oct( $block, 329, 8 ),
97             'minor' => read_oct( $block, 337, 8 ),
98             'prefix' => $prefix
99             }, $class;
100             }
101              
102             sub encode_longlink {
103 2     2 0 310 my ($self) = @_;
104              
105 2         4 my $pathlen = length $self->{'path'};
106              
107 2         18 my $longlink_header = bless {
108             'prefix' => '',
109             'suffix' => '././@LongLink',
110             'mode' => 0,
111             'uid' => 0,
112             'gid' => 0,
113             'size' => $pathlen,
114             'mtime' => 0,
115             'linktype' => 'L',
116             'linkdest' => '',
117             'user' => '',
118             'group' => '',
119             'major' => 0,
120             'minor' => 0
121             },
122             ref $self;
123              
124 2         7 my $path_blocks = "\x00" x ( $pathlen + $BLOCK_SIZE - ( $pathlen % $BLOCK_SIZE ) );
125 2         6 substr( $path_blocks, 0, $pathlen ) = $self->{'path'};
126              
127 2         38 return $longlink_header->encode . $path_blocks;
128             }
129              
130             sub _compute_posix_header {
131 6     6   11653 my ( $self, $key, $value ) = @_;
132 6         15 my $header = " $key=$value\n";
133 6         6 my $len = length $header;
134 6         10 my $hdrlen = length($len) + $len;
135 6         5 my $curlen = length($hdrlen);
136              
137             # The length field includes everything up to and including the newline and
138             # the length field itself. Compute the proper value if adding the length
139             # would push us to a larger number of digits.
140 6 100       11 $hdrlen = $curlen + $len if $curlen > length($len);
141              
142 6         13 return "$hdrlen$header";
143             }
144              
145             sub encode_posix {
146 0     0 0 0 my ($self) = @_;
147              
148 0         0 my $linklen = length $self->{'linkdest'};
149 0         0 my $encoded = $self->_compute_posix_header( 'path', $self->{'path'} );
150 0 0       0 $encoded .= $self->_compute_posix_header( 'linkpath', $self->{'linkdest'} ) if $linklen;
151              
152 0         0 my $encodedlen = length $encoded;
153              
154             my $posix_header = bless {
155             'prefix' => "./PaxHeaders.$$",
156 0         0 'suffix' => substr( $self->{'path'}, 0, 100 ),
157             'mode' => 0,
158             'uid' => 0,
159             'gid' => 0,
160             'size' => $encodedlen,
161             'mtime' => 0,
162             'linktype' => 'x',
163             'linkdest' => '',
164             'user' => '',
165             'group' => '',
166             'major' => 0,
167             'minor' => 0
168             },
169             ref $self;
170              
171 0         0 my $path_blocks = "\x00" x ( $encodedlen + $BLOCK_SIZE - ( $encodedlen % $BLOCK_SIZE ) );
172 0         0 substr( $path_blocks, 0, $encodedlen ) = $encoded;
173              
174 0         0 return $posix_header->encode . $path_blocks;
175             }
176              
177             sub encode {
178 80     80 0 80 my ($self) = @_;
179 80         105 my $block = "\x00" x $BLOCK_SIZE;
180              
181 80         124 write_str( $block, 0, 100, $self->{'suffix'} );
182 80         128 write_oct( $block, 100, 8, $self->{'mode'} & $S_IPERM, 7 );
183 80         117 write_oct( $block, 108, 8, $self->{'uid'}, 7 );
184 80         93 write_oct( $block, 116, 8, $self->{'gid'}, 7 );
185 80         91 write_oct( $block, 124, 12, $self->{'size'}, 11 );
186 80         92 write_oct( $block, 136, 12, $self->{'mtime'}, 11 );
187 80         93 write_str( $block, 148, 8, ' ' );
188              
189 80 100       282 if ( $self->{'linktype'} =~ /^[0-9]$/ ) {
190 78         104 write_oct( $block, 156, 1, $self->{'linktype'}, 1 );
191             }
192             else {
193 2         6 write_str( $block, 156, 1, $self->{'linktype'} );
194             }
195              
196 80         112 write_str( $block, 157, 100, $self->{'linkdest'} );
197 80         93 write_str( $block, 257, 6, 'ustar' );
198 80         90 write_str( $block, 263, 2, '00' );
199 80         97 write_str( $block, 265, 32, $self->{'user'} );
200 80         78 write_str( $block, 297, 32, $self->{'group'} );
201              
202 80 50 33     250 if ( $self->{'major'} || $self->{'minor'} ) {
203 0         0 write_oct( $block, 329, 8, $self->{'major'}, 7 );
204 0         0 write_oct( $block, 337, 8, $self->{'minor'}, 7 );
205             }
206              
207 80         106 write_str( $block, 345, 155, $self->{'prefix'} );
208              
209 80         99 my $checksum = checksum($block);
210              
211 80         107 write_oct( $block, 148, 8, $checksum, 7 );
212              
213 80         161 return $block;
214             }
215              
216             sub split_path_components {
217 88     88 0 94 my ( $parts, $inode ) = @_;
218              
219 88         56 my $truncated = 0;
220              
221 88 100       148 $parts->[-1] .= '/' if $inode->dir;
222              
223 88         101 my $got = 0;
224 88         66 my ( @prefix_items, @suffix_items );
225              
226 88         69 while ( @{$parts} ) {
  488         648  
227 400         254 my $item = pop @{$parts};
  400         327  
228 400         291 my $len = length $item;
229              
230             #
231             # If the first item found is greater than 100 characters in length,
232             # truncate it so that it may fit in the standard tar path header field.
233             #
234 400 100 100     690 if ( $got == 0 && $len > 100 ) {
235 3 100       10 my $truncated_len = $inode->dir ? 99 : 100;
236              
237 3         8 $item = substr( $item, 0, $truncated_len );
238 3 100       5 $item .= '/' if $inode->dir;
239              
240 3         5 $len = 100;
241 3         3 $truncated = 1;
242             }
243              
244 400 100       445 $got++ if $got;
245 400         226 $got += $len;
246              
247 400 100       437 if ( $got <= 100 ) {
    50          
248 294         280 push @suffix_items, $item;
249             }
250             elsif ( $got > 100 ) {
251 106         85 push @prefix_items, $item;
252             }
253             }
254              
255 88         120 my $prefix = join( '/', reverse @prefix_items );
256 88         116 my $suffix = join( '/', reverse @suffix_items );
257              
258 88 50       165 if ( length($prefix) > 155 ) {
259 0         0 $prefix = substr( $prefix, 0, 155 );
260 0         0 $truncated = 1;
261             }
262              
263             return {
264 88         308 'prefix' => $prefix,
265             'suffix' => $suffix,
266             'truncated' => $truncated
267             };
268             }
269              
270             sub read_str {
271 0     0 0 0 my ( $block, $offset, $len ) = @_;
272 0         0 my $template = "Z$len";
273              
274 0         0 return unpack( $template, substr( $block, $offset, $len ) );
275             }
276              
277             sub write_str {
278 642     642 0 623 my ( $block, $offset, $len, $string ) = @_;
279              
280 642 100       611 if ( length($string) == $len ) {
281 163         172 substr( $_[0], $offset, $len ) = $string;
282             }
283             else {
284 479         814 substr( $_[0], $offset, $len ) = pack( "Z$len", $string );
285             }
286              
287 642         449 return;
288             }
289              
290             sub read_oct {
291 0     0 0 0 my ( $block, $offset, $len ) = @_;
292 0         0 my $template = "Z$len";
293              
294 0         0 return oct( unpack( $template, substr( $block, $offset, $len ) ) );
295             }
296              
297             sub write_oct {
298 558     558 0 498 my ( $block, $offset, $len, $value, $digits ) = @_;
299 558         917 my $string = sprintf( "%.${digits}o", $value );
300 558         406 my $sub_offset = length($string) - $digits;
301 558         423 my $substring = substr( $string, $sub_offset, $digits );
302              
303 558 100       525 if ( $len == $digits ) {
304 78         70 substr( $_[0], $offset, $len ) = $substring;
305             }
306             else {
307 480         549 substr( $_[0], $offset, $len ) = pack( "Z$len", $substring );
308             }
309              
310 558         454 return;
311             }
312              
313             sub checksum {
314 80     80 0 69 my ($block) = @_;
315 80         81 my $sum = 0;
316              
317 80         1130 foreach ( unpack 'C*', $block ) {
318 40960         24409 $sum += $_;
319             }
320              
321 80         630 return $sum;
322             }
323              
324             sub validate_block {
325 0     0 0   my ( $block, $checksum ) = @_;
326 0           my $copy = "$block";
327              
328 0           write_str( $block, 148, 8, ' ' x 8 );
329              
330 0           my $calculated_checksum = checksum($copy);
331              
332 0 0         Carp::confess('Invalid block') unless $calculated_checksum == $checksum;
333              
334 0           return;
335             }
336              
337             sub file {
338 0     0 0   my ($self) = @_;
339              
340 0           return $TYPES{ $self->{'linktype'} } == $S_IFREG;
341             }
342              
343             sub link {
344 0     0 0   my ($self) = @_;
345              
346 0           return $self->{'linktype'} == 1;
347             }
348              
349             sub symlink {
350 0     0 0   my ($self) = @_;
351              
352 0           return $TYPES{ $self->{'linktype'} } == $S_IFLNK;
353             }
354              
355             sub char {
356 0     0 0   my ($self) = @_;
357              
358 0           return $TYPES{ $self->{'linktype'} } == $S_IFCHR;
359             }
360              
361             sub block {
362 0     0 0   my ($self) = @_;
363              
364 0           return $TYPES{ $self->{'linktype'} } == $S_IFBLK;
365             }
366              
367             sub dir {
368 0     0 0   my ($self) = @_;
369              
370 0           return $TYPES{ $self->{'linktype'} } == $S_IFDIR;
371             }
372              
373             sub fifo {
374 0     0 0   my ($self) = @_;
375              
376 0           return $TYPES{ $self->{'linktype'} } == $S_IFIFO;
377             }
378              
379             sub contig {
380 0     0 0   my ($self) = @_;
381              
382 0           return $self->{'linktype'} == 7;
383             }
384              
385             1;