view release on metacpan or  search on metacpan

t/lib/Crypt/OpenSSL/CA/Test.pm  view on Meta::CPAN

}

sub run_perl_script {
  my ($scriptfile) = @_;

  my ($stdout, $stderr);
  IPC::Run::run([_perl_cmdline(), $scriptfile], \"", \$stdout, \$stderr);
  return $stdout . $stderr;
}

BEGIN { foreach my $functionname (qw(run_perl run_perl_script)) {
    my $ok_wrapper = sub {
        my ($script_or_file, $outref, $testname) = @_;
        $testname ||= $functionname;

        my $context = context();
        my $out = __PACKAGE__->can($functionname)->($script_or_file);
        $$outref = $out if ref($outref) eq "SCALAR";
        if ($?) {
            return $context->fail_and_release($testname, "exited with code $?", $out);
        } else {
            return $context->pass_and_release($testname);
        }
    };

    no strict "refs";
    *{"${functionname}_ok"} = $ok_wrapper;
}}

=head2 _perl_cmdline ()

Computes (with cache) and returns the command line to invoke sub-Perls
as on behalf of L</run_perl> and L</run_perl_script> while (more or
less) preserving @INC.

Returns the name of the Perl binary and a list of C<-I> command line
switches that should be passed as part of an invocation of
<perlfunc/system> or similar.  The C<-I> paths returned are exactly
the elements in the current @INC that are B<not> part of the Perl
interpreter's compiled-in @INC.

=cut

{
    my @perlcmdline;
    sub _perl_cmdline {
        return @perlcmdline if @perlcmdline;
        my ($perl) = ($^X =~ m/^(.*)$/); # Untainted

        # There might be a more elegant way of fetching the pristine
        # @INC set...
        my ($indent, $orig_inc);
        {
            local $ENV{PERL5LIB};
            ( ($indent, $orig_inc) = `$perl -V` =~ m/^( *)\@INC:\n(.*)\Z/sm )
              or die <<"FAIL";
Couldn't find original \@INC in the output of $perl -V.
FAIL
        }
        my %orig_inc_set;
        foreach (split m{$/}, $orig_inc) {
            last unless m/^$indent +(.*?)$/;
            $orig_inc_set{$1}++;
        }

        @perlcmdline = ($perl, (map { -I => $_ } (grep {! $orig_inc_set{$_} } @INC)));
        diag(join(" ", @perlcmdline)) if $ENV{DEBUG};
        return @perlcmdline;
    }
}

=head2 errstack_empty_ok ()

Asserts that OpenSSL's error stack is empty, and clears it if not.  To
be run at the end of every test.

=cut

sub errstack_empty_ok {
    my $context = context();

    my @ssleay_errors;
    require Net::SSLeay;
    while(my $error = Net::SSLeay::ERR_get_error()) {
        push(@ssleay_errors, $error);
    }
    if (@ssleay_errors) {
        return $context->fail_and_release("Errors found on OpenSSL's stack",
                                          @ssleay_errors);
    } else {
        return $context->pass_and_release("No errors found on OpenSSL's stack");
    }
}

=head2 cannot_check_SV_leaks ()

Returns true iff L<Devel::Leak> is unavailable.

=cut

sub cannot_check_SV_leaks { ! eval { require Devel::Leak } }

=head2 cannot_check_bytes_leaks ()

Returns true iff L<Devel::Mallinfo> is unavailable or does nothing on
this platform (eg MacOS).

=cut

sub cannot_check_bytes_leaks {
    return 1 if ! eval { require Devel::Mallinfo };
    return (! exists Devel::Mallinfo::mallinfo()->{uordblks});
}

=head2 leaks_SVs_ok ($coderef, %named_arguments)

Executes $coderef and asserts (with L<Test::More>) that it doesn't
leak Perl SVs (checked using L<Devel::Leak>).  As a tester, you should
arrange for $coderef to manipulate about 10 SVs; smaller leaks will
not be detected (see I<-max> below).