App-Fetchware
view release on metacpan or search on metacpan
lib/Test/Fetchware.pm view on Meta::CPAN
my $coderef = shift;
my $test_name = shift;
my $kid = fork;
die "Couldn't fork: $!\n" if not defined $kid;
# ... parent code here ...
if ( $kid ) {
# Block waiting for the child process ($kid) to exit.
waitpid($kid, 0);
}
# ... child code here ...
else {
# Run caller's code wihtout any args.
# And exit based on the success or failure of $coderef.
$coderef->() ? exit 0 : exit 1;
}
# Check that the child failed and returned nonzero.
ok(($? >> 8) != 0, $test_name);
return $?;
}
sub skip_all_unless_release_testing {
if (not exists $ENV{FETCHWARE_RELEASE_TESTING}
or not defined $ENV{FETCHWARE_RELEASE_TESTING}
or $ENV{FETCHWARE_RELEASE_TESTING}
ne '***setting this will install software on your computer!!!!!!!***'
# Enforce having *all* other FETCHWARE_* env vars set too to make it
# even harder to easily enable FETCHWARE_RELEASE_TESTING. This is
# because FETCHWARE_RELEASE_TESTING *installs* software on your
# computer.
#
# Furthermore, the env vars below are required for
# FETCHWARE_RELEASE_TESTING to work properly, so without them being set,
# then FETCHWARE_RELEASE_TESTING will not work properly, because these
# env vars will be undef; therefore, check to see if they're enabled.
) {
plan skip_all => 'Not testing for release.';
}
}
sub make_clean {
BAIL_OUT(<<EOF) if -e 'lib/Test/Fetchware.pm' && -e 't/App-Fetchware-build.t';
Running make_clean() inside of fetchware's own directory! make_clean() should
only be called inside testing build directories, and perhaps also only called if
FETCHWARE_RELEASE_TESTING has been set.
EOF
system('make', 'clean');
chdir(updir()) or fail(q{Can't chdir(updir())!});
}
###BUGALERT### make_test_dist() only works properly on Unix, because of its
#dependencies on the shell and make, just replace those commands with perl
#itself, which we can pretty much guaranteed to be installed.
sub make_test_dist {
my %opts = @_;
# Validate options, and set defaults if they need to be set.
if (not defined $opts{file_name}) {
die <<EOD;
Test-Fetchware: file_name named parameter is a mandatory options, and must be
specified despite it pretty much always being just 'test-dist'. It is still
mandatory.
EOD
}
if (not defined $opts{ver_num}) {
die <<EOD;
Test-Fetchware: ver_num named parameter is a mandatory options, and must be
specified despite it pretty much always being just '1.00'. It is still
mandatory.
EOD
}
# $destination_directory is a mandatory option, but if the caller does not
# provide one, then simply use a tempdir().
if (not defined $opts{destination_directory}) {
$opts{destination_directory}
= tempdir("fetchware-test-$$-XXXXXXXXXXX", TMPDIR => 1, CLEANUP => 1);
# Don't *only* create the tempdid $destination_directory, also, it must
# be chmod()'d to 755, unless stay_root is set, so that the dropped priv
# user can still access the directory make_test_dist() creates.
chmod 0755, $opts{destination_directory} or die <<EOD;
Test-Fetchware: Fetchware failed to change the permissions of it's testing
destination directory [$opts{destination_directory}] this shouldn't happen, and is
perhaps a bug. The OS error was [$!].
EOD
}
# This %opts check must go before the code below sets fetchwarefile even if
# the user did not supply it. Perhaps separate things should stay separate,
# and %opts and %test_dist_files should both exist for this, but why bother
# duplicating the same information if only one options is annoyed?
if (defined $opts{fetchwarefile} and defined $opts{append_option}) {
die <<EOD;
fetchware: Run-time error. make_test_dist() can only be called with the
Fetchwarefile option *or* the append_option named parameters never both. Only
specify one.
EOD
}
if (not defined $opts{fetchwarefile}) {
$opts{fetchwarefile} = <<EOF;
# $opts{file_name} is a fake "test distribution" meant for testing fetchware's basic
# installing, upgrading, and so on functionality.
use App::Fetchware;
program '$opts{file_name}';
# Every Fetchwarefile needs a lookup_url...
lookup_url 'file://$opts{destination_directory}';
# ...and a mirror.
mirror 'file://$opts{destination_directory}';
# Need to filter out the cruft.
lib/Test/Fetchware.pm view on Meta::CPAN
|
patches
/x),
re(qr/\d{10,12}/)
) # end any
)
);
EOC
return $expected_filename_listing;
}
sub verbose_on {
# Turn on verbose functionality.
$fetchware::verbose = 1;
}
sub export_ok{
my ($sorted_subs, $sorted_export) = @_;
package main;
my @sorted_subs = sort @$sorted_subs;
my @sorted_export = sort @$sorted_export;
fail("Specified arrays have a different length.\n[@sorted_subs]\n[@sorted_export]")
if @sorted_subs != @sorted_export;
my $i = 0;
for my $e (@sorted_subs) {
if ($e eq $sorted_export[$i]) {
pass("[$e] matches [$sorted_export[$i]]");
} else {
fail("[$e] does *not* match [$sorted_export[$i]]");
}
$i++;
}
}
sub end_ok {
my $temp_dir = shift;
ok(open(my $fh_sem, '>', catfile($temp_dir, 'fetchware.sem')),
'checked cleanup_tempdir() open fetchware lock file success.');
ok( flock($fh_sem, LOCK_EX | LOCK_NB),
'checked cleanup_tempdir() success.');
ok(close $fh_sem,
'checked cleanup_tempdir() released fetchware lock file success.');
}
sub add_prefix_if_nonroot {
my $callback = shift;
my $prefix;
if (not is_os_type('Unix') or $> != 0 ) {
if (not defined $callback) {
$prefix = tempdir("fetchware-test-$$-XXXXXXXXXX",
TMPDIR => 1, CLEANUP => 1);
note("Running as nonroot or nonunix using prefix temp dir [$prefix]");
config(prefix => $prefix);
} else {
ok(ref $callback eq 'CODE', <<EOD);
Received callback that is a proper coderef [$callback].
EOD
$prefix = $callback->();
}
# Return the prefix that will be used.
return $prefix;
} else {
# Return undef meaning no prefix was added.
return;
}
}
sub create_test_fetchwarefile {
my $fetchwarefile_content = shift;
# Use a temp dir outside of the installation directory
my ($fh, $fetchwarefile_path)
=
tempfile("fetchware-$$-XXXXXXXXXXXXXX", TMPDIR => 1, UNLINK => 1);
# Chmod 644 to ensure a possibly dropped priv child can still at least read
# the file. It doesn't need write access just read.
unless (chmod 0644, $fetchwarefile_path
and
# Only Unix drops privs. Nonunix does not.
is_os_type('Unix')
) {
die <<EOD;
fetchware: Failed to chmod 0644, [$fetchwarefile_path]! This is a fatal error,
because if the file is not chmod()ed, then fetchware cannot access the file if
it was created by root, and then tried to read it, but root on Unix dropped
privs. OS error [$!].
EOD
}
# Be sure to add a prefix to the generated Fetchwarefile if fetchware is not
# running as root to ensure that our test installs succeed.
#
# Prepend a newline to ensure that prefix is not added to an existing line.
add_prefix_if_nonroot(sub {
my $prefix_dir = tempdir("fetchware-test-$$-XXXXXXXXXX",
TMPDIR => 1, CLEANUP => 1);
$fetchwarefile_content
.=
"\nprefix '$prefix_dir';";
}
);
# Put test stuff in Fetchwarefile.
print $fh "$fetchwarefile_content";
# Close the file in case it bothers Archive::Tar reading it.
close $fh;
return $fetchwarefile_path;
}
sub rmdashr_ok {
my ($dir_to_recursive_delete, $test_message) = @_;
# If $dir_to_recursive_delete is just a file, just unlink it.
if (not -d $dir_to_recursive_delete) {
unlink($dir_to_recursive_delete)
or fail("Failed to unlink([$dir_to_recursive_delete]): $!")
} else {
# Delete the whole $tempdir. Use error and result for File::Path's
# experimental error handling, and set safe to true to avoid borking the
# filesystem. This might be run as root, so it really could screw up
# your filesystem big time! So set safe to true to avoid doing so.
my $ok = remove_tree($dir_to_recursive_delete, {
error => \my $err,
result => \my $res,
safe => 1} );
# Parse remove_tree()'s insane error handling system. It's expirimental,
# but it's been experimental forever, so I can't see it changing.
if (@$err) {
for my $diag (@$err) {
my ($file, $message) = %$diag;
if ($file eq '') {
warn "general error: $message\n";
} else {
warn "problem unlinking $file: $message\n";
}
}
} else {
note("No errors encountered during removal of [$dir_to_recursive_delete]\n");
}
lib/Test/Fetchware.pm view on Meta::CPAN
=head1 TESTING SUBROUTINES
=head2 eval_ok()
eval_ok($code, $expected_exception_text_or_regex, $test_name);
Executes the $code coderef, and compares its thrown exception, C<$@>, to
$expected_exception_text_or_regex, and uses $test_name as the name for the test if
provided.
If $expected_exception_text_or_regex is a string then Test::More's is() is used,
and if $expected_exception_text_or_regex is a C<'Regexp'> according to ref(),
then like() is used, which will treat $expected_exception_text_or_regex as a
regex instead of as just a string.
=head2 print_ok()
print_ok(\&printer, $expected, $test_name);
Tests if $expected is in the output that C<\&printer-E<gt>()> produces on C<STDOUT>.
It passes $test_name along to the underlying L<Test::More> function that it uses
to do the test.
$expected can be a C<SCALAR>, C<Regexp>, or C<CODEREF> as returned by Perl's
L<ref()> function.
=over
=item * If $expected is a SCALAR according to ref()
=over
=item * Then Use eq to determine if the test passes.
=back
=item * If $expected is a Regexp according to ref()
=over
=item * Then use a regex comparision just like Test::More's like() function.
=back
=item * If $expected is a CODEREF according to ref()
=over
=item * Then execute the coderef with a copy of the $printer's STDOUT and use the result of that expression to determine if the test passed or failed .
=back
=back
=over
NOTICE: C<print_ok()'s> manipuation of STDOUT only works for the current Perl
process. STDOUT may be inherited by forks, but for some reason my knowledge of
Perl and Unix lacks a better explanation other than that print_ok() does not
work for testing what C<fork()ed> and C<exec()ed> processes do such as those
executed with run_prog().
I also have not tested other possibilities, such as using IO::Handle to
manipulate STDOUT, or tie()ing STDOUT like Test::Output does. These methods
probably would not survive a fork() and an exec() though either.
=back
=head2 fork_ok()
fork_ok(&code_fork_should_do, $test_name);
Simply properly forks, and runs the caller's provided coderef in the child,
and tests that the child's exit value is 0 for success using a simple ok() call from
Test::More. The child's exit value is controlled by the caller based on what
&code_fork_should_do returns. If &code_fork_should_do returns true, then the
child returns C<0> for success, and if &code_fork_should_do returns false, then
the child returns C<1> for failure.
Because the fork()ed child is a copy of the current perl process you can still
access whatever Test::More or Test::Fetchware testing subroutines you may have
imported for use in the test file that uses fork_ok().
This testing helper subroutine only exists for testing fetchware's command line
interface. This interface is fetchware's run() subroutine and when you actually
execute the fetchware program from the command line such as C<fetchware help>.
=over
=item WARNING
fork_ok() has a major bug that makes any tests you attempt to run in
&code_fork_should_do that fail never report this failure properly to
Test::Builder. Also, any success is not reported either. This is not fork_ok()'s
fault it is Test::Builder's fault for still not having support for forking. This
lack of support for forking may be fixed in Test::Builder 1.5 or perhaps 2.0,
but those are still in development.
=back
=head2 fork_not_ok()
fork_not_ok(&code_fork_should_do, $test_name);
The exact same thing as fork_ok() except it expects failure and reports true
when the provided coderef returns failure. If the provided coderef returns true,
then it reports failure to the test suite.
The same warnings and problems associated with fork_ok() apply to fork_not_ok().
=head2 skip_all_unless_release_testing()
subtest 'some subtest that tests fetchware' => sub {
skip_all_unless_release_testing();
# ... Your tests go here that will be skipped unless
# FETCHWARE_RELEASE_TESTING among other env vars are set properly.
};
( run in 0.544 second using v1.01-cache-2.11-cpan-64ef6c95b5d )