File Coverage

blib/lib/File/Dir/Dumper/Scanner.pm
Criterion Covered Total %
statement 143 153 93.4
branch 26 32 81.2
condition 4 4 100.0
subroutine 26 26 100.0
pod 1 1 100.0
total 200 216 92.5


line stmt bran cond sub pod time code
1             package File::Dir::Dumper::Scanner;
2             $File::Dir::Dumper::Scanner::VERSION = '0.6.4';
3 1     1   132896 use warnings;
  1         12  
  1         33  
4 1     1   5 use strict;
  1         3  
  1         18  
5 1     1   5 use autodie;
  1         1  
  1         6  
6              
7 1     1   5340 use 5.012;
  1         7  
8              
9 1     1   6 use parent 'File::Dir::Dumper::Base';
  1         2  
  1         6  
10              
11 1     1   78 use Carp ();
  1         2  
  1         15  
12              
13 1     1   576 use File::Find::Object ();
  1         12571  
  1         25  
14 1     1   7 use Devel::CheckOS qw( os_is );
  1         2  
  1         50  
15              
16 1     1   5 use POSIX qw(strftime);
  1         2  
  1         8  
17 1     1   67 use List::Util qw(min);
  1         2  
  1         113  
18              
19 1         12 use Class::XSAccessor accessors => {
20             _digest_cache => '_digest_cache',
21             _digests => '_digests',
22             _file_find => '_file_find',
23             _group_cache => '_group_cache',
24             _last_result => '_last_result',
25             _queue => '_queue',
26             _reached_end => '_reached_end',
27             _result => '_result',
28             _user_cache => '_user_cache',
29 1     1   7 };
  1         2  
30              
31 1     1   1037 use Digest ();
  1         614  
  1         959  
32              
33              
34             sub _init
35             {
36 3     3   5 my $self = shift;
37 3         6 my $args = shift;
38              
39 3         5 my $dir_to_dump = $args->{dir};
40              
41 3         22 $self->_file_find(
42             File::Find::Object->new(
43             {
44             followlink => 0,
45             },
46             $dir_to_dump,
47             )
48             );
49              
50 3         656 $self->_queue( [] );
51              
52 3         16 $self->_add(
53             {
54             type => "header",
55             dir_to_dump => $dir_to_dump,
56             stream_type => "Directory Dump"
57             }
58             );
59              
60 3         10 $self->_digests( undef() );
61 3 100       10 if ( exists( $args->{digests} ) )
62             {
63 2         4 my $digests = {};
64 2         4 foreach my $d ( @{ $args->{digests} } )
  2         21  
65             {
66 4 50       10 if ( exists $digests->{$d} )
67             {
68 0         0 Carp::confess("Duplicate digest '$d'!");
69             }
70 4         23 $digests->{$d} = 1;
71             }
72 2 50       9 if ( !%$digests )
73             {
74 0         0 Carp::confess("The list of digests is empty.");
75             }
76 2         12 $self->_digests( [ sort { $a cmp $b } keys %$digests ] );
  2         12  
77             }
78 3   100     14 my $base = ( $args->{digest_cache} || 'Dummy' );
79 3 50       17 if ( $base !~ /\A[A-Za-z_][A-Za-z_0-9]*\z/ )
80             {
81 0         0 Carp::confess("Invalid digest_cache format.");
82             }
83 3         10 my $cl = "File::Dir::Dumper::DigestCache::$base";
84             ## no critic
85 3         224 eval "require $cl";
86             ## use critic
87 3 50       19 if ($@)
88             {
89 0         0 die $@;
90             }
91             $self->_digest_cache(
92             scalar $cl->new(
93             {
94 3   100     37 params => ( $args->{digest_cache_params} || +{} ),
95              
96             }
97             )
98             );
99              
100 3         15 $self->_user_cache( {} );
101 3         7 $self->_group_cache( {} );
102              
103 3         7 return;
104             }
105              
106             sub _add
107             {
108 19     19   31 my $self = shift;
109 19         29 my $token = shift;
110              
111 19         29 push @{ $self->_queue() }, $token;
  19         59  
112              
113 19         35 return;
114             }
115              
116             sub fetch
117             {
118 21     21 1 29461 my $self = shift;
119              
120 21 100       37 if ( !@{ $self->_queue() } )
  21         78  
121             {
122 14         37 $self->_populate_queue();
123             }
124              
125 21         34 return shift( @{ $self->_queue() } );
  21         97  
126             }
127              
128             sub _up_to_level
129             {
130 9     9   13 my $self = shift;
131 9         15 my $target_level = shift;
132              
133 9         16 my $last_result = $self->_last_result();
134              
135 9         16 for my $level (
136 9         27 reverse( $target_level .. $#{ $last_result->dir_components() } ) )
137             {
138 4         14 $self->_add(
139             {
140             type => "updir",
141             depth => $level + 1,
142             }
143             );
144             }
145              
146 9         14 return;
147             }
148              
149             sub _find_new_common_depth
150             {
151 8     8   17 my $self = shift;
152              
153 8         12 my $result = $self->_result();
154 8         17 my $last_result = $self->_last_result();
155              
156 8         12 my $depth = 0;
157              
158             my $upper_limit = min(
159 8         19 scalar( @{ $last_result->dir_components() } ),
160 8         14 scalar( @{ $result->dir_components() } ),
  8         29  
161             );
162              
163             FIND_I:
164 8         21 while ( $depth < $upper_limit )
165             {
166 2 100       10 if ( $last_result->dir_components()->[$depth] ne
167             $result->dir_components()->[$depth] )
168             {
169 1         3 last FIND_I;
170             }
171             }
172             continue
173             {
174 1         3 $depth++;
175             }
176              
177 8         25 return $depth;
178             }
179              
180             BEGIN
181             {
182 1 50   1   8 if ( os_is('Unix') )
183             {
184             *_my_getpwuid = sub {
185 5     5   5098 my $uid = shift;
186 5         1084 return scalar( getpwuid($uid) );
187 1         26872 };
188             *_my_getgrgid = sub {
189 3     3   5 my $gid = shift;
190 3         214 return scalar( getgrgid($gid) );
191 1         932 };
192             }
193             else
194             {
195 0         0 *_my_getpwuid = sub { return "unknown"; };
  0         0  
196 0         0 *_my_getgrgid = sub { return "unknown"; };
  0         0  
197             }
198             }
199              
200             sub _get_user_name
201             {
202 8     8   504 my $self = shift;
203 8         13 my $uid = shift;
204              
205 8 100       37 if ( !exists( $self->_user_cache()->{$uid} ) )
206             {
207 3         10 $self->_user_cache()->{$uid} = _my_getpwuid($uid);
208             }
209              
210 8         37 return $self->_user_cache()->{$uid};
211             }
212              
213             sub _get_group_name
214             {
215 8     8   13 my $self = shift;
216 8         12 my $gid = shift;
217              
218 8 100       24 if ( !exists( $self->_group_cache()->{$gid} ) )
219             {
220 3         8 $self->_group_cache()->{$gid} = _my_getgrgid($gid);
221             }
222              
223 8         60 return $self->_group_cache()->{$gid};
224             }
225              
226             sub _calc_file_digests_key
227             {
228 5     5   20 my ( $self, $stat ) = @_;
229              
230 5         11 my $digests = $self->_digests;
231              
232 5 100       12 if ( !defined $digests )
233             {
234 1         23 return [];
235             }
236 4         10 my $result = $self->_result();
237 4         10 my $path = $result->path;
238             my $ret = $self->_digest_cache->get_digests(
239             {
240             path => $result->full_components,
241             mtime => $stat->[9],
242             digests => $digests,
243             calc_cb => sub {
244 4     4   50 my %ret;
245 4         12 foreach my $d (@$digests)
246             {
247 8         1268 my $o = Digest->new($d);
248 8         316 open my $fh, '<', $path;
249 8         2676 binmode $fh;
250 8         1376 $o->addfile($fh);
251 8         208 $ret{$d} = $o->hexdigest;
252 8         29 close($fh);
253             }
254 4         299 return \%ret;
255             },
256             }
257 4         16 );
258 4         64 return [ digests => $ret, ];
259             }
260             my $PERM_MASK = oct('07777');
261              
262             sub _calc_file_or_dir_token
263             {
264 8     8   12 my $self = shift;
265              
266 8         17 my $result = $self->_result();
267              
268 8         142 my @stat = stat( $result->path() );
269              
270 8 50       33 if ( not @stat )
271             {
272 0         0 Carp::confess(
273 0         0 "Could not successfully stat <<@{[$result->path()]}>> - $!");
274             }
275              
276             return {
277             filename => $result->full_components()->[-1],
278 8         95 depth => scalar( @{ $result->full_components() } ),
279             perms => sprintf( "%04o", ( $stat[2] & $PERM_MASK ) ),
280             mtime => strftime( "%Y-%m-%dT%H:%M:%S", localtime( $stat[9] ) ),
281             user => $self->_get_user_name( $stat[4] ),
282             group => $self->_get_group_name( $stat[5] ),
283             (
284             $result->is_dir()
285             ? ( type => "dir", )
286             : (
287             type => "file",
288             size => $stat[7],
289 8 100       32 @{ $self->_calc_file_digests_key( \@stat ) },
  5         15  
290             )
291             ),
292             };
293             }
294              
295             sub _populate_queue
296             {
297 14     14   22 my $self = shift;
298              
299 14 100       41 if ( $self->_reached_end() )
300             {
301 2         5 return;
302             }
303              
304 12         39 $self->_result( $self->_file_find->next_obj() );
305              
306 12 100       4094 if ( !$self->_last_result() )
    100          
307             {
308 3         16 $self->_add( { type => "dir", depth => 0 } );
309             }
310             elsif ( !$self->_result() )
311             {
312 1         5 $self->_up_to_level(-1);
313              
314 1         5 $self->_add( { type => "footer" } );
315              
316 1         3 $self->_reached_end(1);
317             }
318             else
319             {
320 8         39 $self->_up_to_level( $self->_find_new_common_depth() );
321              
322 8         73 $self->_add( $self->_calc_file_or_dir_token() );
323             }
324              
325 12         70 $self->_last_result( $self->_result() );
326             }
327              
328              
329             1; # End of File::Dir::Dumper
330              
331             __END__