Use perl-squasher project to create all-in-one script

Use $/ to slurp the whole handle instead of splitting and joining.

.editorconfig

@@ -12,5 +12,8 @@ indent_size = 4
 [*.md]
 indent_size = 2
 
+[.gitmodules]
+indent_style = tab
+
 [{Makefile,*.mak}]
 indent_style = tab

.gitmodules

@@ -0,0 +1,4 @@
+[submodule "perl-squasher"]
+	path = util/perl-squasher
+	url = https://codeberg.org/h3xx/perl-squasher.git
+	branch = main

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

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;

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;

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 {

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;

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 {

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;

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"

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

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", <CATCHOUT>),
-        (join "\n", <CATCHERR>)
+        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;

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

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

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

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

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

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

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;
+}

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

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

util/perl-squasher

@@ -0,0 +1 @@
+Subproject commit 9d414ab346caed6035db5a0512d6c89912a8826c

util/squash

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