view release on metacpan or  search on metacpan

inc/My/Module/Satpass.pm  view on Meta::CPAN

$gblskip ||= -e $script ? '' : 'Can not find satpass script.';


#	Initialize.

my $data = '';		# Test data;
my $failure;		# Notes to output if the next test fails.
my $home = getcwd;	# Directory test runs in.
my $skip;		# Skip indicator
my $test = 0;		# Test number;
my @todo = ();		# Tests expected to fail.
my %h_todo;		# Hash of tests expected to fail.

sub satpass {
    my $handle = shift;

#	If we can not get off the ground, do not try.

    if ($gblskip) {
	plan tests => 1;
	skip ($gblskip, 1);
	return;
    }

    local $| = 1;

#	Set up the testing hook in satpass.
# >>>	This interface is undocumented, and unsupported except for its
# >>>	use in this test script.

    no warnings qw{once};
    $Astro::satpass::Test::Hook = \&tester;
    $Astro::satpass::Test::Handle = $handle;
    use warnings qw{once};

#	Make a pass through the <DATA> to figure out how many tests
#	there are. Tell the Test package how many.

    my $start = tell ($handle);
    local $_ = undef;	# while (<>) ... does not localize $_.
    while (<$handle>) {
	if (m/^\s*-test\b/) {
	    $test++
	} elsif (m/^\s*-todo\b/) {
	    push @todo, $test;
	} elsif (m/^\s*-end\b/) {
	    last;
	}
    }
    seek ($handle, $start, 0);
    plan tests => $test, todo => \@todo;
    %h_todo = map {$_ => 1} @todo;

#	We start from test 1 (since we increment before use).

    $test = 0;

#	Set up the command arguments and 'do' the satpass script. All
#	further work is done by tester() when the script calls it.

    local @ARGV = ('-filter', -initialization_file => File::Spec->devnull ());
    $skip = '';
    do $script;
    print $@ if $@;
    return;
}

#	not_available(module ...) is a utility to determine whether the
#	given modules are available. If so, it loads them. If not, it
#	returns a message for the first module that can not be loaded.

sub not_available {
    foreach my $module (@_) {
	eval "require $module; 1"
	    or return "Module $module can not be loaded.";
    }
    return '';
}

#	not_reachable($url ...) is a utilty to determine whether the given
#	URLs are reachable. If so, it returns false. If not, it returns
#	a suitable message. Makes use of LWP::UserAgent, so may return
#	the results of not_available ('LWP::UserAgent').

sub not_reachable {
    my @args = @_;
    my $ok = not_available ('LWP::UserAgent');
    return $ok if $ok;
    my $ua = LWP::UserAgent->new ()
	or return "Cannot instantiate LWP::UserAgent.\n$@";
    foreach my $url (@args) {
	my $resp = $ua->get ($url);
	return $resp->status_line unless $resp->is_success;
    }
    return '';
}

#	tester() is the test callback. It is called whenever the
#	satpass script wants top-level input. The arguments are the
#	handle used for test I/O (God knows what you would do with
#	this), the _previous_ input line, all output since the previous
#	input was done, and the exception generated (or undef if none).
#	It returns the next line of input, or undef for end-of-file.

#	At least, that's what satpass expects of it. What it does
#	from the point of view of this script is to read the <DATA>
#	handle, parsing the file as it goes. A line that begins with
#	'-' is a test directive; these will be documented in-line.
#	Empty lines and lines beginning with '#' are ignored.
#	Any thing else is returned intact to the caller if the $skip
#	indicator (see below) is false, or ignored if it is true.

#	The test mechanism relies on the values of four local
#	variables:
#	    $data is the expected output of the test, though you
#		will find it is used for other purposes as well.
#	    $output is the output from the satpass script, which
#		was passed by the caller. There are a couple
#		mechanisms to replace this by other data.
#	    $except is the exception encountered, if any, which
#		was passed from the caller.