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 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); my $stderr = File::Temp->new( TMPDIR => 1, CLEANUP => 1, ); my $stdout = File::Temp->new( TMPDIR => 1, CLEANUP => 1, ); 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;