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);

bin/hashl  view on Meta::CPAN

	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";
		if ( !-d $dir_base ) {
			mkdir($dir_base)
			  or die("Cannot create ${dir_base}: $!\n");
		}
	}

	return;
}

sub prepare_db_run {
	my ($dir) = @_;

	$dir //= $base;

	if ( not $show_progress ) {
		return;
	}

	find( \&get_total, $dir );

	$timer = Time::Progress->new();
	$timer->attr(
		min => 1,
		max => $total,
	);

	return;
}

sub cmd_copy {
	($incoming_dir) = @_;

	prepare_db_run();

	if ( not $incoming_dir ) {
		usage();
	}

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

	$find_ref      = \&db_copy;
	$find_db_write = 0;
	find( \&process_file, $base );
	print "\n";

	return;
}

sub cmd_find_known {
	my ($dir) = @_;

	$dir //= $base;

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

	prepare_db_run($dir);

	$find_ref      = \&db_find_known;
	$find_db_write = 0;
	find( \&process_file, $dir );
	print "\n";

	return;
}

sub cmd_find_new {
	my ($new_dir) = @_;

	$new_dir //= $base;

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

	prepare_db_run($new_dir);

	$find_ref      = \&db_find_new;
	$find_db_write = 0;