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

package File::ContentStore;
$File::ContentStore::VERSION = '1.004';
use 5.014;

use Carp qw( croak );
use Types::Standard qw( slurpy Object Bool Str ArrayRef HashRef CodeRef );
use Types::Path::Tiny qw( Dir File );
use Type::Params qw( compile );
use Digest;

use Moo;
use namespace::clean;

has path => (
    is       => 'ro',
    isa      => Dir,
    required => 1,
    coerce   => 1,
);

has digest => (
    is      => 'ro',
    isa     => Str,
    default => 'SHA-1',
);

has parts => (
    is => 'lazy',
    builder =>
      sub { int( length( Digest->new( shift->digest )->hexdigest ) / 32 ) },
    init_arg => undef,
);

has check_for_collisions => (
    is       => 'ro',
    isa      => Bool,
    required => 1,
    default  => 1,
);

has make_read_only => (
    is       => 'ro',
    isa      => Bool,
    required => 1,
    default  => 1,
);

has file_callback => (
    is        => 'ro',
    isa       => CodeRef,
    predicate => 1,
);

has inode => (
    is       => 'lazy',
    isa      => HashRef,
    init_arg => undef,
    builder  => sub {
        my ($self) = @_;
        my $re = qr{
            ^
            ${ \( '[a-f0-9][a-f0-9]/' x $self->parts ) }
            ${ \( '[a-f0-9]'
                  x ( length( Digest->new( $self->digest )->hexdigest )
                      - 2 * $self->parts ) ) }
            $
        }x;
        $self->path->visit(
            sub {
                my ( $path, $inode ) = @_;
                my $rel = $path->relative( $self->path )->stringify;
                $inode->{ $path->stat->ino } = $rel
                  if -f && $rel =~ $re;
            },
            { recurse => 1 }
        );
    },
);

# if a single non-hashref argument is given, assume it's 'path'
sub BUILDARGS {
    my $class = shift;
    scalar @_ == 1
      ? ref $_[0] eq 'HASH'
          ? { %{ $_[0] } }
          : { path => $_[0] }
      : @_ % 2 ? Carp::croak(
            "The new() method for $class expects a hash reference or a"
          . " key/value list. You passed an odd number of arguments" )
      : {@_};
}

sub BUILD {
    Digest->new( shift->digest );    # dies if 'digest' is not installed
}

my $BUFF_SIZE = 1024 * 32;
my $DIGEST_OPTS = { chunk_size => $BUFF_SIZE };

sub link_file {
    state $check = compile( Object, File );
    my ( $self, $file ) = $check->(@_);

    # skip non-files and symbolic links
    return unless -f $file && !-l $file;

    my ( $digest, $content, $done );

    # check if the file's inode is in the cache
    if ( $content = $self->inode->{ $file->stat->ino } ) {
        $digest  = $content =~ s{/}{}gr;
        $content = $self->path->child($content);
        $done    = 1;
    }

    # compute content file name
    else {
        $digest = $file->digest( $DIGEST_OPTS, $self->digest );
        $content =
          $self->path->child(
            map( { substr $digest, 2 * $_, 2 } 0 .. $self->parts - 1 ),
            substr( $digest, 2 * $self->parts ) );
    }

    $self->file_callback->( $file, $digest, $content )
       if $self->has_file_callback;

    # if the inode is already in our store, there's nothing left to do
    return if $done;

    # check for collisions
    if( -e $content && $self->check_for_collisions ) {
        croak "Collision found for $file and $content: size differs"
           if -s $file != -s $content;

        my @buf;
        my @fh = map $_->openr_raw, $file, $content;
        while( $fh[0]->sysread( $buf[0], $BUFF_SIZE ) ) {
            $fh[1]->sysread( $buf[1], $BUFF_SIZE );
            croak "Collision found for $file and $content: content differs"
                 if $buf[0] ne $buf[1];
        }
    }

    # link both files
    $content->parent->mkpath;
    my ( $old, $new ) = -e $content ? ( $content, $file ) : ( $file, $content );

    return if $old eq $new;    # do not link a file to itself
    $new->remove;
    link $old, $new or croak "Failed linking $new to $old: $!";

    # optionally remove the write permissions
    $old->chmod( $old->stat->mode & 07777 | 0222 ^ 0222 )
      if $self->make_read_only;

    # add the inode to the cache
    $self->inode->{ $content->stat->ino } =
      $content->relative( $self->path )->stringify;

    return $content;
}

sub link_dir {
    state $check = compile( Object, slurpy ArrayRef[Dir] );
    my ( $self, $dirs ) = $check->(@_);

    $_->visit( sub { $self->link_file($_) if -f }, { recurse => 1 } )
      for @$dirs;
}

sub fsck {
    my ($self) = @_;
    $self->path->visit(
        sub {
            my ( $path, $state ) = @_;

            if ( -d $path ) {

                # empty directory
                push @{ $state->{empty} }, $path unless $path->children;
            }
            elsif( -l $path ) {
                push @{ $state->{symlink} }, $path;
            }
            else {

                # orphan content file
                push @{ $state->{orphan} }, $path
                  if $path->stat->nlink == 1;

                # content does not match name
                my $digest = $path->digest( $DIGEST_OPTS, $self->digest );
                push @{ $state->{corrupted} }, $path
                  if $digest ne $path->relative( $self->path ) =~ s{/}{}gr;
            }
        },
        { recurse => 1 },
    );
}

1;

__END__