simplify_static_dir/t/TestFunctions.pm

package TestFunctions;
# vi: et sts=4 sw=4 ts=4
use strict;
use warnings;

require Archive::Tar;
use Cwd qw/
    abs_path
    chdir
    getcwd
/;
use File::Basename qw/
    dirname
/;
require File::Temp;

use Exporter;
our @ISA = qw/ Exporter /;
our @EXPORT = qw/
    are_hardlinked
    file_exists
    filemtime
    has_mtime
    mktempdir
    prep_tar
    run_script
    run_script_capture
/;

use constant SCRIPT => $ENV{SCRIPT} // abs_path dirname(__FILE__) . '/../simplify_static_dir-main.pl';

sub are_hardlinked {
    my ($starter, @files) = @_;

    my $gen_ident = sub {
        my ($dev, $ino) = stat $_[0];
        return "$dev:$ino";
    };

    my $starter_ident = $gen_ident->($starter);
    foreach my $file (@files) {
        if ($gen_ident->($file) ne $starter_ident) {
            return 0;
        }
    }
    return 1;
}

sub file_exists {
    my @files = @_;
    foreach my $file (@files) {
        unless (-e $file) {
            return 0;
        }
    }
    return 1;
}

sub filemtime {
    my $file = shift;
    return (stat $file)[9];
}

sub has_mtime {
    my ($mtime, @files) = @_;
    foreach my $file (@files) {
        if (filemtime($file) != $mtime) {
            return 0;
        }
    }
    return 1;
}

sub mktempdir {
    return File::Temp->newdir(
        TEMPLATE => 'tests.XXXXXX',
        TMPDIR => 1,
        CLEANUP => 1,
    );
}

sub prep_tar {
    my $tarball = shift // (dirname(__FILE__) . '/t.tar');

    my $td = mktempdir();

    # Note: Using chdir from Cwd automatically keeps $ENV{PWD} up-to-date (just
    # in case)
    my $oldpwd = getcwd();

    chdir $td;
    my $tar = Archive::Tar->new;
    $tar->read($tarball);
    $tar->extract();
    chdir $oldpwd;

    return $td;
}

sub run_script_capture {
    my @args = @_;
    my @cmd = (SCRIPT, @args);

    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;

    return (
        $?,
        (join "\n", <CATCHOUT>),
        (join "\n", <CATCHERR>)
    );
}

sub run_script {
    my @args = @_;
    print STDERR '+ ' . SCRIPT . " @args\n";
    return system SCRIPT, @args;
}

1;