File Coverage

blib/lib/Filesys/POSIX/Userland/Tar.pm
Criterion Covered Total %
statement 92 99 92.9
branch 25 36 69.4
condition 10 15 66.6
subroutine 13 13 100.0
pod 1 1 100.0
total 141 164 85.9


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;
9              
10 7     7   2897 use strict;
  7         8  
  7         156  
11 7     7   17 use warnings;
  7         7  
  7         124  
12              
13 7     7   19 use Filesys::POSIX::Bits;
  7         7  
  7         1524  
14 7     7   23 use Filesys::POSIX::Module ();
  7         7  
  7         80  
15              
16 7     7   16 use Filesys::POSIX::Path ();
  7         6  
  7         62  
17 7     7   2335 use Filesys::POSIX::Userland::Find ();
  7         12  
  7         102  
18 7     7   2874 use Filesys::POSIX::Userland::Tar::Header ();
  7         13  
  7         125  
19              
20 7     7   34 use Errno;
  7         3  
  7         223  
21 7     7   25 use Carp ();
  7         8  
  7         4169  
22              
23             my @METHODS = qw(tar);
24              
25             Filesys::POSIX::Module->export_methods( __PACKAGE__, @METHODS );
26              
27             =head1 NAME
28              
29             Filesys::POSIX::Userland::Tar - Generate ustar archives from L
30              
31             =head1 SYNOPSIS
32              
33             use Filesys::POSIX;
34             use Filesys::POSIX::Mem;
35             use Filesys::POSIX::IO::Handle;
36             use Filesys::POSIX::Userland::Tar;
37              
38             my $fs = Filesys::POSIX->new(Filesys::POSIX::Mem->new,
39             'noatime' => 1
40             );
41              
42             $fs->mkdir('foo');
43             $fs->touch('foo/bar');
44              
45             $fs->tar(Filesys::POSIX::IO::Handle->new(\*STDOUT), '.');
46              
47             =head1 DESCRIPTION
48              
49             This module provides an implementation of the ustar standard on top of the
50             virtual filesystem layer, a mechanism intended to take advantage of the many
51             possible mapping and manipulation capabilities inherent in this mechanism.
52             Internally, it uses the L module to perform
53             depth- last recursion to locate inodes for packaging.
54              
55             As mentioned, archives are written in the ustar format, with pathnames of the
56             extended maximum length of 256 characters, supporting file sizes up to 4GB.
57             Currently, only user and group IDs are stored; names are not resolved and
58             stored as of the time of this writing. All inode types are supported for
59             archival.
60              
61             =head1 USAGE
62              
63             =over
64              
65             =cut
66              
67             our $BLOCK_SIZE = 512;
68             our $BUF_MAX = 20 * $BLOCK_SIZE;
69              
70             #
71             # NOTE: I'm only using $inode->open() calls to avoid having to call stat().
72             # This is not necessarily something that should be done by end user software.
73             #
74             sub _write_file {
75 11     11   32 my ( $fh, $inode, $handle, $size ) = @_;
76              
77 11         12 my $total = 0;
78 11         11 my $actual_file_len = 0;
79              
80 11         12 my $premature_eof;
81              
82 11         9 do {
83 4893         3508 my $max_read = $size - $actual_file_len;
84 4893 100       5676 $max_read = $BUF_MAX if $max_read > $BUF_MAX;
85              
86 4893         3341 my ( $len, $real_len, $buf );
87 4893 100       4989 if ($premature_eof) { # If we reach EOF before the expected length, pad with null bytes
88 1         5 $len = $real_len = $max_read;
89 1         16 $buf = "\x0" x $max_read;
90             }
91             else {
92 4892         3650 $buf = '';
93 4892         2995 $real_len = 0;
94 4892         2896 my $amt_read;
95              
96             # Attempt to read a total of $max_read bytes per buffer. ($max_read is either the
97             # maximum buffer size or the number of bytes expected remaining in the file, whichever
98             # is smaller.)
99             #
100             # Possible outcomes:
101             #
102             # 1. We received no bytes, in which case we have reached EOF unexpectedly.
103             # Produce a warning and set the flag to pad the remaining portion of the
104             # file with null bytes.
105             # 2. We received exactly $max_read bytes. This is good and means we can drop out of
106             # this sub-loop after a single iteration per read loop iteration. (Should be the
107             # most common case.)
108             # 3. We received some bytes, but not as many as we expected. Retry the read,
109             # accumulating bytes until we either have a total of $max_read bytes for
110             # this block or we reach EOF.
111 4892   100     2989 do {
112 4893         2686 my $incremental_buf;
113 4893         8669 $amt_read = $fh->read( $incremental_buf, $max_read - $real_len );
114 4893         8340 $buf .= $incremental_buf;
115 4893         3526 $real_len += $amt_read;
116              
117 4893 100 66     11950 if ( $amt_read <= 0 && $max_read - $real_len > 0 ) {
118 1         9 $premature_eof = 1;
119 1         54 warn sprintf(
120             'WARNING: Short read while archiving file (expected total of %d bytes, but only got %d); padding with null bytes...',
121             $size, $actual_file_len + $real_len,
122             );
123             }
124             } while ( $real_len < $max_read && $amt_read > 0 );
125              
126 4892         3271 $len = $real_len;
127             }
128              
129 4893 100       7376 if ( ( my $padlen = $BLOCK_SIZE - ( $len % $BLOCK_SIZE ) ) != $BLOCK_SIZE ) {
130 8         8 $len += $padlen;
131 8         14 $buf .= "\x0" x $padlen;
132             }
133              
134 4893         3022 my $written = 0;
135              
136 4893 50       8033 if ( ( $written = $handle->write( $buf, $len ) ) != $len ) {
137 0         0 Carp::confess("Short write while dumping file buffer to handle. Expected to write $len bytes, but only wrote $written.");
138             }
139              
140 4893         4728 $actual_file_len += $real_len;
141 4893         7657 $total += $written;
142             } while ( $actual_file_len < $size );
143              
144 11         56 $fh->close;
145              
146 11         35 return $total;
147             }
148              
149             sub _archive {
150 75     75   83 my ( $inode, $handle, $path, $opts ) = @_;
151              
152 75         53 my $written = 0;
153              
154 75         337 my $header = Filesys::POSIX::Userland::Tar::Header->from_inode( $inode, $path );
155 75         103 my $blocks = '';
156              
157 75 50       156 if ( $header->{'truncated'} ) {
158              
159 0 0       0 if ( $opts->{'gnu_extensions'} ) {
    0          
160 0         0 $blocks .= $header->encode_longlink;
161             }
162             elsif ( $opts->{'posix_extensions'} ) {
163 0         0 $blocks .= $header->encode_posix;
164             }
165             else {
166 0         0 die('Filename too long');
167             }
168             }
169              
170 75         162 $blocks .= $header->encode;
171 75         95 local $@;
172              
173 75         83 eval {
174             # Acquire the file handle before writing the header so we don't corrupt
175             # the tarball if the file is missing.
176 75         83 my $fh;
177              
178 75 100 100     148 if ( $inode->file && $header->{'size'} > 0 ) {
179 13         43 $fh = $inode->open( $O_RDONLY | $O_NONBLOCK ); # Case 82969: No block on pipes
180             }
181              
182             # write header
183 73         74 my $header_len = length $blocks;
184 73 50       159 unless ( $handle->write( $blocks, $header_len ) == $header_len ) {
185 0         0 Carp::confess('Short write while dumping tar header to file handle');
186             }
187 73         90 $written += $header_len;
188              
189             # write file
190 73 100       152 $written += _write_file( $fh, $inode, $handle, $header->{'size'} ) if ($fh);
191             };
192              
193 75 100       1610 if ($!) {
194 2 100 33     19 if ( $! == &Errno::ENOENT && $opts->{'ignore_missing'} ) {
    50 33        
195             $opts->{'ignore_missing'}->($path)
196 1 50       6 if ref $opts->{'ignore_missing'} eq 'CODE';
197             }
198             elsif ( $! == &Errno::EACCES && $opts->{'ignore_inaccessible'} ) {
199             $opts->{'ignore_inaccessible'}->($path)
200 0 0       0 if ref $opts->{'ignore_inaccessible'} eq 'CODE';
201             }
202             else {
203 1         9 die $@;
204             }
205             }
206              
207 74         361 return $written;
208             }
209              
210             =item C<$fs-Etar($handle, @items)>
211              
212             =item C<$fs-Etar($handle, $opts, @items)>
213              
214             Locate files and directories in each path specified in the C<@items> array,
215             writing results to the I/O handle wrapper specified by C<$handle>, an instance
216             of L. When an anonymous HASH argument, C<$opts>, is
217             specified, the data is passed unmodified to L.
218             In this way, for instance, the behavior of following symlinks can be specified.
219              
220             In addition to options supported by L, the
221             following options are recognized uniquely by C<$fs-Etar()>:
222              
223             =over
224              
225             =item C
226              
227             When set, certain GNU extensions to the tar output format are enabled, namely
228             support for arbitrarily long filenames.
229              
230             =item C
231              
232             When set, ignore if a file is missing when writing it to the tarball. This can
233             happen if a file is removed between the time the find functionality finds it and
234             the time it is actually written to the output. If the value is a coderef, calls
235             that function with the name of the missing file.
236              
237             =item C
238              
239             When set, ignore if a file is unreadable when writing it to the tarball. This can
240             happen if a file permissions do not allow the current UID and GID to read the file.
241             If the value is a coderef, calls that function with the name of the inaccessible
242             file.
243              
244             =back
245              
246             =cut
247              
248             sub tar {
249 11     11 1 311 my $self = shift;
250 11         46 my $handle = shift;
251 11 100       106 my $opts = ref $_[0] eq 'HASH' ? shift : {};
252 11         52 my @items = @_;
253 11         29 my $unpadded = 0;
254              
255             $self->find(
256             sub {
257 76     76   61 my ( $path, $inode ) = @_;
258              
259 76 100       267 return if $inode->sock;
260              
261 75         156 $unpadded += _archive( $inode, $handle, $path->full, $opts );
262 74         174 $unpadded %= $BUF_MAX;
263             },
264 11         290 $opts,
265             @items
266             );
267              
268 10         63 my $padlen = $BUF_MAX - ( $unpadded % $BUF_MAX );
269 10         120 $handle->write( "\x00" x $padlen, $padlen );
270              
271 10         46 return;
272             }
273              
274             =back
275              
276             =cut
277              
278             1;
279              
280             __END__