diff --git a/.editorconfig b/.editorconfig index af3a9c5..b8a739d 100644 --- a/.editorconfig +++ b/.editorconfig @@ -12,8 +12,5 @@ indent_size = 4 [*.md] indent_size = 2 -[.gitmodules] -indent_style = tab - [{Makefile,*.mak}] indent_style = tab diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index 8afe3ee..0000000 --- a/.gitmodules +++ /dev/null @@ -1,4 +0,0 @@ -[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 ad8ebb4..14592ef 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,11 +14,6 @@ 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 7192622..6591751 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, $rel_name) = @_; + my $class = shift; + my $rel_name = shift; 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}; - return $self; + $self } sub hash { @@ -25,7 +25,7 @@ sub hash { $ctx->addfile($self->{name}); $self->{_hash} = $ctx->hexdigest; } - return $self->{_hash}; + $self->{_hash} } 1; diff --git a/lib/Directory/Simplify/FileHash.pm b/lib/Directory/Simplify/FileHash.pm index 4b1029f..54a0eb8 100644 --- a/lib/Directory/Simplify/FileHash.pm +++ b/lib/Directory/Simplify/FileHash.pm @@ -13,18 +13,25 @@ require Directory::Simplify::File; # :squash-remove-end: sub new { - my ($class, %args) = @_; + my $class = shift; return bless { _entries => {}, _files_in_hash => {}, - %args, + @_, }, $class; } sub add { - my ($self, %args) = @_; - my @files = @{$args{files}}; - my $callback = $args{callback}; + 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 = @_; + } foreach my $file (@files) { unless (ref $file eq 'Directory::Simplify::File') { $file = Directory::Simplify::File->new($file); @@ -36,18 +43,15 @@ sub add { $self->{_entries}->{$hash} = []; } push @{$self->{_entries}->{$hash}}, $file; - if (ref $callback eq 'CODE') { - $callback->($file); - } + &{$callback}($file) if ref $callback eq 'CODE'; } $self->{_files_in_hash}->{$file->{name}} = 1; } - return; } sub entries { my $self = shift; - return values %{$self->{_entries}}; + values %{$self->{_entries}} } 1; diff --git a/lib/Directory/Simplify/Instruction/CopyTimestamp.pm b/lib/Directory/Simplify/Instruction/CopyTimestamp.pm index ca1e6ce..fba95c9 100644 --- a/lib/Directory/Simplify/Instruction/CopyTimestamp.pm +++ b/lib/Directory/Simplify/Instruction/CopyTimestamp.pm @@ -1,4 +1,5 @@ package Directory::Simplify::Instruction::CopyTimestamp; +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; use overload '""' => 'as_string'; @@ -8,9 +9,9 @@ require Directory::Simplify::Utils; # :squash-remove-end: sub new { - my ($class, %args) = @_; + my $class = shift; return bless { - %args, + @_, }, $class; } @@ -18,7 +19,6 @@ 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 4369df3..d2bab1b 100644 --- a/lib/Directory/Simplify/Instruction/Generator.pm +++ b/lib/Directory/Simplify/Instruction/Generator.pm @@ -1,9 +1,10 @@ package Directory::Simplify::Instruction::Generator; +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; use overload '""' => 'as_string'; -use Carp qw/ carp /; -require File::Compare; +use File::Basename qw/ dirname /; +use File::Compare qw/ compare /; # :squash-remove-start: require Directory::Simplify::Instruction::CopyTimestamp; @@ -11,17 +12,17 @@ require Directory::Simplify::Instruction::Hardlink; # :squash-remove-end: sub new { - my ($class, %args) = @_; + my $class = shift; return bless { filehash => undef, min_size => 1, - %args, + @_, }, $class; } sub as_string { my $self = shift; - return join "\n", $self->instructions; + join "\n", $self->instructions; } sub buckets { @@ -42,7 +43,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; } @@ -55,7 +56,7 @@ sub buckets { push @buckets, @these_buckets; } - return @buckets; + @buckets } sub _entry_should_be_skipped { @@ -71,35 +72,41 @@ 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 @entries = @_; - my @sorted = sort { +sub oldest_mtime { + my $self = shift; + return sort { $a->{mtime} <=> $b->{mtime} - } @entries; - return @sorted; + } @_; } -sub _more_linked { - my @entries = @_; - my @sorted = sort { +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 + } $b->{nlink} <=> $a->{nlink} - } @entries; - return @sorted; + } @_; } sub _entries_are_already_hard_linked { @@ -123,11 +130,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) { - carp "Hash collision between files:\n* $entry_a->{name}\n* $entry_b->{name}\n (don't panic)\n"; + warn "Hash collision between files:\n* $entry_a->{name}\n* $entry_b->{name}\n (don't panic)\n"; } return $contents_same; } @@ -141,27 +148,12 @@ sub instructions { my @inst; foreach my $bucket ($self->buckets) { - # Of the bucket, find the oldest timestamp, regardless of read-only - my ($oldest_entry) = _oldest_mtime(@{$bucket}); + # of the bucket, find the oldest timestamp + my ($oldest_entry) = $self->oldest_mtime(@{$bucket}); - # 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; + # 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; 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 @@ -174,7 +166,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, @@ -182,7 +174,7 @@ sub instructions { ); } } - return @inst; + @inst } 1; diff --git a/lib/Directory/Simplify/Instruction/Hardlink.pm b/lib/Directory/Simplify/Instruction/Hardlink.pm index 2303e0f..24d274e 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, %args) = @_; + my $class = shift; return bless { freed => 0, - %args, + @_, }, $class; } @@ -21,17 +21,16 @@ sub run { # hard link the files unless (unlink $self->{target}->{name}) { - croak "Failed to remove file `$self->{target}->{name}': $!\n"; + die "Failed to remove file `$self->{target}->{name}': $!\n"; } unless (link $self->{source}->{name}, $self->{target}->{name}) { - croak "Failed to hard link `$self->{source}->{name}' => `$self->{target}->{name}': $!"; + die "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 37bea38..5c05489 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 (@numbers) { + foreach my $num (@_) { # 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); } - return wantarray ? @added : $added[0]; + wantarray ? @added : $added[0] } sub hr_size { @@ -29,21 +29,19 @@ sub hr_size { } # default to ($sz, 'bytes') - unless (@ret) { - @ret = ($sz, $sizes[0]); - } + @ret = ($sz, $sizes[0]) unless @ret; - return wantarray ? @ret : "@ret"; + wantarray ? @ret : "@ret" } sub shell_quote { # shell-escape argument for inclusion in non-interpolated single quotes - my @words = @_; - foreach my $word (@words) { - $word =~ s/'/'\\''/g; - $word = "'$word'"; - } - return wantarray ? @words : $words[0]; + my @transformed = map { + (my $out = $_) + =~ s/'/'\\''/g; + "'$out'"; + } @_; + wantarray ? @transformed : $transformed[0]; } 1; diff --git a/make-allinone.sh b/make-allinone.sh index 8f3e79a..6bbaa4d 100755 --- a/make-allinone.sh +++ b/make-allinone.sh @@ -1,11 +1,12 @@ #!/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/perl-squasher/squash" \ +"$WORKDIR/util/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 9dd8579..78ecfe4 100755 --- a/simplify_static_dir-main.pl +++ b/simplify_static_dir-main.pl @@ -1,4 +1,5 @@ #!/usr/bin/perl +# vi: et sts=4 sw=4 ts=4 package main; use strict; @@ -116,16 +117,15 @@ 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,26 +142,24 @@ MAIN: { my @dirs_to_process = map { Cwd::abs_path($_) } (@ARGV ? @ARGV : ($ENV{PWD})); my @files; - if ($verbose) { - print STDERR 'Finding files...'; - } + print STDERR 'Finding files...' + if $verbose; - find(sub { + &find(sub { # outright skip directories (don't report skip) return if -d $File::Find::name; # skip non-existent files and links - if (! -f $File::Find::name || -l $File::Find::name) { + unless (-f $File::Find::name && ! -l $File::Find::name) { return; } push @files, Directory::Simplify::File->new($File::Find::name); }, @dirs_to_process); - if ($verbose) { - printf STDERR '%d files found', - scalar @files; - } + printf STDERR "%d files found", + scalar @files + if $verbose; # Limit to or exclude file patterns specified by `-m' or `-M', respectively # @@ -176,18 +174,20 @@ MAIN: { @files = grep { $_->{rel_name} =~ $files_match } @files; - if ($verbose && $file_ct_before_filter != scalar @files) { - printf STDERR ' (%d files filtered by -m rule)', - $file_ct_before_filter - scalar @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 (length $files_exclude) { $file_ct_before_filter = scalar @files; @files = grep { not $_->{rel_name} =~ $files_exclude } @files; - if ($verbose && $file_ct_before_filter != scalar @files) { - printf STDERR ' (%d files filtered by -M rule)', - $file_ct_before_filter - scalar @files; + if ($file_ct_before_filter != scalar @files) { + printf STDERR " (%d files filtered by -M rule)", + $file_ct_before_filter - scalar @files + if $verbose; } } @@ -195,31 +195,26 @@ 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; - foreach my $file (@files) { - ++$file_sizes{$file->{size}}; - } + ++$file_sizes{$_->{size}} foreach @files; @files = grep { $file_sizes{$_->{size}} > 1 } @files; - if ($verbose) { - printf STDERR " (%d candidates).\n", - scalar @files; - } + printf STDERR " (%d candidates).\n", + scalar @files + if $verbose; unless (@files) { printf STDERR "Nothing to do.\n"; exit 0; } - if ($verbose) { - print STDERR 'Generating hashes...'; - } + print STDERR "Generating hashes..." if $verbose; 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}"; @@ -234,13 +229,12 @@ MAIN: { } }; } - $filehash->add( + $filehash->add({ files => \@files, callback => $cb, - ); - if ($verbose) { - print STDERR "done.\n"; - } + }); + print STDERR "done.\n" + if $verbose; my $generator = Directory::Simplify::Instruction::Generator->new( filehash => $filehash, @@ -250,17 +244,14 @@ MAIN: { my $freed_bytes = 0; foreach my $inst ($generator->instructions) { - if ($verbose) { - print STDERR $inst, "\n"; - } + print STDERR $inst, "\n" if $verbose; $inst->run; $freed_bytes += $inst->bytes_freed; } - 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); - } + 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; } diff --git a/t/TestFunctions.pm b/t/TestFunctions.pm index 8214a65..94441ff 100644 --- a/t/TestFunctions.pm +++ b/t/TestFunctions.pm @@ -1,4 +1,5 @@ package TestFunctions; +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; @@ -12,18 +13,13 @@ use File::Basename qw/ dirname /; require File::Temp; -use IPC::Open3 qw/ open3 /; -use Symbol qw/ gensym /; use Exporter; -use parent 'Exporter'; -## no critic ( Modules::ProhibitAutomaticExportation ) -# This is a test function library, it's not production code... +our @ISA = qw/ Exporter /; our @EXPORT = qw/ are_hardlinked file_exists filemtime - gen_ident has_mtime mktempdir prep_tar @@ -34,11 +30,16 @@ our @EXPORT = qw/ use constant SCRIPT => $ENV{SCRIPT} // abs_path dirname(__FILE__) . '/../simplify_static_dir-main.pl'; sub are_hardlinked { - my ($starter, @files) = @_; + my $starter = shift; - my $starter_ident = gen_ident($starter); - foreach my $file (@files) { - if (gen_ident($file) ne $starter_ident) { + 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) { return 0; } } @@ -46,8 +47,7 @@ sub are_hardlinked { } sub file_exists { - my @files = @_; - foreach my $file (@files) { + foreach my $file (@_) { unless (-e $file) { return 0; } @@ -56,20 +56,13 @@ sub file_exists { } sub filemtime { - my $file = shift; - return (stat $file)[9]; -} - -sub gen_ident { - my $file = shift; - my ($dev, $ino) = stat $file; - return "$dev:$ino"; + (stat shift)[9]; } sub has_mtime { - my ($mtime, @files) = @_; - foreach my $file (@files) { - if (filemtime($file) != $mtime) { + my $mtime = shift; + foreach my $file (@_) { + if (&filemtime($file) != $mtime) { return 0; } } @@ -87,11 +80,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; @@ -103,30 +96,35 @@ sub prep_tar { } sub run_script_capture { - my @args = @_; - my @cmd = (SCRIPT, @args); - my $in = ''; - my $child_out = gensym(); - my $child_err = gensym(); - print STDERR "+ @cmd\n"; - my $pid = open3 $in, $child_out, $child_err, @cmd; - waitpid $pid, 0; - foreach my $handle ($child_out, $child_err) { - seek $handle, 0, 0; - } + 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 $in = ''; + local *CATCHOUT = $stdout; + local *CATCHERR = $stderr; + print STDERR "+ @cmd\n"; + my $pid = open3 $in, '>&CATCHOUT', '>&CATCHERR', @cmd; + waitpid $pid, 0; + seek $_, 0, 0 for \*CATCHOUT, \*CATCHERR; - local $/; return ( $?, - scalar <$child_out>, # slurp! - scalar <$child_err>, # slurp! + (join "\n", ), + (join "\n", ) ); } sub run_script { - my @args = @_; - print STDERR '+ ' . SCRIPT . " @args\n"; - return system SCRIPT, @args; + print STDERR '+ ' . SCRIPT . " @_\n"; + system SCRIPT, @_; } 1; diff --git a/t/freed-bytes-commas.t b/t/freed-bytes-commas.t index 81af8d0..fc5b13f 100644 --- a/t/freed-bytes-commas.t +++ b/t/freed-bytes-commas.t @@ -1,31 +1,28 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; -use Carp qw/ croak /; +use Test::Simple + tests => 1; 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 @files = @_; - my $bytes = 1_048_576; # 1 MB - foreach my $file (@files) { + my $bytes = 1048576; # 1 MB + foreach my $file (@_) { open my $fh, '>', $file - or croak("Failed to open file $file for writing: $!"); + or die "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 bb52994..3945e3e 100644 --- a/t/freed-bytes.t +++ b/t/freed-bytes.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 3; 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", @@ -16,7 +17,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 6ef6d25..e88b004 100644 --- a/t/link-counting.t +++ b/t/link-counting.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 3; 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", @@ -14,7 +15,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 f4ab8d6..1743053 100644 --- a/t/normal-linkage.t +++ b/t/normal-linkage.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 3; 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", @@ -14,7 +15,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 38146de..afbd0f4 100644 --- a/t/normal-non-linkage.t +++ b/t/normal-non-linkage.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 3; 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", @@ -14,7 +15,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 b18a15d..f494436 100644 --- a/t/sha1collision-non-linkage.t +++ b/t/sha1collision-non-linkage.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 3; 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", @@ -14,7 +15,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 deleted file mode 100755 index 7120ca0..0000000 --- a/t/some-files-readonly.t +++ /dev/null @@ -1,68 +0,0 @@ -#!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 c0ae713..c8eea03 100644 --- a/t/timestamp-preservation.t +++ b/t/timestamp-preservation.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 4; 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", @@ -14,9 +15,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), 'files should be hardlinked'; -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); +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 9ea20fe..1f841fd 100644 --- a/t/zero-size-non-linkage.t +++ b/t/zero-size-non-linkage.t @@ -1,12 +1,13 @@ -#!perl +# vi: et sts=4 sw=4 ts=4 use strict; use warnings; -use Test::More 'no_plan'; +use Test::Simple + tests => 3; 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", @@ -14,7 +15,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 deleted file mode 160000 index 9d414ab..0000000 --- a/util/perl-squasher +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9d414ab346caed6035db5a0512d6c89912a8826c diff --git a/util/squash b/util/squash new file mode 100755 index 0000000..a015533 --- /dev/null +++ b/util/squash @@ -0,0 +1,92 @@ +#!/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;