File Coverage

blib/lib/Dir/Split.pm
Criterion Covered Total %
statement 140 189 74.0
branch 13 42 30.9
condition 5 15 33.3
subroutine 29 32 90.6
pod 4 4 100.0
total 191 282 67.7


line stmt bran cond sub pod time code
1             package Dir::Split;
2              
3 3     3   75005 use strict;
  3         16  
  3         84  
4 3     3   15 use warnings;
  3         6  
  3         112  
5 3     3   437 use boolean qw(true false);
  3         3180  
  3         15  
6              
7 3     3   218 use Carp qw(croak);
  3         4  
  3         188  
8 3     3   25 use File::Basename ();
  3         7  
  3         57  
9 3     3   1478 use File::Copy ();
  3         6857  
  3         71  
10 3     3   18 use File::Find ();
  3         6  
  3         40  
11 3     3   13 use File::Path ();
  3         6  
  3         36  
12 3     3   19 use File::Spec ();
  3         6  
  3         50  
13 3     3   1645 use Params::Validate ':all';
  3         27267  
  3         8381  
14              
15             our $VERSION = '0.82';
16              
17             validation_options(
18             on_fail => sub
19             {
20             my ($error) = @_;
21             chomp $error;
22             croak $error;
23             },
24             stack_skip => 2,
25             );
26              
27             my %num_presets = (
28             verbose => false,
29             override => false,
30             sort => 'asc',
31             limit => 5,
32             prefix => 'sub',
33             separator => '-',
34             continue => false,
35             length => 5,
36             );
37             my %char_presets = (
38             verbose => false,
39             override => false,
40             prefix => 'sub',
41             separator => '-',
42             case => 'upper',
43             length => 1,
44             );
45              
46             sub new
47             {
48 2     2 1 6916 my $class = shift;
49              
50 2   33     47 my $self = bless {}, ref($class) || $class;
51              
52 2         18 $self->_init(@_);
53              
54 2         6 return $self;
55             }
56              
57             sub _init
58             {
59 2     2   7 my $self = shift;
60 2         13 my %opts = @_;
61              
62             validate(@_, {
63             source => {
64             type => SCALAR,
65             callbacks => {
66 2     2   45 'directory exists' => sub { -d $_[0] }
67             },
68             },
69             target => {
70             type => SCALAR,
71             callbacks => {
72 2     2   42 'directory exists' => sub { -d $_[0] }
73             },
74             },
75 2         99 });
76              
77 2         27 foreach my $opt (qw(source target)) {
78 4         35 $self->{ucfirst $opt} = $opts{$opt};
79             }
80             }
81              
82             sub split_num
83             {
84 1     1 1 7 my $self = shift;
85              
86 1         5 $self->_validate_num(@_);
87              
88 1         83 $self->_init_mode(@_, \%num_presets);
89              
90 1         7 my ($dirs, $files) = $self->_gather_files;
91 1         6 $self->_sort_files($files);
92              
93 1         6 my $suffix = $self->_get_num_suffix;
94 1         5 $self->_move_num($files, $suffix);
95             }
96              
97             sub _validate_num
98             {
99 1     1   2 my $self = shift;
100              
101 1         4 validate(@_, {
102             verbose => {
103             type => BOOLEAN,
104             optional => true,
105             },
106             override => {
107             type => BOOLEAN,
108             optional => true,
109             },
110             sort => {
111             type => SCALAR,
112             optional => true,
113             regex => qr!^(?:asc|desc)$!,
114             },
115             limit => {
116             type => SCALAR,
117             optional => true,
118             regex => qr!^\d+$!,
119             },
120             prefix => {
121             type => SCALAR,
122             optional => true,
123             regex => qr!^\S+$!,
124             },
125             separator => {
126             type => SCALAR,
127             optional => true,
128             regex => qr!^\S+$!,
129             },
130             continue => {
131             type => BOOLEAN,
132             optional => true,
133             },
134             length => {
135             type => SCALAR,
136             optional => true,
137             regex => qr!^\d+$!,
138             },
139             });
140             }
141              
142             sub split_char
143             {
144 1     1 1 7 my $self = shift;
145              
146 1         7 $self->_validate_char(@_);
147              
148 1         87 $self->_init_mode(@_, \%char_presets);
149              
150 1         4 my ($dirs, $files) = $self->_gather_files;
151              
152 1         2 my %suffixes;
153 1         15 $self->_get_char_suffixes($files, \%suffixes);
154 1         4 $self->_move_char(\%suffixes);
155             }
156              
157             sub _validate_char
158             {
159 1     1   2 my $self = shift;
160              
161 1         31 validate(@_, {
162             verbose => {
163             type => BOOLEAN,
164             optional => true,
165             },
166             override => {
167             type => BOOLEAN,
168             optional => true,
169             },
170             prefix => {
171             type => SCALAR,
172             optional => true,
173             regex => qr!^\S+$!,
174             },
175             separator => {
176             type => SCALAR,
177             optional => true,
178             regex => qr!^\S+$!,
179             },
180             case => {
181             type => SCALAR,
182             optional => true,
183             regex => qr!^(?:lower|upper)$!,
184             },
185             length => {
186             type => SCALAR,
187             optional => true,
188             regex => qr!^\d+$!,
189             },
190             });
191             }
192              
193             sub _init_mode
194             {
195 2     2   4 my $self = shift;
196 2         4 my $presets = pop;
197 2         15 my %opts = @_;
198              
199 2         12 delete @$self{qw(exists failure track)};
200              
201 2         72 foreach my $opt (keys %num_presets, keys %char_presets) {
202 28         51 delete $self->{ucfirst $opt};
203             }
204 2         13 foreach my $opt (keys %$presets) {
205 14         41 $self->{ucfirst $opt} = $presets->{$opt};
206             }
207 2         8 foreach my $opt (keys %opts) {
208 0         0 $self->{ucfirst $opt} = $opts{$opt};
209             }
210              
211 2         8 $self->{track}{target}{dirs} = 0;
212 2         5 $self->{track}{target}{files} = 0;
213             }
214              
215             sub _gather_files
216             {
217 2     2   5 my $self = shift;
218              
219 2         4 my (@dirs, @files);
220              
221             File::Find::find({
222             wanted => sub {
223 22 100   22   236 push @dirs, $File::Find::name if -d $_;
224 22 100       1140 push @files, $File::Find::name if -f $_;
225             },
226 2         271 }, $self->{Source});
227              
228 2         14 shift @dirs; # remove top-level directory
229              
230 2         12 $self->{track}{source}{dirs} = scalar @dirs;
231 2         4 $self->{track}{source}{files} = scalar @files;
232              
233 2         21 return (\@dirs, \@files);
234             }
235              
236             sub _sort_files
237             {
238 1     1   2 my $self = shift;
239 1         3 my ($files) = @_;
240              
241 1         3 my %sort = (
242             asc => 'lc File::Basename::basename($a) cmp lc File::Basename::basename($b)',
243             desc => 'lc File::Basename::basename($b) cmp lc File::Basename::basename($a)',
244             );
245              
246 1         4 my $cmp = $sort{$self->{Sort}};
247              
248 1         7 @$files = sort { eval $cmp } @$files;
  12         665  
249             }
250              
251             sub _get_num_suffix
252             {
253 1     1   2 my $self = shift;
254              
255 1 50       4 if ($self->{Continue}) {
256 0         0 my @dirs;
257 0         0 $self->_read_dir($self->{Target}, \@dirs);
258              
259             # Leave files behind as we need to evaluate names of subdirs.
260 0         0 @dirs = grep { -d File::Spec->catfile($self->{Target}, $_) } @dirs;
  0         0  
261              
262 0         0 my $continue = 0;
263              
264 0         0 foreach my $dir (@dirs) {
265 0 0       0 if ($dir =~ /^(.+?)\Q$self->{Separator}\E([0-9]+)$/) {
266 0         0 my ($prefix, $suffix) = ($1, $2);
267 0 0 0     0 if ($prefix eq $self->{Prefix}
      0        
268             && length $suffix == $self->{Length}
269             && $suffix > $continue
270             ) {
271 0         0 $continue = $suffix;
272             }
273             }
274             }
275 0         0 return sprintf "%0.$self->{Length}d", ++$continue;
276             }
277             else {
278 1         16 return sprintf "%0.$self->{Length}d", 1;
279             }
280             }
281              
282             sub _get_char_suffixes
283             {
284 1     1   4 my $self = shift;
285 1         6 my ($files, $suffixes) = @_;
286              
287             my %alter = (
288 0     0   0 lower => sub { lc $_[0] },
289 7     7   17 upper => sub { uc $_[0] },
290 1         7 );
291              
292 1         4 foreach my $file (@$files) {
293 7         12 my $suffix = do {
294 7         144 local $_ = File::Basename::fileparse($file, qr/(?<=\S)\.[^.]*/); # returns filename
295 7         34 s/\s//g;
296 7         17 $_ = substr($_, 0, $self->{Length});
297 7         19 $alter{$self->{Case}}->($_);
298             };
299 7         10 push @{$suffixes->{$suffix}}, $file;
  7         25  
300             }
301             }
302              
303             sub _move_num
304             {
305 1     1   2 my $self = shift;
306 1         3 my ($files, $suffix) = @_;
307              
308 1         4 while (@$files) {
309 2         6 my $target_path = $self->_make_path($suffix);
310 2         3 my $copied = 0;
311 2         4 my %seen;
312 2   100     14 while ($copied < $self->{Limit} && @$files) {
313 7         15 my $file = shift @$files;
314 7         180 my $basename = File::Basename::basename($file);
315 7 50       21 if ($seen{$basename}) {
316 0         0 $self->_copy($file, $self->_make_path($suffix, $seen{$basename}));
317             }
318             else {
319 7         17 $self->_copy($file, $target_path);
320             }
321 7         19 $seen{$basename}++;
322 7         33 $copied++;
323             }
324 2         20 $suffix++;
325             }
326             }
327              
328             sub _move_char
329             {
330 1     1   2 my $self = shift;
331 1         2 my ($suffixes) = @_;
332              
333 1         7 foreach my $suffix (sort keys %$suffixes) {
334 7         26 my $target_path = $self->_make_path($suffix);
335 7         10 my %seen;
336 7         10 while (my $file = shift @{$suffixes->{$suffix}}) {
  14         57  
337 7         177 my $basename = File::Basename::basename($file);
338 7 50       19 if ($seen{$basename}) {
339 0         0 $self->_copy($file, $self->_make_path($suffix, $seen{$basename}));
340             }
341             else {
342 7         18 $self->_copy($file, $target_path);
343             }
344 7         22 $seen{$basename}++;
345             }
346             }
347             }
348              
349             sub _make_path
350             {
351 9     9   12 my $self = shift;
352 9         62 my ($suffix, $seen) = @_;
353              
354 9 50       117 my $target_path = File::Spec->catfile($self->{Target}, "$self->{Prefix}$self->{Separator}$suffix", defined $seen ? $seen : ());
355              
356 9 50       222 if (-e $target_path) {
357 0 0       0 croak "Target path `$target_path' is not a directory" unless -d $target_path;
358 0         0 return $target_path;
359             }
360              
361 9 50       529 if (File::Path::mkpath($target_path, $self->{Verbose})) {
362 9         631 $self->{track}{target}{dirs}++;
363             }
364             else {
365 0         0 croak "Target directory `$target_path' cannot be created: $!";
366             }
367              
368 9         27 return $target_path;
369             }
370              
371             sub _copy
372             {
373 14     14   31 my $self = shift;
374 14         29 my ($file, $target_path) = @_;
375              
376 14         20 my $source_file = $file;
377 14         355 my $target_file = File::Spec->catfile($target_path, File::Basename::basename($file));
378              
379 14 50 33     360 if (-e $target_file && !$self->{Override}) {
380 0         0 push @{$self->{exists}}, $target_file;
  0         0  
381 0         0 return;
382             }
383              
384 14 50       72 if (File::Copy::copy($source_file, $target_file)) {
385 14 50       3646 print "copy $source_file -> $target_file\n" if $self->{Verbose};
386 14         149 $self->{track}{target}{files}++;
387             }
388             else {
389 0           push @{$self->{failure}{copy}}, $target_file;
  0            
390             }
391             }
392              
393             sub _read_dir
394             {
395 0     0     my $self = shift;
396 0           my ($dir, $files) = @_;
397              
398 0 0         opendir(my $dh, $dir) or croak "Cannot open directory `$dir': $!";
399 0           @$files = grep !/^\.\.?$/, readdir($dh);
400 0 0         closedir($dh) or croak "Cannot close directory `$dir': $!";
401             }
402              
403             sub print_summary
404             {
405 0     0 1   my $self = shift;
406              
407 0 0         return unless exists $self->{track};
408              
409 0           my %track = %{$self->{track}};
  0            
410              
411             my @output = (
412             [ 'dirs', $track{source}{dirs}, $track{target}{dirs} ],
413 0           [ 'files', $track{source}{files}, $track{target}{files} ],
414             );
415              
416             format STDOUT_TOP =
417             Type Source Target
418             ==========================
419             .
420 0           foreach my $line (@output) {
421             format STDOUT =
422             @<<<<< @<<<<< @<<<<<
423             @$line
424             .
425 0           write;
426             }
427 0           print "\n";
428              
429 0 0         if (@{$self->{exists} || []}) {
  0 0          
430 0           print <<'EOT';
431             Existing files
432             ==============
433             EOT
434 0           foreach my $file (@{$self->{exists}}) {
  0            
435 0           print $file, "\n";
436             }
437 0           print "\n";
438             }
439 0 0         if (@{$self->{failure}{copy} || []}) {
  0 0          
440 0           print <<'EOT';
441             Copy failures
442             =============
443             EOT
444 0           foreach my $file (@{$self->{failure}{copy}}) {
  0            
445 0           print $file, "\n";
446             }
447             }
448             }
449              
450             1;
451             __END__