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.6.4';
3 2     2   169191 use 5.016;
  2         28  
4 2     2   11 use strict;
  2         3  
  2         40  
5 2     2   10 use warnings;
  2         4  
  2         48  
6              
7 2     2   1118 use File::Find::Object ();
  2         24961  
  2         48  
8 2     2   971 use Digest ();
  2         1168  
  2         57  
9              
10 2     2   1540 use Getopt::Long qw/ GetOptions /;
  2         21273  
  2         9  
11 2     2   342 use List::Util 1.33 qw/ any /;
  2         37  
  2         1226  
12              
13             sub _worker
14             {
15 3     3   1849 my ( $self, $args ) = @_;
16              
17 3         7 my $digest = $args->{digest};
18 3         6 my $output_cb = $args->{output_cb};
19 3 100       5 my @prunes = ( map { qr/$_/ } @{ $args->{prune_re} || [] } );
  2         12  
  3         15  
20 3   100     17 my $start_path = ( $args->{start_path} // "." );
21              
22 3         14 my $t = Digest->new($digest);
23              
24 3         3267 my $ff = File::Find::Object->new( {}, $start_path );
25             FILES:
26 3         627 while ( my $r = $ff->next_obj )
27             {
28 18         4727 my $path = join '/', @{ $r->full_components };
  18         46  
29 18 100       162 if (@prunes)
30             {
31 12 100   12   61 if ( any { $path =~ $_ } @prunes )
  12         76  
32             {
33 2         10 $ff->prune;
34 2         172 next FILES;
35             }
36             }
37 16 100       63 if ( $r->is_file )
38             {
39 10         17 my $fh;
40 10 50       382 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         38 binmode $fh;
46 10         52 my $d = Digest->new($digest);
47 10         362 $d->addfile($fh);
48 10         422 close $fh;
49 10         104 my $s = $d->hexdigest . ' ' . $path . "\n";
50 10         46 $output_cb->( { str => $s } );
51 10         122 $t->add($s);
52             }
53             }
54 3         372 my $s = $t->hexdigest . ' ' . "-" . "\n";
55 3         13 $output_cb->( { str => $s } );
56              
57 3         70 return;
58             }
59              
60             sub run
61             {
62 1     1 1 93 my $digest;
63             my @skips;
64 1         3 my $start_path = '.';
65 1 50       7 GetOptions(
66             'digest=s' => \$digest,
67             'skip=s' => \@skips,
68             'start-path=s' => \$start_path,
69             ) or die "Unknown flags $!";
70 1 50       554 if ( not defined($digest) )
71             {
72 0         0 die "Please give a --digest=[digest] argument.";
73             }
74 1 50       4 if (@ARGV)
75             {
76 1         13 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__