133 lines
2.4 KiB
Perl
133 lines
2.4 KiB
Perl
package TestFunctions;
|
|
use strict;
|
|
use warnings;
|
|
|
|
require Archive::Tar;
|
|
use Cwd qw/
|
|
abs_path
|
|
chdir
|
|
getcwd
|
|
/;
|
|
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 @EXPORT = qw/
|
|
are_hardlinked
|
|
file_exists
|
|
filemtime
|
|
gen_ident
|
|
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 $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 gen_ident {
|
|
my $file = shift;
|
|
my ($dev, $ino) = stat $file;
|
|
return "$dev:$ino";
|
|
}
|
|
|
|
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);
|
|
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;
|
|
}
|
|
|
|
local $/;
|
|
return (
|
|
$?,
|
|
scalar <$child_out>, # slurp!
|
|
scalar <$child_err>, # slurp!
|
|
);
|
|
}
|
|
|
|
sub run_script {
|
|
my @args = @_;
|
|
print STDERR '+ ' . SCRIPT . " @args\n";
|
|
return system SCRIPT, @args;
|
|
}
|
|
|
|
1;
|