File Coverage

blib/lib/App/rshasum.pm
Criterion Covered Total %
statement 56 62 90.3
branch 12 16 75.0
condition 2 2 100.0
subroutine 10 11 90.9
pod 1 1 100.0
total 81 92 88.0


line stmt bran cond sub pod time code
1             package App::rshasum;
2             $App::rshasum::VERSION = '0.8.0';
3 2     2   172024 use 5.016;
  2         31  
4 2     2   12 use strict;
  2         4  
  2         41  
5 2     2   10 use warnings;
  2         2  
  2         55  
6              
7 2     2   1212 use File::Find::Object ();
  2         25416  
  2         47  
8 2     2   1007 use Digest ();
  2         1152  
  2         85  
9              
10 2     2   1646 use Getopt::Long qw/ GetOptions /;
  2         22065  
  2         10  
11 2     2   394 use List::Util 1.33 qw/ any /;
  2         49  
  2         1152  
12              
13             sub _worker
14             {
15 3     3   1885 my ( $self, $args ) = @_;
16              
17 3         7 my $digest = $args->{digest};
18 3         7 my $output_cb = $args->{output_cb};
19 3 100       4 my @prunes = ( map { qr/$_/ } @{ $args->{prune_re} || [] } );
  2         12  
  3         14  
20 3   100     15 my $start_path = ( $args->{start_path} // "." );
21              
22 3         14 my $t = Digest->new($digest);
23              
24 3         3373 my $ff = File::Find::Object->new( {}, $start_path );
25             FILES:
26 3         648 while ( my $r = $ff->next_obj )
27             {
28 18         4817 my $path = join '/', @{ $r->full_components };
  18         46  
29 18 100       165 if (@prunes)
30             {
31 12 100   12   63 if ( any { $path =~ $_ } @prunes )
  12         77  
32             {
33 2         11 $ff->prune;
34 2         177 next FILES;
35             }
36             }
37 16 100       58 if ( $r->is_file )
38             {
39 10         16 my $fh;
40 10 50       385 if ( not( open $fh, '<', $r->path ) )
41             {
42 0         0 warn "Could not open @{[$r->path]} ; skipping";
  0         0  
43 0         0 next FILES;
44             }
45 10         39 binmode $fh;
46 10         54 my $d = Digest->new($digest);
47 10         370 $d->addfile($fh);
48 10         416 close $fh;
49 10         103 my $s = $d->hexdigest . ' ' . $path . "\n";
50 10         47 $output_cb->( { str => $s } );
51 10         124 $t->add($s);
52             }
53             }
54 3         362 my $s = $t->hexdigest . ' ' . "-" . "\n";
55 3         16 $output_cb->( { str => $s } );
56              
57 3         72 return;
58             }
59              
60             sub run
61             {
62 1     1 1 97 my $digest;
63             my @skips;
64 1         3 my $start_path = '.';
65 1 50       6 GetOptions(
66             'digest=s' => \$digest,
67             'skip=s' => \@skips,
68             'start-path=s' => \$start_path,
69             ) or die "Unknown flags $!";
70 1 50       619 if ( not defined($digest) )
71             {
72 0         0 die "Please give a --digest=[digest] argument.";
73             }
74 1 50       5 if (@ARGV)
75             {
76 1         14 die
77             qq#Leftover arguments "@ARGV" in the command line. (Did you intend to use --start-path ?)#;
78             }
79             return shift()->_worker(
80             {
81             digest => $digest,
82 0     0     output_cb => sub { print shift()->{str}; },
83 0           prune_re => ( \@skips ),
84             start_path => $start_path,
85             }
86             );
87             }
88              
89             1;
90              
91             __END__