view release on metacpan or  search on metacpan

lib/App/Hashl.pm  view on Meta::CPAN

package App::Hashl;

use strict;
use warnings;
use 5.010;

use Digest::SHA;
use Storable qw(nstore retrieve);

our $VERSION = '1.01';

sub new {
	my ( $obj, %conf ) = @_;

	my $ref = {
		files   => {},
		ignored => {},
	};

	$ref->{config} = \%conf;
	$ref->{config}->{read_size} //= ( 2**20 ) * 4;    # 4 MiB
	$ref->{version} = $VERSION;

	return bless( $ref, $obj );
}

sub new_from_file {
	my ( $obj, $file ) = @_;

	my $ref = retrieve($file);

	if ( not defined $ref->{version} ) {
		$ref->{version} = '1.00';
	}

	return bless( $ref, $obj );
}

sub si_size {
	my ( $self, $bytes ) = @_;
	my @post = ( q{ }, qw(k M G T) );

	if ( $bytes == 0 ) {
		return 'infinite';
	}

	while ( $bytes >= 1024 ) {
		$bytes /= 1024;
		shift @post;
	}

	return sprintf( '%6.1f%s', $bytes, $post[0] );
}

sub hash_file {
	my ( $self, $file ) = @_;
	my $data;
	my $digest = Digest::SHA->new(1);

	# read() fails for empty files
	if ( ( stat($file) )[7] == 0 ) {
		return $digest->hexdigest;
	}
	if ( $self->{config}->{read_size} == 0 ) {
		$digest->addfile($file);
		return $digest->hexdigest;
	}

	#<<< perltidy has problems indenting 'or die' with tabs

	open( my $fh, '<', $file )
		or die("Can't open ${file} for reading: $!\n");
	binmode($fh)
		or die("Can't set binmode on ${file}: $!\n");
	read( $fh, $data, $self->{config}->{read_size} )
		or die("Can't read ${file}: $!\n");
	close($fh)
		or die("Can't close ${file}: $!\n");

	#>>>
	$digest->add($data);
	return $digest->hexdigest;
}

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

	if ( $self->{ignored}->{$hash} ) {
		return '// ignored';
	}

	for my $name ( $self->files() ) {
		my $file = $self->file($name);

		if ( $file->{hash} eq $hash ) {
			return $name;
		}
	}
	return;
}

sub file_in_db {
	my ( $self, $file ) = @_;

	return $self->hash_in_db( $self->hash_file($file) );
}

sub read_size {
	my ($self) = @_;

	return $self->{config}->{read_size};
}

sub db_info {
	my ($self) = @_;

	return sprintf(
		"Database created by hashl v%s\n"
		  . "Read size: %d bytes (%s)\n"
		  . "contains: %d file%s and %d ignored hash%s\n",
		$self->db_version,
		$self->read_size,
		$self->si_size( $self->read_size ),
		scalar( $self->files ),
		( scalar( $self->files ) == 1 ? q{} : 's' ),
		scalar( $self->ignored ),
		( scalar( $self->ignored ) == 1 ? q{} : 'es' ),
	);
}

sub db_version {
	my ($self) = @_;

	return $self->{version};
}

sub file {
	my ( $self, $name ) = @_;

	return $self->{files}->{$name};
}

sub delete_file {
	my ( $self, $name ) = @_;

	delete $self->{files}->{$name};

	return 1;
}

sub files {
	my ($self) = @_;

	return keys %{ $self->{files} };
}

sub add_file {
	my ( $self, %opt ) = @_;
	my $file = $opt{file};
	my $path = $opt{path};
	my ( $size, $mtime ) = ( stat($path) )[ 7, 9 ];

	if (    $self->file($file)
		and $self->file($file)->{mtime} == $mtime
		and $self->file($file)->{size} == $size )
	{
		return;
	}

	my $hash = $self->hash_file($path);

	if ( $self->{ignored}->{$hash} ) {
		if ( $opt{unignore} ) {
			$self->unignore($hash);
		}
		else {
			return;
		}
	}

	$self->{files}->{$file} = {
		hash  => $hash,
		mtime => $mtime,
		size  => $size,
	};

	return 1;
}

sub ignored {
	my ($self) = @_;

	if ( exists $self->{ignored} ) {
		return keys %{ $self->{ignored} };
	}

	return ();
}

sub ignore {
	my ( $self, $file, $path ) = @_;

	$self->delete_file($file);
	$self->{ignored}->{ $self->hash_file($path) } = 1;

	return 1;
}

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

	delete $self->{ignored}->{$hash};

	return 1;
}

sub save {
	my ( $self, $file ) = @_;

	return nstore( $self, $file );
}