view release on metacpan or  search on metacpan

bin/hashl  view on Meta::CPAN

#!/usr/bin/env perl
## Copyright © 2010 by Daniel Friesel <derf@finalrewind.org>
## License: WTFPL <http://sam.zoy.org/wtfpl>
##   0. You just DO WHAT THE FUCK YOU WANT TO.
use strict;
use warnings;
use 5.010;

no if $] >= 5.018, warnings => 'experimental::smartmatch';

use App::Hashl;
use Cwd;
use DateTime;
use File::Copy;
use File::Find;
use Getopt::Long;
use IO::Handle;
use List::MoreUtils qw(any);
use Time::Progress;

my $add_unignore  = 0;
my $base          = getcwd();
my $rel_paths     = 1;
my $db_file       = '.hashl.db';
my $total         = 0;
my $cur           = 0;
my $show_progress = 1;
my $xdev_fsno;
my @edb_files;
my $timer;
my $incoming_dir;
my $read_size;
my ( $find_ref, $find_db_write );

my $hashl;
my @ehashl;

our $VERSION = '1.01';

STDERR->autoflush(1);

GetOptions(
	'd|database=s'      => \$db_file,
	'e|extra-db=s'      => \@edb_files,
	'f|force'           => \$add_unignore,
	'n|no-progress'     => sub { $show_progress = 0 },
	's|read-size=i'     => sub { $read_size = $_[1] * 1024 },
	'V|version'         => sub { say "hashl version ${VERSION}"; exit 0 },
	'x|one-file-system' => sub { $xdev_fsno = ( stat($base) )[0] },
) or usage();

if ( substr( $db_file, 0, 1 ) ne q{/} ) {
	$db_file = "${base}/${db_file}";
}

my $action = shift;

sub usage {
	die(<<"EOF");
Usage: $0 [options] <update|list|info|...> [args]
See 'perldoc -F $0' (or 'man hashl' if it is properly installed)
EOF
}

if ( not defined $action ) {
	usage();
}

if ( -r $db_file ) {
	$hashl = App::Hashl->new_from_file($db_file);
}
else {
	$hashl = App::Hashl->new( read_size => $read_size );
}
@ehashl = ($hashl);

for my $file (@edb_files) {
	if ( -r $file ) {
		push( @ehashl, App::Hashl->new_from_file($file) );
	}
	else {
		die("-e ${file}: database does not exist\n");
	}
}

local $SIG{INT}  = \&quit_save_db;
local $SIG{TERM} = \&quit_save_db;

sub quit_save_db {
	$hashl->save($db_file);
	exit 0;
}

sub get_total {
	my $file = $File::Find::name;

	if (    -f $file
		and not -l $file
		and $file ne $db_file
		and ( not $xdev_fsno or ( stat($file) )[0] == $xdev_fsno ) )
	{
		$total++;
	}

	return;
}

sub drop_deleted {
	for my $file ( $hashl->files ) {
		if ( not -e $file ) {
			$hashl->delete_file($file);
		}
	}

	return;
}

sub ensure_equal_hash_sizes {
	for my $i ( 1 .. $#ehashl ) {
		if ( $ehashl[$i]->read_size != $hashl->read_size ) {
			printf STDERR (
				'Cannot list: main database has read size %d, but database'
				  . " %s has read size %d\n",
				$hashl->read_size,
				$edb_files[ $i - 1 ],
				$ehashl[$i]->read_size
			);
			exit 1;
		}
	}
	return;
}

sub copy_file {
	my ( $file, $to ) = @_;

	my $cp_base = substr( $file, length($base) + 1 );
	if ( $base =~ s{ / [^/]+ $}{}x ) {
		mkdirs( $incoming_dir, $cp_base );
	}

	copy( $file, "${to}/${cp_base}" )
	  or die("Cannot copy ${file} to ${to}/${cp_base}: $!\n");

	return;
}

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

	if ( not any { $_->file_in_db($path) } @ehashl ) {
		print STDERR "\r\e[2K";
		say $file;
	}

	return;
}

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

	if ( any { $_->file_in_db($path) } @ehashl ) {
		print STDERR "\r\e[2K";
		say $file;
	}

	return;
}

sub file_info {
	my ($file) = @_;

	my $entry = $hashl->file($file);

	if ( not $entry ) {
		die("No such file in database\n");
	}

	printf(
		"File: %s\nSize: %d bytes (%s)\nHash: %s\n",
		$file, $entry->{size}, $hashl->si_size( $entry->{size} ),
		$entry->{hash},
	);

	return;
}

sub process_file {
	my ( $code, $write ) = ( $find_ref, $find_db_write );

	my $file = $File::Find::name;
	my $path = $file;

	if (   not -f $file
		or -l $file
		or $file eq $db_file
		or ( $xdev_fsno and ( stat($file) )[0] != $xdev_fsno ) )
	{
		return;
	}

	if ($rel_paths) {
		$file = substr( $file, length($base) + 1 );
	}

	$cur++;

	if ($show_progress) {
		print STDERR $timer->report(
			"\r\e[2KScanning directory: %p done, %L elapsed, %E remaining",
			$cur, );
	}

	&{$code}( $file, $path );

	if ( $write and ( ( $cur % 5000 ) == 0 ) ) {
		$hashl->save($db_file);
	}

	return;
}

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

	$hashl->add_file(
		file     => $file,
		path     => $path,
		unignore => $add_unignore,
	);

	return;
}

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

	$hashl->ignore( $file, $path );

	return;
}

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

	if ( not any { $_->file_in_db($path) } @ehashl ) {
		copy_file( $path, $incoming_dir );
	}

	return;
}

sub mkdirs {
	my ( $dir_base, $new ) = @_;

	for my $dir ( split( qr{/}, $new ) ) {
		$dir_base .= "/$dir";