diff --git a/.editorconfig b/.editorconfig index b8a739d..af3a9c5 100644 --- a/.editorconfig +++ b/.editorconfig @@ -12,5 +12,8 @@ indent_size = 4 [*.md] indent_size = 2 +[.gitmodules] +indent_style = tab + [{Makefile,*.mak}] indent_style = tab diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..8afe3ee --- /dev/null +++ b/.gitmodules @@ -0,0 +1,4 @@ +[submodule "perl-squasher"] + path = util/perl-squasher + url = https://codeberg.org/h3xx/perl-squasher.git + branch = main diff --git a/CHANGELOG.md b/CHANGELOG.md index 14592ef..ad8ebb4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,11 @@ All notable changes to this project will be documented in this file. - Omit output of progress bar unless -v flag is present - Add thousands separator commas to output +### Fixed + +- Fixed issue where removable files wouldn't be linked with non-removable + files. + ## [3.0.0] ### Changed diff --git a/lib/Directory/Simplify/File.pm b/lib/Directory/Simplify/File.pm index 6591751..7192622 100644 --- a/lib/Directory/Simplify/File.pm +++ b/lib/Directory/Simplify/File.pm @@ -1,20 +1,20 @@ package Directory::Simplify::File; -# vi: et sts=4 sw=4 ts=4 use strict; use warnings; require Cwd; +use File::Basename qw/ dirname /; sub new { - my $class = shift; - my $rel_name = shift; + my ($class, $rel_name) = @_; my $self = bless { rel_name => $rel_name, name => Cwd::abs_path($rel_name), }, $class; + $self->{dirname} = dirname($self->{name}); (@{$self}{qw/ dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks /}) = lstat $self->{name}; - $self + return $self; } sub hash { @@ -25,7 +25,7 @@ sub hash { $ctx->addfile($self->{name}); $self->{_hash} = $ctx->hexdigest; } - $self->{_hash} + return $self->{_hash}; } 1; diff --git a/lib/Directory/Simplify/FileHash.pm b/lib/Directory/Simplify/FileHash.pm index 54a0eb8..4b1029f 100644 --- a/lib/Directory/Simplify/FileHash.pm +++ b/lib/Directory/Simplify/FileHash.pm @@ -13,25 +13,18 @@ require Directory::Simplify::File; # :squash-remove-end: sub new { - my $class = shift; + my ($class, %args) = @_; return bless { _entries => {}, _files_in_hash => {}, - @_, + %args, }, $class; } sub add { - my $self = shift; - my (@files, $callback); - if (ref $_[0] eq 'HASH') { - # Called method like { files => [] } - my %opts = %{$_[0]}; - @files = @{$opts{files}}; - $callback = $opts{callback}; - } else { - @files = @_; - } + my ($self, %args) = @_; + my @files = @{$args{files}}; + my $callback = $args{callback}; foreach my $file (@files) { unless (ref $file eq 'Directory::Simplify::File') { $file = Directory::Simplify::File->new($file); @@ -43,15 +36,18 @@ sub add { $self->{_entries}->{$hash} = []; } push @{$self->{_entries}->{$hash}}, $file; - &{$callback}($file) if ref $callback eq 'CODE'; + if (ref $callback eq 'CODE') { + $callback->($file); + } } $self->{_files_in_hash}->{$file->{name}} = 1; } + return; } sub entries { my $self = shift; - values %{$self->{_entries}} + return values %{$self->{_entries}}; } 1; diff --git a/lib/Directory/Simplify/Instruction/CopyTimestamp.pm b/lib/Directory/Simplify/Instruction/CopyTimestamp.pm index fba95c9..ca1e6ce 100644 --- a/lib/Directory/Simplify/Instruction/CopyTimestamp.pm +++ b/lib/Directory/Simplify/Instruction/CopyTimestamp.pm @@ -1,5 +1,4 @@ package Directory::Simplify::Instruction::CopyTimestamp; -# vi: et sts=4 sw=4 ts=4 use strict; use warnings; use overload '""' => 'as_string'; @@ -9,9 +8,9 @@ require Directory::Simplify::Utils; # :squash-remove-end: sub new { - my $class = shift; + my ($class, %args) = @_; return bless { - @_, + %args, }, $class; } @@ -19,6 +18,7 @@ sub run { my $self = shift; # preserve older time stamp utime $self->{source}->{atime}, $self->{source}->{mtime}, $self->{target}->{name}; + return; } sub bytes_freed { diff --git a/lib/Directory/Simplify/Instruction/Generator.pm b/lib/Directory/Simplify/Instruction/Generator.pm index d2bab1b..4369df3 100644 --- a/lib/Directory/Simplify/Instruction/Generator.pm +++ b/lib/Directory/Simplify/Instruction/Generator.pm @@ -1,10 +1,9 @@ package Directory::Simplify::Instruction::Generator; -# vi: et sts=4 sw=4 ts=4 use strict; use warnings; use overload '""' => 'as_string'; -use File::Basename qw/ dirname /; -use File::Compare qw/ compare /; +use Carp qw/ carp /; +require File::Compare; # :squash-remove-start: require Directory::Simplify::Instruction::CopyTimestamp; @@ -12,17 +11,17 @@ require Directory::Simplify::Instruction::Hardlink; # :squash-remove-end: sub new { - my $class = shift; + my ($class, %args) = @_; return bless { filehash => undef, min_size => 1, - @_, + %args, }, $class; } sub as_string { my $self = shift; - join "\n", $self->instructions; + return join "\n", $self->instructions; } sub buckets { @@ -43,7 +42,7 @@ sub buckets { next ELIMINATOR if $self->_entry_should_be_skipped($entry); 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; next ELIMINATOR; } @@ -56,7 +55,7 @@ sub buckets { push @buckets, @these_buckets; } - @buckets + return @buckets; } sub _entry_should_be_skipped { @@ -72,41 +71,35 @@ sub _entries_are_hard_linkable { my ($entry_a, $entry_b) = @_; # 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; } # 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; } - if (&_entries_contents_match($entry_a, $entry_b)) { + if (_entries_contents_match($entry_a, $entry_b)) { return 1; } return 0; } -sub oldest_mtime { - my $self = shift; - return sort { +sub _oldest_mtime { + my @entries = @_; + my @sorted = sort { $a->{mtime} <=> $b->{mtime} - } @_; + } @entries; + return @sorted; } -sub more_linked { - my $self = shift; - my %warned; - return sort { - if (! -w &dirname($a->{name})) { - warn "Warning: $a->{name} not able to be unlinked!" unless $warned{$a->{name}}++; - return 1; # favor a -> front - } elsif (! -w &dirname($b->{name})) { - warn "Warning: $b->{name} not able to be unlinked!" unless $warned{$b->{name}}++; - return -1; # favor b -> front - } +sub _more_linked { + my @entries = @_; + my @sorted = sort { $b->{nlink} <=> $a->{nlink} - } @_; + } @entries; + return @sorted; } sub _entries_are_already_hard_linked { @@ -130,11 +123,11 @@ sub _entries_sizes_match { sub _entries_contents_match { 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 unless ($contents_same) { - warn "Hash collision between files:\n* $entry_a->{name}\n* $entry_b->{name}\n (don't panic)\n"; + carp "Hash collision between files:\n* $entry_a->{name}\n* $entry_b->{name}\n (don't panic)\n"; } return $contents_same; } @@ -148,12 +141,27 @@ sub instructions { my @inst; foreach my $bucket ($self->buckets) { - # of the bucket, find the oldest timestamp - my ($oldest_entry) = $self->oldest_mtime(@{$bucket}); + # Of the bucket, find the oldest timestamp, regardless of read-only + my ($oldest_entry) = _oldest_mtime(@{$bucket}); - # of the bucket, find the file most embedded in the file system - my @to_link = $self->more_linked(@{$bucket}); - my $most_linked_entry = shift @to_link; + # Limit link/unlink operations to files in non-readonly directories + my (@non_readonly, @readonly); + foreach my $entry (@{$bucket}) { + unless (-w $entry->{dirname}) { + carp "Warning: $entry->{name} not able to be unlinked!"; + push @readonly, $entry; + } else { + push @non_readonly, $entry; + } + } + + # Of the linkable files, find the file most embedded in the file system + my @to_link = _more_linked(@non_readonly); + @readonly = _more_linked(@readonly); + + # Select a basis for linkage, either the most-linked readonly entry (if + # any) or the most linked of the read-write entries. + my $most_linked_entry = shift @readonly // shift @to_link; foreach my $entry (@to_link) { # XXX there shouldn't be a need to update entries' link counts, # since this generates all the instructions at once @@ -166,7 +174,7 @@ sub instructions { 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 push @inst, Directory::Simplify::Instruction::CopyTimestamp->new( source => $oldest_entry, @@ -174,7 +182,7 @@ sub instructions { ); } } - @inst + return @inst; } 1; diff --git a/lib/Directory/Simplify/Instruction/Hardlink.pm b/lib/Directory/Simplify/Instruction/Hardlink.pm index 24d274e..2303e0f 100644 --- a/lib/Directory/Simplify/Instruction/Hardlink.pm +++ b/lib/Directory/Simplify/Instruction/Hardlink.pm @@ -1,18 +1,18 @@ package Directory::Simplify::Instruction::Hardlink; -# vi: et sts=4 sw=4 ts=4 use strict; use warnings; use overload '""' => 'as_string'; +use Carp qw/ croak /; # :squash-remove-start: require Directory::Simplify::Utils; # :squash-remove-end: sub new { - my $class = shift; + my ($class, %args) = @_; return bless { freed => 0, - @_, + %args, }, $class; } @@ -21,16 +21,17 @@ sub run { # hard link the files unless (unlink $self->{target}->{name}) { - die "Failed to remove file `$self->{target}->{name}': $!\n"; + croak "Failed to remove file `$self->{target}->{name}': $!\n"; } unless (link $self->{source}->{name}, $self->{target}->{name}) { - die "Failed to hard link `$self->{source}->{name}' => `$self->{target}->{name}': $!"; + croak "Failed to hard link `$self->{source}->{name}' => `$self->{target}->{name}': $!"; } # bookkeeping ++$self->{source}->{nlink}; if (--$self->{target}->{nlink} == 0) { $self->{freed} = $self->{target}->{size}; } + return; } sub bytes_freed { diff --git a/lib/Directory/Simplify/Utils.pm b/lib/Directory/Simplify/Utils.pm index 5c05489..37bea38 100644 --- a/lib/Directory/Simplify/Utils.pm +++ b/lib/Directory/Simplify/Utils.pm @@ -1,18 +1,18 @@ package Directory::Simplify::Utils; -# vi: et sts=4 sw=4 ts=4 use strict; use warnings; sub addcommas { + my @numbers = @_; my @added; - foreach my $num (@_) { + foreach my $num (@numbers) { # don't split anything after the decimal my @parts = split /\./, $num; while ($parts[0] =~ s/(\d)(\d{3}(?:\D|$))/$1,$2/) { } push @added, (join '.', @parts); } - wantarray ? @added : $added[0] + return wantarray ? @added : $added[0]; } sub hr_size { @@ -29,19 +29,21 @@ sub hr_size { } # default to ($sz, 'bytes') - @ret = ($sz, $sizes[0]) unless @ret; + unless (@ret) { + @ret = ($sz, $sizes[0]); + } - wantarray ? @ret : "@ret" + return wantarray ? @ret : "@ret"; } sub shell_quote { # shell-escape argument for inclusion in non-interpolated single quotes - my @transformed = map { - (my $out = $_) - =~ s/'/'\\''/g; - "'$out'"; - } @_; - wantarray ? @transformed : $transformed[0]; + my @words = @_; + foreach my $word (@words) { + $word =~ s/'/'\\''/g; + $word = "'$word'"; + } + return wantarray ? @words : $words[0]; } 1; diff --git a/make-allinone.sh b/make-allinone.sh index 6bbaa4d..8f3e79a 100755 --- a/make-allinone.sh +++ b/make-allinone.sh @@ -1,12 +1,11 @@ #!/bin/bash -# vi: et sts=4 sw=4 ts=4 WORKDIR=${0%/*} OUT=$WORKDIR/simplify_static_dir.pl echo "Outputting to $OUT" >&2 shopt -s globstar -"$WORKDIR/util/squash" \ +"$WORKDIR/util/perl-squasher/squash" \ "$WORKDIR/simplify_static_dir-main.pl" \ "$WORKDIR"/lib/**/*.pm \ > "$OUT" diff --git a/simplify_static_dir-main.pl b/simplify_static_dir-main.pl index 78ecfe4..9dd8579 100755 --- a/simplify_static_dir-main.pl +++ b/simplify_static_dir-main.pl @@ -1,5 +1,4 @@ #!/usr/bin/perl -# vi: et sts=4 sw=4 ts=4 package main; use strict; @@ -117,15 +116,16 @@ require Directory::Simplify::Utils; sub HELP_MESSAGE { my $fh = shift; - &pod2usage( + pod2usage( -verbose => 1, -exitval => 0, ); + return; } MAIN: { - &getopts('vfm:M:z', \ my %opts) - || &pod2usage( + getopts('vfm:M:z', \ my %opts) + || pod2usage( -exitval => 2, -msg => "Try '$0 --help' for more information", ); @@ -142,24 +142,26 @@ MAIN: { my @dirs_to_process = map { Cwd::abs_path($_) } (@ARGV ? @ARGV : ($ENV{PWD})); my @files; - print STDERR 'Finding files...' - if $verbose; + if ($verbose) { + print STDERR 'Finding files...'; + } - &find(sub { + find(sub { # outright skip directories (don't report skip) return if -d $File::Find::name; # skip non-existent files and links - unless (-f $File::Find::name && ! -l $File::Find::name) { + if (! -f $File::Find::name || -l $File::Find::name) { return; } push @files, Directory::Simplify::File->new($File::Find::name); }, @dirs_to_process); - printf STDERR "%d files found", - scalar @files - if $verbose; + if ($verbose) { + printf STDERR '%d files found', + scalar @files; + } # Limit to or exclude file patterns specified by `-m' or `-M', respectively # @@ -174,20 +176,18 @@ MAIN: { @files = grep { $_->{rel_name} =~ $files_match } @files; - if ($file_ct_before_filter != scalar @files) { - printf STDERR " (%d files filtered by -m rule)", - $file_ct_before_filter - scalar @files - if $verbose; + if ($verbose && $file_ct_before_filter != scalar @files) { + printf STDERR ' (%d files filtered by -m rule)', + $file_ct_before_filter - scalar @files; } if (length $files_exclude) { $file_ct_before_filter = scalar @files; @files = grep { not $_->{rel_name} =~ $files_exclude } @files; - if ($file_ct_before_filter != scalar @files) { - printf STDERR " (%d files filtered by -M rule)", - $file_ct_before_filter - scalar @files - if $verbose; + if ($verbose && $file_ct_before_filter != scalar @files) { + printf STDERR ' (%d files filtered by -M rule)', + $file_ct_before_filter - scalar @files; } } @@ -195,26 +195,31 @@ MAIN: { # unique size. The reasoning being that file sizes do not match, there's no # possible way those two files can have the same contents. my %file_sizes; - ++$file_sizes{$_->{size}} foreach @files; + foreach my $file (@files) { + ++$file_sizes{$file->{size}}; + } @files = grep { $file_sizes{$_->{size}} > 1 } @files; - printf STDERR " (%d candidates).\n", - scalar @files - if $verbose; + if ($verbose) { + printf STDERR " (%d candidates).\n", + scalar @files; + } unless (@files) { printf STDERR "Nothing to do.\n"; exit 0; } - print STDERR "Generating hashes..." if $verbose; + if ($verbose) { + print STDERR 'Generating hashes...'; + } my $filehash = Directory::Simplify::FileHash->new; my $report_every = 1; # seconds my $processed_bytes = 0; 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; if ($print_progress) { printf STDERR "\e\x{37}"; @@ -229,12 +234,13 @@ MAIN: { } }; } - $filehash->add({ + $filehash->add( files => \@files, callback => $cb, - }); - print STDERR "done.\n" - if $verbose; + ); + if ($verbose) { + print STDERR "done.\n"; + } my $generator = Directory::Simplify::Instruction::Generator->new( filehash => $filehash, @@ -244,14 +250,17 @@ MAIN: { my $freed_bytes = 0; foreach my $inst ($generator->instructions) { - print STDERR $inst, "\n" if $verbose; + if ($verbose) { + print STDERR $inst, "\n"; + } $inst->run; $freed_bytes += $inst->bytes_freed; } - printf STDERR "freed %s bytes (%0.4G %s)\n", - Directory::Simplify::Utils::addcommas($freed_bytes), - Directory::Simplify::Utils::hr_size($freed_bytes) - if $print_freed or $verbose; + if ($print_freed or $verbose) { + printf STDERR "freed %s bytes (%0.4G %s)\n", + Directory::Simplify::Utils::addcommas($freed_bytes), + Directory::Simplify::Utils::hr_size($freed_bytes); + } } diff --git a/t/TestFunctions.pm b/t/TestFunctions.pm index 94441ff..8214a65 100644 --- a/t/TestFunctions.pm +++ b/t/TestFunctions.pm @@ -1,5 +1,4 @@ package TestFunctions; -# vi: et sts=4 sw=4 ts=4 use strict; use warnings; @@ -13,13 +12,18 @@ use File::Basename qw/ dirname /; require File::Temp; +use IPC::Open3 qw/ open3 /; +use Symbol qw/ gensym /; use Exporter; -our @ISA = qw/ Exporter /; +use parent 'Exporter'; +## no critic ( Modules::ProhibitAutomaticExportation ) +# This is a test function library, it's not production code... our @EXPORT = qw/ are_hardlinked file_exists filemtime + gen_ident has_mtime mktempdir prep_tar @@ -30,16 +34,11 @@ our @EXPORT = qw/ use constant SCRIPT => $ENV{SCRIPT} // abs_path dirname(__FILE__) . '/../simplify_static_dir-main.pl'; sub are_hardlinked { - my $starter = shift; + my ($starter, @files) = @_; - my $gen_ident = sub { - my ($dev, $ino) = stat $_[0]; - return "$dev:$ino"; - }; - - my $starter_ident = &$gen_ident($starter); - foreach my $file (@_) { - if (&$gen_ident($file) ne $starter_ident) { + my $starter_ident = gen_ident($starter); + foreach my $file (@files) { + if (gen_ident($file) ne $starter_ident) { return 0; } } @@ -47,7 +46,8 @@ sub are_hardlinked { } sub file_exists { - foreach my $file (@_) { + my @files = @_; + foreach my $file (@files) { unless (-e $file) { return 0; } @@ -56,13 +56,20 @@ sub file_exists { } sub filemtime { - (stat shift)[9]; + my $file = shift; + return (stat $file)[9]; +} + +sub gen_ident { + my $file = shift; + my ($dev, $ino) = stat $file; + return "$dev:$ino"; } sub has_mtime { - my $mtime = shift; - foreach my $file (@_) { - if (&filemtime($file) != $mtime) { + my ($mtime, @files) = @_; + foreach my $file (@files) { + if (filemtime($file) != $mtime) { return 0; } } @@ -80,11 +87,11 @@ sub mktempdir { sub prep_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 # in case) - my $oldpwd = &getcwd; + my $oldpwd = getcwd(); chdir $td; my $tar = Archive::Tar->new; @@ -96,35 +103,30 @@ sub prep_tar { } sub run_script_capture { - my @cmd =(SCRIPT, @_); - - use IPC::Open3 qw/ open3 /; - my $stderr = File::Temp->new( - TMPDIR => 1, - CLEANUP => 1, - ); - my $stdout = File::Temp->new( - TMPDIR => 1, - CLEANUP => 1, - ); + my @args = @_; + my @cmd = (SCRIPT, @args); my $in = ''; - local *CATCHOUT = $stdout; - local *CATCHERR = $stderr; + my $child_out = gensym(); + my $child_err = gensym(); print STDERR "+ @cmd\n"; - my $pid = open3 $in, '>&CATCHOUT', '>&CATCHERR', @cmd; + my $pid = open3 $in, $child_out, $child_err, @cmd; waitpid $pid, 0; - seek $_, 0, 0 for \*CATCHOUT, \*CATCHERR; + foreach my $handle ($child_out, $child_err) { + seek $handle, 0, 0; + } + local $/; return ( $?, - (join "\n", ), - (join "\n", ) + scalar <$child_out>, # slurp! + scalar <$child_err>, # slurp! ); } sub run_script { - print STDERR '+ ' . SCRIPT . " @_\n"; - system SCRIPT, @_; + my @args = @_; + print STDERR '+ ' . SCRIPT . " @args\n"; + return system SCRIPT, @args; } 1; diff --git a/t/freed-bytes-commas.t b/t/freed-bytes-commas.t index fc5b13f..81af8d0 100644 --- a/t/freed-bytes-commas.t +++ b/t/freed-bytes-commas.t @@ -1,28 +1,31 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 1; +use Test::More 'no_plan'; +use Carp qw/ croak /; use TestFunctions; -my $test_dir = &mktempdir; -&put_file( +my $test_dir = mktempdir(); +put_file( "$test_dir/1", "$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'; sub put_file { - my $bytes = 1048576; # 1 MB - foreach my $file (@_) { + my @files = @_; + my $bytes = 1_048_576; # 1 MB + foreach my $file (@files) { open my $fh, '>', $file - or die "Failed to open file $file for writing: $!"; + or croak("Failed to open file $file for writing: $!"); for (my $bytes_written = 0; $bytes_written < $bytes; ++$bytes_written) { print $fh 'A'; } + close $fh; } + return; } diff --git a/t/freed-bytes.t b/t/freed-bytes.t index 3945e3e..bb52994 100644 --- a/t/freed-bytes.t +++ b/t/freed-bytes.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 3; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/freed-bytes"; my @files = ( "$test_dir/1", @@ -17,7 +16,7 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -my (undef, $stdout, $stderr) = &run_script_capture('-f', $test_dir, $test_dir); -ok &file_exists(@files), 'files were not accidentally deleted'; +ok !are_hardlinked(@files), 'not hardlinked before we start'; +my (undef, $stdout, $stderr) = run_script_capture('-f', $test_dir, $test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; ok "freed 24 bytes (24 B)\n" eq $stderr, 'prints correct number of freed bytes'; diff --git a/t/link-counting.t b/t/link-counting.t index e88b004..6ef6d25 100644 --- a/t/link-counting.t +++ b/t/link-counting.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 3; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/link-counting"; my @files = ( "$test_dir/most-links", @@ -15,7 +14,7 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -&run_script($test_dir); -ok &file_exists(@files), 'files were not accidentally deleted'; -ok &are_hardlinked(@files), 'files with existing links got hardlinked'; +ok !are_hardlinked(@files), 'not hardlinked before we start'; +run_script($test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; +ok are_hardlinked(@files), 'files with existing links got hardlinked'; diff --git a/t/normal-linkage.t b/t/normal-linkage.t index 1743053..f4ab8d6 100644 --- a/t/normal-linkage.t +++ b/t/normal-linkage.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 3; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/normal"; my @files = ( "$test_dir/foo/same", @@ -15,7 +14,7 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -&run_script($test_dir); -ok &file_exists(@files), 'files were not accidentally deleted'; -ok &are_hardlinked(@files), 'files with the same contents got hardlinked'; +ok !are_hardlinked(@files), 'not hardlinked before we start'; +run_script($test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; +ok are_hardlinked(@files), 'files with the same contents got hardlinked'; diff --git a/t/normal-non-linkage.t b/t/normal-non-linkage.t index afbd0f4..38146de 100644 --- a/t/normal-non-linkage.t +++ b/t/normal-non-linkage.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 3; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/normal"; my @files = ( "$test_dir/foo/same", @@ -15,7 +14,7 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -&run_script($test_dir); -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), 'not hardlinked before we start'; +run_script($test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; +ok !are_hardlinked(@files), 'files with different contents did not get hardlinked'; diff --git a/t/sha1collision-non-linkage.t b/t/sha1collision-non-linkage.t index f494436..b18a15d 100644 --- a/t/sha1collision-non-linkage.t +++ b/t/sha1collision-non-linkage.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 3; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/sha1-collision"; my @files = ( "$test_dir/shattered-1.pdf", @@ -15,7 +14,7 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -&run_script($test_dir); -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), 'not hardlinked before we start'; +run_script($test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; +ok !are_hardlinked(@files), 'files with the same SHA-1 hash did not get hardlinked'; diff --git a/t/some-files-readonly.t b/t/some-files-readonly.t new file mode 100755 index 0000000..7120ca0 --- /dev/null +++ b/t/some-files-readonly.t @@ -0,0 +1,68 @@ +#!perl +use strict; +use warnings; + +require Data::Dumper; +use Test::More 'no_plan'; + +use TestFunctions; + +my $test_dir = mktempdir(); + +my %files = ( + rw1 => "$test_dir/rw-dir/1", + rw2 => "$test_dir/rw-dir/2", + ro1 => "$test_dir/ro-dir/ro-file", +); + +PREP: { + mkdir "$test_dir/ro-dir"; + mkdir "$test_dir/rw-dir"; + + # Create two read-write links + put_file($files{rw1}); + link $files{rw1}, $files{rw2}; + + # Create a new less-linked but read-only file with the same contents + put_file($files{ro1}); + + # Lastly, make the directory read-only + chmod 0555, "$test_dir/ro-dir"; +} + +my $ident_ro_before = gen_ident($files{ro1}); +my $ident_rw_before = gen_ident($files{rw1}); + +my ($exit_code, $stdout, $stderr) = run_script_capture('-f', $test_dir); +is $exit_code, 0, 'script should not fail'; + +ok file_exists(values %files), 'files were not accidentally deleted'; +is $ident_ro_before, gen_ident($files{ro1}), 'read-only file should not have been re-linked'; +ok are_hardlinked(values %files), 'all files should become hard-linked ' . prettify_file_idents(values %files); + +isnt $ident_rw_before, gen_ident($files{rw1}), 'the read-write file should become hard-linked'; + +sub put_file { + my @files = @_; + my $bytes = 1_048_576; # 1 MB + foreach my $file (@files) { + open my $fh, '>', $file + or croak("Failed to open file $file for writing: $!"); + for (my $bytes_written = 0; $bytes_written < $bytes; ++$bytes_written) { + print $fh 'A'; + } + close $fh; + } + return; +} + +sub prettify_file_idents { + my @files = @_; + my $d = Data::Dumper->new([{ + map { ($_, gen_ident($_)) } @files + }]); + $d->Indent(1); + $d->Sortkeys(1); + $d->Terse(1); + return $d->Dump; +} diff --git a/t/timestamp-preservation.t b/t/timestamp-preservation.t index c8eea03..c0ae713 100644 --- a/t/timestamp-preservation.t +++ b/t/timestamp-preservation.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 4; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/timestamp-preservation"; my @files = ( "$test_dir/newer-more-linked", @@ -15,9 +14,9 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -my $should_have_mtime = &filemtime($files[1]); -&run_script($test_dir); -ok &file_exists(@files), 'files were not accidentally deleted'; -ok &are_hardlinked(@files); -ok &has_mtime($should_have_mtime, @files), 'timestamps updated to use oldest'; +ok !are_hardlinked(@files), 'not hardlinked before we start'; +my $should_have_mtime = filemtime($files[1]); +run_script($test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; +ok are_hardlinked(@files), 'files should be hardlinked'; +ok has_mtime($should_have_mtime, @files), 'timestamps updated to use oldest'; diff --git a/t/zero-size-non-linkage.t b/t/zero-size-non-linkage.t index 1f841fd..9ea20fe 100644 --- a/t/zero-size-non-linkage.t +++ b/t/zero-size-non-linkage.t @@ -1,13 +1,12 @@ -# vi: et sts=4 sw=4 ts=4 +#!perl use strict; use warnings; -use Test::Simple - tests => 3; +use Test::More 'no_plan'; use TestFunctions; -my $tarball_dir = &prep_tar; +my $tarball_dir = prep_tar(); my $test_dir = "$tarball_dir/t/zero-size"; my @files = ( "$test_dir/empty1", @@ -15,7 +14,7 @@ my @files = ( ); # Smoke test -ok !&are_hardlinked(@files), 'not hardlinked before we start'; -&run_script($test_dir); -ok &file_exists(@files), 'files were not accidentally deleted'; -ok !&are_hardlinked(@files), 'zero-sized files did not get hardlinked'; +ok !are_hardlinked(@files), 'not hardlinked before we start'; +run_script($test_dir); +ok file_exists(@files), 'files were not accidentally deleted'; +ok !are_hardlinked(@files), 'zero-sized files did not get hardlinked'; diff --git a/util/perl-squasher b/util/perl-squasher new file mode 160000 index 0000000..9d414ab --- /dev/null +++ b/util/perl-squasher @@ -0,0 +1 @@ +Subproject commit 9d414ab346caed6035db5a0512d6c89912a8826c diff --git a/util/squash b/util/squash deleted file mode 100755 index a015533..0000000 --- a/util/squash +++ /dev/null @@ -1,92 +0,0 @@ -#!/usr/bin/perl -# vi: et sts=4 sw=4 ts=4 - -# Squashes together the parts of the app into the single script. -# (Adapted from the script that squashes App::Ack - see https://github.com/beyondgrep/ack3) -use warnings; -use strict; - -my $code; -for my $arg (@ARGV) { - my $filename = $arg; - if ($arg =~ /::/) { - my $key = "$arg.pm"; - $key =~ s{::}{/}g; - $filename = $INC{$key} or die "Can't find the file for $arg"; - } - - warn "Reading $filename\n"; - open my $fh, '<', $filename or die "Can't open $filename: $!"; - my $in_pod = 0; - my $in_section = ''; - my $ignore_lines = 0; - my $empty_lines = 0; - while (<$fh>) { - if (/#.*:squash-ignore-start:$/) { - $in_section = 'ignore'; - $ignore_lines = 1; - } elsif (/#.*:squash-ignore-end:$/) { - $in_section = ''; - $ignore_lines = 1; - } - if ($ignore_lines > 0) { - $ignore_lines--; - next; - } - - if ($in_section eq 'ignore') { - $empty_lines = 0 unless /^$/; - $code .= $_; - next; - } - - # Remove repeated newlines between paragraphs - # (Provided of course we're not in an 'ignore' section) - if (/^$/) { - ++$empty_lines; - if ($empty_lines > 1) { - next; - } - } else { - $empty_lines = 0; - } - - if (/#.*:squash-remove-start:$/) { - $in_section = 'remove'; - next; - } elsif (/#.*:squash-remove-end:$/) { - $in_section = ''; - next; - } - next if $in_section eq 'remove'; - next if /#.*:squash-remove-line:$/; - - next if /^\s*1;$/; - - if ($filename =~ /\.pm$/) { - # See if we're in module POD blocks - if (/^=(\w+)/) { - $in_pod = ($1 ne 'cut'); - next; - } - elsif ($in_pod) { - next; - } - next if /^# vi:/; - } - - # Remove Perl::Critic comments. - # I'd like to remove all comments, but this is a start - s{\s*##.+critic.*}{}; - $code .= $_; - } - - # Warn if there were unterminated :squash-*: sections - warn "$filename: Unterminated :squash-$in_section-start: section" if $in_section; - - close $fh; -} - -print $code; - -exit 0;