File Coverage

blib/lib/File/ContentStore.pm
Criterion Covered Total %
statement 81 81 100.0
branch 38 42 90.4
condition 7 9 77.7
subroutine 18 18 100.0
pod 3 5 60.0
total 147 155 94.8


line stmt bran cond sub pod time code
1             package File::ContentStore;
2             $File::ContentStore::VERSION = '1.001';
3 2     2   217682 use 5.014;
  2         39  
4              
5 2     2   18 use Carp qw( croak );
  2         6  
  2         181  
6 2     2   1445 use Types::Standard qw( slurpy Object Bool Str ArrayRef HashRef CodeRef );
  2         196269  
  2         36  
7 2     2   5898 use Types::Path::Tiny qw( Dir File );
  2         67422  
  2         24  
8 2     2   2798 use Type::Params qw( compile );
  2         31867  
  2         25  
9 2     2   1783 use Digest;
  2         1464  
  2         81  
10              
11 2     2   1238 use Moo;
  2         28914  
  2         23  
12 2     2   5587 use namespace::clean;
  2         35348  
  2         20  
13              
14             has path => (
15             is => 'ro',
16             isa => Dir,
17             required => 1,
18             coerce => 1,
19             );
20              
21             has digest => (
22             is => 'ro',
23             isa => Str,
24             default => 'SHA-1',
25             );
26              
27             has parts => (
28             is => 'lazy',
29             builder =>
30 6     6   132 sub { int( length( Digest->new( shift->digest )->hexdigest ) / 32 ) },
31             init_arg => undef,
32             );
33              
34             has check_for_collisions => (
35             is => 'ro',
36             isa => Bool,
37             required => 1,
38             default => 1,
39             );
40              
41             has make_read_only => (
42             is => 'ro',
43             isa => Bool,
44             required => 1,
45             default => 1,
46             );
47              
48             has file_callback => (
49             is => 'ro',
50             isa => CodeRef,
51             predicate => 1,
52             );
53              
54             has inode => (
55             is => 'lazy',
56             isa => HashRef,
57             init_arg => undef,
58             builder => sub {
59 6     6   6664 my ($self) = @_;
60 6         22 my $re = qr{
61             ^
62 6         196 ${ \( '[a-f0-9][a-f0-9]/' x $self->parts ) }
63 6         428 ${ \( '[a-f0-9]'
64             x ( length( Digest->new( $self->digest )->hexdigest )
65             - 2 * $self->parts ) ) }
66             $
67             }x;
68             $self->path->visit(
69             sub {
70 4     4   1329 my ( $path, $inode ) = @_;
71 4         28 my $rel = $path->relative( $self->path )->stringify;
72 4 100 66     1400 $inode->{ $path->stat->ino } = $rel
73             if -f && $rel =~ $re;
74             },
75 6         1042 { recurse => 1 }
76             );
77             },
78             );
79              
80             # if a single non-hashref argument is given, assume it's 'path'
81             sub BUILDARGS {
82 8     8 0 123113 my $class = shift;
83             scalar @_ == 1
84             ? ref $_[0] eq 'HASH'
85 8 100       304 ? { %{ $_[0] } }
  1 50       694  
    100          
86             : { path => $_[0] }
87             : @_ % 2 ? Carp::croak(
88             "The new() method for $class expects a hash reference or a"
89             . " key/value list. You passed an odd number of arguments" )
90             : {@_};
91             }
92              
93             sub BUILD {
94 7     7 0 4901 Digest->new( shift->digest ); # dies if 'digest' is not installed
95             }
96              
97             my $BUFF_SIZE = 1024 * 32;
98             my $DIGEST_OPTS = { chunk_size => $BUFF_SIZE };
99              
100             sub link_file {
101 16     16 1 411 state $check = compile( Object, File );
102 16         4061 my ( $self, $file ) = $check->(@_);
103              
104             # skip non-files and symbolic links
105 16 100 66     1435 return unless -f $file && !-l $file;
106              
107 12         601 my ( $digest, $content, $done );
108              
109             # check if the file's inode is in the cache
110 12 100       458 if ( $content = $self->inode->{ $file->stat->ino } ) {
111 2         984 $digest = $content =~ s{/}{}gr;
112 2         15 $content = $self->path->child($content);
113 2         120 $done = 1;
114             }
115              
116             # compute content file name
117             else {
118 10         14587 $digest = $file->digest( $DIGEST_OPTS, $self->digest );
119             $content =
120             $self->path->child(
121 10         5902 map( { substr $digest, 2 * $_, 2 } 0 .. $self->parts - 1 ),
  10         446  
122             substr( $digest, 2 * $self->parts ) );
123             }
124              
125 12 100       1027 $self->file_callback->( $file, $digest, $content )
126             if $self->has_file_callback;
127              
128             # if the inode is already in our store, there's nothing left to do
129 12 100       2280 return if $done;
130              
131             # check for collisions
132 10 100 100     68 if( -e $content && $self->check_for_collisions ) {
133 2 50       101 croak "Collision found for $file and $content: size differs"
134             if -s $file != -s $content;
135              
136 2         107 my @buf;
137 2         18 my @fh = map $_->openr_raw, $file, $content;
138 2         688 while( $fh[0]->sysread( $buf[0], $BUFF_SIZE ) ) {
139 3         110 $fh[1]->sysread( $buf[1], $BUFF_SIZE );
140 3 100       121 croak "Collision found for $file and $content: content differs"
141             if $buf[0] ne $buf[1];
142             }
143             }
144              
145             # link both files
146 9         363 $content->parent->mkpath;
147 9 100       2613 my ( $old, $new ) = -e $content ? ( $content, $file ) : ( $file, $content );
148              
149 9 50       346 return if $old eq $new; # do not link a file to itself
150 9         141 $new->remove;
151 9 50       485 link $old, $new or croak "Failed linking $new to $old: $!";
152              
153             # optionally remove the write permissions
154 9 100       498 $old->chmod( $old->stat->mode & 07777 | 0222 ^ 0222 )
155             if $self->make_read_only;
156              
157             # add the inode to the cache
158 9         2325 $self->inode->{ $content->stat->ino } =
159             $content->relative( $self->path )->stringify;
160              
161 9         5407 return $content;
162             }
163              
164             sub link_dir {
165 5     5 1 4821 state $check = compile( Object, slurpy ArrayRef[Dir] );
166 5         24064 my ( $self, $dirs ) = $check->(@_);
167              
168 18 100   18   3806 $_->visit( sub { $self->link_file($_) if -f }, { recurse => 1 } )
169 5         878 for @$dirs;
170             }
171              
172             sub fsck {
173 2     2 1 12308 my ($self) = @_;
174             $self->path->visit(
175             sub {
176 14     14   5711 my ( $path, $state ) = @_;
177              
178 14 100       79 if ( -d $path ) {
    100          
179              
180             # empty directory
181 7 100       196 push @{ $state->{empty} }, $path unless $path->children;
  1         117  
182             }
183             elsif( -l $path ) {
184 1         58 push @{ $state->{symlink} }, $path;
  1         10  
185             }
186             else {
187              
188             # orphan content file
189 6 100       318 push @{ $state->{orphan} }, $path
  1         326  
190             if $path->stat->nlink == 1;
191              
192             # content does not match name
193 6         1551 my $digest = $path->digest( $DIGEST_OPTS, $self->digest );
194 6 100       3937 push @{ $state->{corrupted} }, $path
  1         390  
195             if $digest ne $path->relative( $self->path ) =~ s{/}{}gr;
196             }
197             },
198 2         41 { recurse => 1 },
199             );
200             }
201              
202             1;
203              
204             __END__