File Coverage

blib/lib/Debian/Snapshot/File.pm

Criterion	Covered	Total	%
statement	16	66	24.2
branch	0	38	0.0
condition	0	9	0.0
subroutine	6	11	54.5
pod	3	3	100.0
total	25	127	19.6

package Debian::Snapshot::File;
BEGIN {
  $Debian::Snapshot::File::VERSION = '0.003';
}
# ABSTRACT: information about a file

use Any::Moose;

use Digest::SHA1;
use File::Spec;
use List::MoreUtils qw( uniq );

has 'hash' => (
	is       => 'ro',
	isa      => 'Str',
	required => 1,
);

has '_fileinfo' => (
	is      => 'ro',
	isa     => 'ArrayRef[HashRef]',
	lazy    => 1,
	builder => '_fileinfo_builder',
);

has '_service' => (
	is       => 'ro',
	isa      => 'Debian::Snapshot',
	required => 1,
);

sub archive {
	my ($self, $archive_name) = @_;

	$archive_name = qr/^\Q$archive_name\E$/ unless ref($archive_name) eq 'Regexp';

	my @archives = map $_->{archive_name}, @{ $self->_fileinfo };
	return 0 != grep $_ =~ $archive_name, @archives;
}

sub _checksum {
	my ($self, $filename) = @_;

	open my $fp, "<", $filename;
	binmode $fp;

	my $sha1 = Digest::SHA1->new->addfile($fp)->hexdigest;

	close $fp;

	return lc($self->hash) eq lc($sha1);
}

sub download {
	my ($self, %p) = @_;
	my $hash = $self->hash;

	unless (defined $p{directory} || defined $p{filename}) {
		die "One of 'directory', 'file' parameters must be given.";
	}
	if (ref($p{filename}) eq 'Regexp' && ! defined $p{directory}) {
		die "Parameter 'directory' is required if 'filename' is a regular expression.";
	}

	my $filename = $p{filename};
	if (ref($p{filename}) eq 'Regexp' || ! defined $filename) {
		$filename = $self->filename($p{archive_name}, $p{filename});
	}

	if (defined $p{directory}) {
		$filename = File::Spec->catfile($p{directory}, $filename);
	}

	if (-f $filename) {
		return $filename if $self->_checksum($filename);
		die "$filename does already exist." unless $p{overwrite};
	}

	$self->_service->_get("/file/$hash", ':content_file' => $filename);
	die "Wrong checksum for '$filename' (expected " . $self->hash . ")." unless $self->_checksum($filename);

	return $filename;
}

sub filename {
	my ($self, $archive_name, $constraint) = @_;
	my $hash = $self->hash;

	my @fileinfo = @{ $self->_fileinfo };

	if (defined $archive_name) {
		$archive_name = qr/^\Q$archive_name\E$/ unless ref($archive_name) eq 'Regexp';
		@fileinfo = grep $_->{archive_name} =~ $archive_name, @fileinfo;
	}

	my @names    = uniq map $_->{name}, @fileinfo;
	die "No filename found for file $hash." unless @names;

	if (defined $constraint) {
		$constraint = qr/^\Q$constraint\E_/ unless ref($constraint) eq 'Regexp';
		@names = grep $_ =~ $constraint, @names;
		die "No matching filename found for file $hash." unless @names;
	}

	return @names if wantarray;
	die "More than one filename and calling function does not want a list." unless @names == 1;

	my $filename = $names[0];

	die "Filename contains a slash." if $filename =~ m{/};
	die "Filename does not start with an alphanumeric character." unless $filename =~ m{^[a-zA-Z0-9]};

	return $filename;
}

sub _fileinfo_builder {
	my $self = shift;
	my $hash = $self->hash;
	$self->_service->_get_json("/mr/file/$hash/info")->{result};
}

no Any::Moose;
1;



=pod

=head1 NAME

Debian::Snapshot::File - information about a file

=head1 VERSION

version 0.003

=head1 ATTRIBUTES

=head2 hash

The hash of this file.

=head1 METHODS

=head2 archive($archive_name)

Check if this file belongs to the archive C<$archive_name> which can either be
a string or a regular expression.

=head2 download(%params)

Download the file from the snapshot service.

=over

=item archive_name

(Optional.) Name of the archive used when looking for the filename.

=item directory

The name of the directory where the file should be stored.

=item filename

The filename to use.  If this option is not specified the method C
will be used to retrieve the filename.

=item overwrite

If true downloading will overwrite existing files if their hash differs from
the expected value.  Defaults to false.

=back

At least one of C and C must be given.

=head2 filename($archive_name?, $constraint?)

Return the filename(s) of this file in the archive C<$archive_name> (which
might be a string or a regular expression).  Will die if there is no known
filename or several filenames were want and the method is called in scalar
context.

If the optional parameter C<$constraint> is specified the filename must either
start with this string followed by an underscore or match this regular
expression.

=head1 SEE ALSO

L

=head1 AUTHOR

  Ansgar Burchardt

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Ansgar Burchardt .

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut


__END__