=over 4
-=item check_req
-
=item compare
=item evcheck
-=item only_files
-
=item save_output
=item restore_output
=item find_exec
-=item read_file
-
=back
=cut
-@EXPORT_OK = qw( check_req compare evcheck find_exec only_files read_file
+@EXPORT_OK = qw( compare evcheck
save_output restore_output tempdir tmpnam );
# Utility -----------------------------
if ( File::Spec->file_name_is_absolute($_[0]) ) {
return $_[0];
} else {
- return catdir(cwd, $_[0]);
+ return File::Spec->catdir(cwd, $_[0]);
}
}
-sub catdir {
- File::Spec->catdir(@_);
-}
-
-sub catfile {
- File::Spec->catfile(@_);
-}
-
-sub updir {
- File::Spec->updir(@_);
-}
-
sub min {
croak "Can't min over 0 args!\n"
unless @_;
# PACKAGE CONSTANTS
# -------------------------------------
-use constant BUILD_SCRIPT_DIR => => catdir $Bin, updir, qw( blib script );
+use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
sub find_exec {
my ($exec) = @_;
for (split /:/, $PATH) {
- my $try = catfile $_, $exec;
+ my $try = File::Spec->catfile($_, $exec);
return rel2abs($try)
if -x $try;
}
# PACKAGE FUNCTIONS
# -------------------------------------
-=head2 only_files
-
-=over 4
-
-=item ARGUMENTS
-
-=over 4
-
-=item expect
-
-Arrayref of names of files to expect to exist.
-
-=back
-
-=item RETURNS
-
-=over 4
-
-=item ok
-
-1 if exactly expected files exist, false otherwise.
-
-=back
-
-=back
-
-=cut
-
-sub only_files {
- my ($expect) = @_;
-
- local *MYDIR;
- opendir MYDIR, '.';
- my %files = map { $_ => 1 } readdir MYDIR;
- closedir MYDIR;
-
- my $ok = 1;
-
- for (@$expect, '.', '..') {
- if ( exists $files{$_} ) {
- delete $files{$_};
- } elsif ( ! -e $_ ) { # $_ might be absolute
- carp "File not found: $_\n"
- if $ENV{TEST_DEBUG};
- $ok = 0;
- }
- }
-
- for (keys %files) {
- carp "Extra file found: $_\n"
- if $ENV{TEST_DEBUG};
- $ok = 0;
- }
-
- if ( $ok ) {
- return 1;
- } else {
- return;
- }
-}
-
-# -------------------------------------
-
=head2 evcheck
Eval code, return status
=cut
-#XYZ sub _run {
-#XYZ my ($cmd, $name, $in) = @_;
-#XYZ
-#XYZ my $infn = defined $in ? tmpnam : '/dev/null';
-#XYZ my $outfn = tmpnam;
-#XYZ my $errfn = tmpnam;
-#XYZ
-#XYZ my $pid = fork;
-#XYZ croak "Couldn't fork: $!\n"
-#XYZ unless defined $pid;
-#XYZ
-#XYZ if ( $pid == 0 ) { # Child
-#XYZ open STDOUT, '>', $outfn;
-#XYZ open STDERR, '>', $errfn;
-#XYZ open STDIN, '<', $infn;
-#XYZ
-#XYZ exec @$cmd;
-#XYZ }
-#XYZ
-#XYZ my $rv = waitpid $pid, 0;
-#XYZ my $status = $?;
-#XYZ
-#XYZ croak "Unexpected waitpid return from child $name: $rv (expected $pid)\n"
-#XYZ unless $rv == $pid;
-#XYZ
-#XYZ local $/ = undef;
-#XYZ local (OUT, ERR);
-#XYZ open *OUT, '<', $outfn;
-#XYZ open *ERR, '<', $errfn;
-#XYZ my $out = <OUT>;
-#XYZ my $err = <ERR>;
-#XYZ close *OUT;
-#XYZ close *ERR;
-#XYZ
-#XYZ return $status >> 8, $status & 127, $status & 128 , $out, $err
-#XYZ }
-
# return codes and old-style call semantics left for backwards compatibility
BEGIN {
my $savewarn = $SIG{__WARN__};
# -------------------------------------
-=head2 check_req
-
-Perform a requisite check on a given executable. This will skip if the
-required modules are not present.
-
-4+(n+m)*2 tests are performed, where n is the number of prerequisites
-expected, and m is the number of outputs expected.
-
-=over 4
-
-=item SYNOPSIS
-
- check_req('ccu-touch',
- ['/etc/passwd'],
- [[REQ_FILE, '/etc/passwd']],
- [[REQ_FILE, 'passwd.foo']],
- 'requisites 1');
-
-
-=item ARGUMENTS
-
-=over 4
-
-=item cmd_name
-
-The name of the command to run. It is assumed that this command is in
-blib/script; hence it should be an executable in this package, and C<make>
-shuold have been run recently.
-
-=item args
-
-The arguments to pass to the cmd_name, as an arrayref.
-
-=item epres
-
-The expected prerequisites, as an arrayref, wherein every member is a
-two-element arrayref, the members being the requisite type, and the requisite
-value.
-
-=item eouts
-
-The expected outputs, in the same format as the L<epres|"epres">.
-
-=item testname
-
-The name to use in error messages.
-
-=back
-
-=back
-
-=cut
-
-sub check_req {
- my ($cmd_name, $args, $epres, $eouts, $testname) = @_;
-
- eval "use Pipeline::DataFlow 1.03 qw( :req_types );";
- my $skip;
- if ( $@ ) {
- print STDERR "$@\n"
- if $ENV{TEST_DEBUG};
- $skip = 'Skipped: Pipeline::DataFlow 1.03 not found';
- } else {
- $skip = 0;
- }
-
- my $count = 1;
- my $test = sub {
- my ($code, $expect) = @_;
- my $name = sprintf "%s (%2d)", $testname, $count++;
- my $value = UNIVERSAL::isa($code, 'CODE') ? $code->($name) : $code;
- skip $skip, $value, $expect, $name;
- };
-
- # Initialize nicely to cope when read_reqs fails
- my ($pres, $outs) = ([], []);
-
- $test->(sub {
- evcheck(sub {
- ($pres, $outs) = Pipeline::DataFlow->read_reqs
- ([catfile($Bin, updir, 'blib', 'script', $cmd_name),
- @$args]);
- }, $_[0]),},
- 1);
-
- $test->(scalar @$pres, scalar @$epres);
-
- my (@epres, @pres);
- @epres = sort { $a->[1] cmp $b->[1] } @$epres;
- @pres = sort { $a->[1] cmp $b->[1] } @$pres;
-
- for (my $i = 0; $i < @epres; $i++) {
- my ($type, $value) = @{$epres[$i]};
- $test->($type, @pres > $i ? $pres[$i]->[0] : undef);
- $test->($value, @pres > $i ? $pres[$i]->[1] : undef);
- }
-
- $test->(scalar @$outs, scalar @$eouts);
-
- my (@eouts, @outs);
- @eouts = sort { $a->[1] cmp $b->[1] } @$eouts;
- @outs = sort { $a->[1] cmp $b->[1] } @$outs;
-
- for (my $i = 0; $i < @eouts; $i++) {
- my ($type, $value) = @{$eouts[$i]};
- $test->($type, @outs > $i ? $outs[$i]->[0] : undef);
- $test->($value, @outs > $i ? $outs[$i]->[1] : undef);
- }
-
- $test->(only_files([]), 1);
-}
-
-# -------------------------------------
-
=head2 find_exec
=over 4
# defined further up to use in constants
-# -------------------------------------
-
-=head2 read_file
-
-=over 4
-
-=item ARGUMENTS
-
-=over 4
-
-=item filename
-
-B<Mandatory>
-
-=item line-terminator
-
-B<Optional>. Value of C<$/>. Defaults to C<"\n">.
-
-=back
-
-=item RETURNS
-
-=over 4
-
-=item lines
-
-A list of lines in the file (lines determined by the value of
-line-terminator), as an arrayref.
-
-=back
-
-=back
-
-=cut
-
-sub read_file {
- my ($fn, $term) = @_;
-
- $term = "\n"
- unless defined $term;
-
- my $fh = do { local *F; *F };
- sysopen $fh, $fn, O_RDONLY;
- local $/ = $term;
- my @lines = <$fh>;
- close $fh;
-
- return \@lines;
-}
-
# ----------------------------------------------------------------------------
=head1 EXAMPLES
projects / term-progressbar.git / blobdiff