File Coverage

blib/lib/DataStore/CAS.pm

Criterion	Covered	Total	%
statement	137	197	69.5
branch	46	104	44.2
condition	36	91	39.5
subroutine	37	63	58.7
pod	26	26	100.0
total	282	481	58.6

package DataStore::CAS;
use 5.008;
use Moo::Role;
use Carp;
use Try::Tiny;
require Scalar::Util;
require Symbol;

our $VERSION= '0.05';
our @CARP_NOT= qw( DataStore::CAS::File DataStore::CAS::VirtualHandle );

# ABSTRACT: Abstract base class for Content Addressable Storage


requires 'digest';

has hash_of_null => ( is => 'lazy' );

sub _build_hash_of_null {
	return shift->calculate_hash('');
}


requires 'get';


sub _thing_stringifies_to_filename {
	my $ref= ref $_[0];
	(!$ref && defined $_[0])
		|| $ref->isa('Path::Class::File')
		|| $ref->isa('Path::Tiny')
		|| $ref->isa('File::Temp')
}

sub put {
	my $ref= ref $_[1];
	goto $_[0]->can('put_scalar')
		if !$ref || $ref eq 'SCALAR';
	goto $_[0]->can('put_file')
		if $ref->isa('DataStore::CAS::File')
		or _thing_stringifies_to_filename($_[1]);
	goto $_[0]->can('put_handle')
		if $ref->isa('IO::Handle')
		or Scalar::Util::reftype($_[1]) eq 'GLOB';
	croak("Can't 'put' object of type $ref");
}


sub put_scalar {
	my ($self, undef, $flags)= @_;
	my $ref= ref $_[1] eq 'SCALAR'? $_[1] : \$_[1];

	# Force to plain string if it is an object
	if (ref $$ref) {
		# TODO: croak unless object has stringify magic
		$ref= \"$$ref";
	}

	# Can only 'put' octets, not wide-character unicode strings.
	utf8::downgrade($$ref, 1)
		or croak "scalar must be byte string (octets).  If storing unicode,"
			." you must reduce to a byte encoding first.";

	my $hash= $flags && $flags->{known_hashes} && $flags->{known_hashes}{$self->digest}
		? $flags->{known_hashes}{$self->digest}
		: $self->calculate_hash($ref);
	if ($self->get($hash)) {
		# Already have it
		$flags->{stats}{dup_file_count}++
			if $flags->{stats};
		return $hash;
	} else {
		$flags= { ($flags? %$flags : ()), known_hashes => { $self->digest => $hash } };
		my $handle= $self->new_write_handle($flags);
		$handle->_write_all($$ref);
		return $self->commit_write_handle($handle);
	}
}


sub put_file {
	my ($self, $file, $flags)= @_;
	my $ref= ref $file;
	my $is_cas_file= $ref && $ref->isa('DataStore::CAS::File');
	my $is_filename= _thing_stringifies_to_filename($file);
	croak "Unhandled argument to put_file: ".($file||'(undef)')
		unless defined $file && ($is_cas_file || $is_filename);

	my %known_hashes= $flags->{known_hashes}? %{$flags->{known_hashes}} : ();
	# Apply reuse_hash feature, if requested
	if ($is_cas_file && $flags->{reuse_hash}) {
		$known_hashes{$file->store->digest}= $file->hash;
		$flags= { %$flags, known_hashes => \%known_hashes };
	}
	# It is probably better to read a file twice than to write one that
	# doesn't need to be written.
	# ...but can't do better than ->put_handle unless the file is a real file.
	my $fname= $is_filename? "$file"
		: $is_cas_file && $file->can('local_file')? $file->local_file
		: undef;
	if ($known_hashes{$self->digest} || (defined $fname && -f $fname)) {
		# Calculate the hash if it wasn't given.
		my $hash= ($known_hashes{$self->digest} ||= $self->calculate_file_hash($fname));
		# Avoid unnecessary work
		if ($self->get($hash)) {
			$flags->{stats}{dup_file_count}++
				if $flags->{stats};
			$self->_unlink_source_file($file, $flags)
				if $flags->{move} && defined $fname;
			return $hash;
		}
		# Save hash for next step
		$flags= { %$flags, known_hashes => \%known_hashes };
	}
	my $fh;
	if ($is_cas_file) {
		$fh= $file->open or croak "Can't open '$file': $!";
	}
	elsif ($ref && $ref->can('openr')) {
		$fh= $file->openr or croak "Can't open '$file': $!";
	}
	elsif ($is_filename) {
		open($fh, '<', $fname) or croak "Can't open '$fname': $!";
	}
	else {
		croak "Don't know how to open '$file'";
	}
	my $hash= $self->put_handle($fh, $flags);
	$self->_unlink_source_file($file, $flags)
		if $hash && $flags->{move};
	return $hash;
}

sub _unlink_source_file {
	my ($self, $file, $flags)= @_;
	return if $flags->{dry_run};
	my $is_cas_file= ref $file && ref($file)->isa('DataStore::CAS::File');
	if ($is_cas_file) {
		croak "Refusing to delete origin CAS File (this can damage a CAS)\n"
			."If you really want to do this, pass \$file->local_name and then"
			." delete the cas entry yourself.";
	} else {
		if (ref $file && ref($file)->isa('File::Temp')) {
			# The Simple backend closes File::Temp files to ensure they don't
			# get written to any more. so match that behavior here.
			$file->close;
		}
		unlink "$file" or croak "unlink($file): $!"
	}
}


sub put_handle {
	my ($self, $h_in, $flags)= @_;
	binmode $h_in;
	my $h_out= $self->new_write_handle($flags);
	my $buf_size= $flags->{buffer_size} || 1024*1024;
	my $buf;
	while(1) {
		my $got= read($h_in, $buf, $buf_size);
		if ($got) {
			$h_out->_write_all($buf) or croak "write: $!";
		} elsif (!defined $got) {
			next if ($!{EINTR} || $!{EAGAIN});
			croak "read: $!";
		} else {
			last;
		}
	}
	return $self->commit_write_handle($h_out);
}


# This implementation probably needs overridden by subclasses.
sub new_write_handle {
	my ($self, $flags)= @_;
	return DataStore::CAS::FileCreatorHandle->new($self, { flags => $flags });
}

# This must be implemented by subclasses
requires 'commit_write_handle';


sub calculate_hash {
	my $self= shift;
	Digest->new($self->digest)->add(ref $_[0]? ${$_[0]} : $_[0])->hexdigest;
}

sub calculate_file_hash {
	my ($self, $file)= @_;
	open my $fh, '<', $file or croak "open($file): $!";
	binmode $fh;
	Digest->new($self->digest)->addfile($fh)->hexdigest;
}


sub validate {
	my ($self, $hash, $flags)= @_;

	my $file= $self->get($hash);
	return undef unless defined $file;

	# Exceptions during 'put' will most likely come from reading $file,
	# which means that validation fails, and we return false.
	my $new_hash;
	try {
		# We don't pass flags directly through to get/put, because flags for validate
		#  are not the same as flags for get or put.  But, 'stats' is a standard thing.
		my %args= ( dry_run => 1 );
		$args{stats}= $flags->{stats} if $flags->{stats};
		$new_hash= $self->put_handle($file, \%args);
	}
	catch {
	};
	return (defined $new_hash and $new_hash eq $hash)? 1 : 0;
}


requires 'delete';


requires 'iterator';


requires 'open_file';

# File and Handle objects have DESTROY methods that call these methods of
# their associated CAS.  The CAS should implement these for cleanup of
# temporary files, or etc.
sub _file_destroy {}
sub _handle_destroy {}

package DataStore::CAS::File;
use strict;
use warnings;

our $VERSION= '0.05';

sub store { $_[0]{store} }
sub hash  { $_[0]{hash} }
sub size  { $_[0]{size} }

sub open {
	my $self= shift;
	return $self->{store}->open_file($self)
		if @_ == 0;
	return $self->{store}->open_file($self, { @_ })
		if @_ > 1;
	return $self->{store}->open_file($self, { layer => $_[0] })
		if @_ == 1 and !ref $_[0];
	Carp::croak "Wrong arguments to 'open'";
};

sub DESTROY {
	$_[0]{store}->_file_destroy(@_);
}

our $AUTOLOAD;
sub AUTOLOAD {
	my $attr= substr($AUTOLOAD, rindex($AUTOLOAD, ':')+1);
	return $_[0]{$attr} if exists $_[0]{$attr};
	unshift @_, $_[0]{store};
	goto (
		$_[0]->can("_file_$attr")
		or Carp::croak "Can't locate object method \"_file_$attr\" via package \"".ref($_[0]).'"'
	);
}

package DataStore::CAS::VirtualHandle;
use strict;
use warnings;

our $VERSION= '0.05';

sub new {
	my ($class, $cas, $fields)= @_;
	my $glob= bless Symbol::gensym(), $class;
	${*$glob}= $cas;
	%{*$glob}= %{$fields||{}};
	tie *$glob, $glob;
	$glob;
}
sub TIEHANDLE { return $_[0]; }

sub _cas  { ${*${$_[0]}} }  # the scalar view of the symbol points to the CAS object
sub _data { \%{*${$_[0]}} } # the hashref view of the symbol holds the fields of the handle

sub DESTROY { unshift @_, ${*{$_[0]}}; goto $_[0]->can('_handle_destroy') }

# By default, any method not defined will call to C<$cas->_handle_$method( $handle, @args );>
our $AUTOLOAD;
sub AUTOLOAD {
	unshift @_, ${*${$_[0]}}; # unshift @_, $self->_cas
	my $attr= substr($AUTOLOAD, rindex($AUTOLOAD, ':')+1);
	goto (
		$_[0]->can("_handle_$attr")
		or Carp::croak "Can't locate object method \"_handle_$attr\" via package \"".ref($_[0]).'"'
	);
}

#
# Tied filehandle API
#

sub READ     { (shift)->read(@_) }
sub READLINE { wantarray? (shift)->getlines : (shift)->getline }
sub GETC     { $_[0]->getc }
sub EOF      { $_[0]->eof }

sub WRITE    { (shift)->write(@_) }
sub PRINT    { (shift)->print(@_) }
sub PRINTF   { (shift)->printf(@_) }

sub SEEK     { (shift)->seek(@_) }
sub TELL     { (shift)->tell(@_) }

sub FILENO   { $_[0]->fileno }
sub CLOSE    { $_[0]->close }

#
# The following are some default implementations to make subclassing less cumbersome.
#

sub getlines {
	my $self= shift;
	wantarray or !defined wantarray or Carp::croak "getlines called in scalar context";
	my (@ret, $line);
	push @ret, $line
		while defined ($line= $self->getline);
	@ret;
}

# I'm not sure why anyone would ever want this function, but I'm adding
#  it for completeness.
sub getc {
	my $c;
	$_[0]->read($c, 1)? $c : undef;
}

# 'write' does not guarantee that all bytes get written in one shot.
# Needs to be called in a loop to accomplish "print" semantics.
sub _write_all {
	my ($self, $str)= @_;
	while (1) {
		my $wrote= $self->write($str);
		return 1 if defined $wrote and ($wrote eq length $str);
		return undef unless defined $wrote or $!{EINTR} or $!{EAGAIN};
		substr($str, 0, $wrote)= '';
	}
}

# easy to forget that 'print' API involves "$," and "$\"
sub print {
	my $self= shift;
	my $str= join( (defined $, ? $, : ""), @_ );
	$str .= $\ if defined $\;
	$self->_write_all($str);
}

# as if anyone would want to write their own printf implementation...
sub printf {
	my $self= shift;
	my $str= sprintf($_[0], $_[1..$#_]);
	$self->_write_all($str);
}

# virtual handles are unlikely to have one, and if they did, they wouldn't
# be using this class
sub fileno { undef; }

package DataStore::CAS::FileCreatorHandle;
use strict;
use warnings;
use parent -norequire => 'DataStore::CAS::VirtualHandle';

our $VERSION= '0.05';

# For write-handles, commit data to the CAS and return the digest hash for it.
sub commit   { $_[0]->_cas->commit_write_handle(@_) }

# These would happen anyway via the AUTOLOAD, but we enumerate them so that
# they officially appear as methods of this class.
sub close    { $_[0]->_cas->_handle_close(@_) }
sub seek     { $_[0]->_cas->_handle_seek(@_) }
sub tell     { $_[0]->_cas->_handle_tell(@_) }
sub write    { $_[0]->_cas->_handle_write(@_) }

# This is a write-only handle
sub eof      { return 1; }
sub read     { return 0; }
sub readline { return undef; }


1;

__END__