Remove Perl 4 sigils (PBP)
This commit is contained in:
parent
02f97c2a90
commit
907a7113a8
|
@ -43,7 +43,7 @@ sub add {
|
||||||
$self->{_entries}->{$hash} = [];
|
$self->{_entries}->{$hash} = [];
|
||||||
}
|
}
|
||||||
push @{$self->{_entries}->{$hash}}, $file;
|
push @{$self->{_entries}->{$hash}}, $file;
|
||||||
&{$callback}($file) if ref $callback eq 'CODE';
|
$callback->($file) if ref $callback eq 'CODE';
|
||||||
}
|
}
|
||||||
$self->{_files_in_hash}->{$file->{name}} = 1;
|
$self->{_files_in_hash}->{$file->{name}} = 1;
|
||||||
}
|
}
|
||||||
|
|
|
@ -42,7 +42,7 @@ sub buckets {
|
||||||
next ELIMINATOR if $self->_entry_should_be_skipped($entry);
|
next ELIMINATOR if $self->_entry_should_be_skipped($entry);
|
||||||
|
|
||||||
foreach my $bucket_idx (0 .. $#these_buckets) {
|
foreach my $bucket_idx (0 .. $#these_buckets) {
|
||||||
if (&_entries_are_hard_linkable($these_buckets[$bucket_idx]->[0], $entry)) {
|
if (_entries_are_hard_linkable($these_buckets[$bucket_idx]->[0], $entry)) {
|
||||||
push @{$these_buckets[$bucket_idx]}, $entry;
|
push @{$these_buckets[$bucket_idx]}, $entry;
|
||||||
next ELIMINATOR;
|
next ELIMINATOR;
|
||||||
}
|
}
|
||||||
|
@ -71,16 +71,16 @@ sub _entries_are_hard_linkable {
|
||||||
my ($entry_a, $entry_b) = @_;
|
my ($entry_a, $entry_b) = @_;
|
||||||
|
|
||||||
# obviously, if the sizes aren't the same, they're not the same file
|
# obviously, if the sizes aren't the same, they're not the same file
|
||||||
unless (&_entries_sizes_match($entry_a, $entry_b)) {
|
unless (_entries_sizes_match($entry_a, $entry_b)) {
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
# they're the same file, don't try it
|
# they're the same file, don't try it
|
||||||
if (&_entries_are_already_hard_linked($entry_a, $entry_b)) {
|
if (_entries_are_already_hard_linked($entry_a, $entry_b)) {
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
if (&_entries_contents_match($entry_a, $entry_b)) {
|
if (_entries_contents_match($entry_a, $entry_b)) {
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
return 0;
|
return 0;
|
||||||
|
@ -123,7 +123,7 @@ sub _entries_sizes_match {
|
||||||
sub _entries_contents_match {
|
sub _entries_contents_match {
|
||||||
my ($entry_a, $entry_b) = @_;
|
my ($entry_a, $entry_b) = @_;
|
||||||
|
|
||||||
my $contents_same = (0 == &File::Compare::compare($entry_a->{name}, $entry_b->{name}));
|
my $contents_same = (0 == File::Compare::compare($entry_a->{name}, $entry_b->{name}));
|
||||||
|
|
||||||
# warn about hash collision
|
# warn about hash collision
|
||||||
unless ($contents_same) {
|
unless ($contents_same) {
|
||||||
|
@ -168,7 +168,7 @@ sub instructions {
|
||||||
target => $entry,
|
target => $entry,
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
if (&Scalar::Util::refaddr($most_linked_entry) != &Scalar::Util::refaddr($oldest_entry)) {
|
if (Scalar::Util::refaddr($most_linked_entry) != Scalar::Util::refaddr($oldest_entry)) {
|
||||||
# most_linked_entry should get its timestamp updated
|
# most_linked_entry should get its timestamp updated
|
||||||
push @inst, Directory::Simplify::Instruction::CopyTimestamp->new(
|
push @inst, Directory::Simplify::Instruction::CopyTimestamp->new(
|
||||||
source => $oldest_entry,
|
source => $oldest_entry,
|
||||||
|
|
|
@ -117,15 +117,15 @@ require Directory::Simplify::Utils;
|
||||||
|
|
||||||
sub HELP_MESSAGE {
|
sub HELP_MESSAGE {
|
||||||
my $fh = shift;
|
my $fh = shift;
|
||||||
&pod2usage(
|
pod2usage(
|
||||||
-verbose => 1,
|
-verbose => 1,
|
||||||
-exitval => 0,
|
-exitval => 0,
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
|
|
||||||
MAIN: {
|
MAIN: {
|
||||||
&getopts('vfm:M:z', \ my %opts)
|
getopts('vfm:M:z', \ my %opts)
|
||||||
|| &pod2usage(
|
|| pod2usage(
|
||||||
-exitval => 2,
|
-exitval => 2,
|
||||||
-msg => "Try '$0 --help' for more information",
|
-msg => "Try '$0 --help' for more information",
|
||||||
);
|
);
|
||||||
|
@ -145,7 +145,7 @@ MAIN: {
|
||||||
print STDERR 'Finding files...'
|
print STDERR 'Finding files...'
|
||||||
if $verbose;
|
if $verbose;
|
||||||
|
|
||||||
&find(sub {
|
find(sub {
|
||||||
# outright skip directories (don't report skip)
|
# outright skip directories (don't report skip)
|
||||||
return if -d $File::Find::name;
|
return if -d $File::Find::name;
|
||||||
|
|
||||||
|
@ -214,7 +214,7 @@ MAIN: {
|
||||||
my $report_every = 1; # seconds
|
my $report_every = 1; # seconds
|
||||||
my $processed_bytes = 0;
|
my $processed_bytes = 0;
|
||||||
my $last_report = time;
|
my $last_report = time;
|
||||||
my $total_size_hr = sprintf "%0.4G %s", Directory::Simplify::Utils::hr_size(&sum(map { $_->{size} } @files) or 0);
|
my $total_size_hr = sprintf "%0.4G %s", Directory::Simplify::Utils::hr_size(sum(map { $_->{size} } @files) or 0);
|
||||||
my $cb;
|
my $cb;
|
||||||
if ($print_progress) {
|
if ($print_progress) {
|
||||||
printf STDERR "\e\x{37}";
|
printf STDERR "\e\x{37}";
|
||||||
|
|
|
@ -37,9 +37,9 @@ sub are_hardlinked {
|
||||||
return "$dev:$ino";
|
return "$dev:$ino";
|
||||||
};
|
};
|
||||||
|
|
||||||
my $starter_ident = &$gen_ident($starter);
|
my $starter_ident = $gen_ident->($starter);
|
||||||
foreach my $file (@_) {
|
foreach my $file (@_) {
|
||||||
if (&$gen_ident($file) ne $starter_ident) {
|
if ($gen_ident->($file) ne $starter_ident) {
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -62,7 +62,7 @@ sub filemtime {
|
||||||
sub has_mtime {
|
sub has_mtime {
|
||||||
my $mtime = shift;
|
my $mtime = shift;
|
||||||
foreach my $file (@_) {
|
foreach my $file (@_) {
|
||||||
if (&filemtime($file) != $mtime) {
|
if (filemtime($file) != $mtime) {
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -80,11 +80,11 @@ sub mktempdir {
|
||||||
sub prep_tar {
|
sub prep_tar {
|
||||||
my $tarball = shift // (dirname(__FILE__) . '/t.tar');
|
my $tarball = shift // (dirname(__FILE__) . '/t.tar');
|
||||||
|
|
||||||
my $td = &mktempdir;
|
my $td = mktempdir();
|
||||||
|
|
||||||
# Note: Using chdir from Cwd automatically keeps $ENV{PWD} up-to-date (just
|
# Note: Using chdir from Cwd automatically keeps $ENV{PWD} up-to-date (just
|
||||||
# in case)
|
# in case)
|
||||||
my $oldpwd = &getcwd;
|
my $oldpwd = getcwd();
|
||||||
|
|
||||||
chdir $td;
|
chdir $td;
|
||||||
my $tar = Archive::Tar->new;
|
my $tar = Archive::Tar->new;
|
||||||
|
|
|
@ -7,13 +7,13 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $test_dir = &mktempdir;
|
my $test_dir = mktempdir();
|
||||||
&put_file(
|
put_file(
|
||||||
"$test_dir/1",
|
"$test_dir/1",
|
||||||
"$test_dir/2",
|
"$test_dir/2",
|
||||||
);
|
);
|
||||||
|
|
||||||
my (undef, $stdout, $stderr) = &run_script_capture('-f', $test_dir);
|
my (undef, $stdout, $stderr) = run_script_capture('-f', $test_dir);
|
||||||
ok "freed 1,048,576 bytes (1 MB)\n" eq $stderr, 'prints freed bytes with commas';
|
ok "freed 1,048,576 bytes (1 MB)\n" eq $stderr, 'prints freed bytes with commas';
|
||||||
|
|
||||||
sub put_file {
|
sub put_file {
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/freed-bytes";
|
my $test_dir = "$tarball_dir/t/freed-bytes";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/1",
|
"$test_dir/1",
|
||||||
|
@ -17,7 +17,7 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
my (undef, $stdout, $stderr) = &run_script_capture('-f', $test_dir, $test_dir);
|
my (undef, $stdout, $stderr) = run_script_capture('-f', $test_dir, $test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok "freed 24 bytes (24 B)\n" eq $stderr, 'prints correct number of freed bytes';
|
ok "freed 24 bytes (24 B)\n" eq $stderr, 'prints correct number of freed bytes';
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/link-counting";
|
my $test_dir = "$tarball_dir/t/link-counting";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/most-links",
|
"$test_dir/most-links",
|
||||||
|
@ -15,7 +15,7 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
&run_script($test_dir);
|
run_script($test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok &are_hardlinked(@files), 'files with existing links got hardlinked';
|
ok are_hardlinked(@files), 'files with existing links got hardlinked';
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/normal";
|
my $test_dir = "$tarball_dir/t/normal";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/foo/same",
|
"$test_dir/foo/same",
|
||||||
|
@ -15,7 +15,7 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
&run_script($test_dir);
|
run_script($test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok &are_hardlinked(@files), 'files with the same contents got hardlinked';
|
ok are_hardlinked(@files), 'files with the same contents got hardlinked';
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/normal";
|
my $test_dir = "$tarball_dir/t/normal";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/foo/same",
|
"$test_dir/foo/same",
|
||||||
|
@ -15,7 +15,7 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
&run_script($test_dir);
|
run_script($test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok !&are_hardlinked(@files), 'files with different contents did not get hardlinked';
|
ok !are_hardlinked(@files), 'files with different contents did not get hardlinked';
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/sha1-collision";
|
my $test_dir = "$tarball_dir/t/sha1-collision";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/shattered-1.pdf",
|
"$test_dir/shattered-1.pdf",
|
||||||
|
@ -15,7 +15,7 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
&run_script($test_dir);
|
run_script($test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok !&are_hardlinked(@files), 'files with the same SHA-1 hash did not get hardlinked';
|
ok !are_hardlinked(@files), 'files with the same SHA-1 hash did not get hardlinked';
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/timestamp-preservation";
|
my $test_dir = "$tarball_dir/t/timestamp-preservation";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/newer-more-linked",
|
"$test_dir/newer-more-linked",
|
||||||
|
@ -15,9 +15,9 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
my $should_have_mtime = &filemtime($files[1]);
|
my $should_have_mtime = filemtime($files[1]);
|
||||||
&run_script($test_dir);
|
run_script($test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok &are_hardlinked(@files);
|
ok are_hardlinked(@files);
|
||||||
ok &has_mtime($should_have_mtime, @files), 'timestamps updated to use oldest';
|
ok has_mtime($should_have_mtime, @files), 'timestamps updated to use oldest';
|
||||||
|
|
|
@ -7,7 +7,7 @@ use Test::Simple
|
||||||
|
|
||||||
use TestFunctions;
|
use TestFunctions;
|
||||||
|
|
||||||
my $tarball_dir = &prep_tar;
|
my $tarball_dir = prep_tar();
|
||||||
my $test_dir = "$tarball_dir/t/zero-size";
|
my $test_dir = "$tarball_dir/t/zero-size";
|
||||||
my @files = (
|
my @files = (
|
||||||
"$test_dir/empty1",
|
"$test_dir/empty1",
|
||||||
|
@ -15,7 +15,7 @@ my @files = (
|
||||||
);
|
);
|
||||||
|
|
||||||
# Smoke test
|
# Smoke test
|
||||||
ok !&are_hardlinked(@files), 'not hardlinked before we start';
|
ok !are_hardlinked(@files), 'not hardlinked before we start';
|
||||||
&run_script($test_dir);
|
run_script($test_dir);
|
||||||
ok &file_exists(@files), 'files were not accidentally deleted';
|
ok file_exists(@files), 'files were not accidentally deleted';
|
||||||
ok !&are_hardlinked(@files), 'zero-sized files did not get hardlinked';
|
ok !are_hardlinked(@files), 'zero-sized files did not get hardlinked';
|
||||||
|
|
Loading…
Reference in New Issue