Test-Stream

 view release on metacpan or  search on metacpan

lib/Test/Stream/Plugin/Capture.pm  view on Meta::CPAN

use strict;
use warnings;

use Test::Stream::Util qw/try/;
use Carp qw/croak/;

use Test::Stream::Exporter qw/import default_exports/;
default_exports qw/capture/;
no Test::Stream::Exporter;

sub capture(&) {
    my $code = shift;

    my ($err, $out) = ("", "");

    my ($ok, $e);
    {
        local *STDOUT;
        local *STDERR;

        ($ok, $e) = try {

lib/Test/Stream/Plugin/Compare.pm  view on Meta::CPAN

        $ctx->ok(0, $name, [$delta->table, @diag]);
    }
    else {
        $ctx->ok(1, $name);
    }

    $ctx->release;
    return !$delta;
}

sub meta(&)   { build('Test::Stream::Compare::Meta',   @_) }
sub hash(&)   { build('Test::Stream::Compare::Hash',   @_) }
sub array(&)  { build('Test::Stream::Compare::Array',  @_) }
sub object(&) { build('Test::Stream::Compare::Object', @_) }

my $FDNE = Test::Stream::Compare::Custom->new(code => sub { $_ ? 0 : 1 }, name => 'FALSE', operator => 'FALSE() || !exists');
my $DNE = Test::Stream::Compare::Custom->new(code => sub { my %p = @_; $p{exists} ? 0 : 1 },          name => '<DOES NOT EXIST>', operator => '!exists');
my $F   = Test::Stream::Compare::Custom->new(code => sub { my %p = @_; $p{got}    ? 0 : $p{exists} }, name => 'FALSE',            operator => 'FALSE()');
my $T = Test::Stream::Compare::Custom->new(code => sub { $_         ? 1 : 0 }, name => 'TRUE',    operator => 'TRUE()');
my $D = Test::Stream::Compare::Custom->new(code => sub { defined $_ ? 1 : 0 }, name => 'DEFINED', operator => 'DEFINED()');

sub T()    { $T }
sub F()    { $F }
sub D()    { $D }

lib/Test/Stream/Plugin/Compare.pm  view on Meta::CPAN

    my ($str, @args) = @_;
    my @caller = caller;
    return Test::Stream::Compare::String->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $str,
        @args,
    );
}

sub filter_items(&) {
    my $build = get_build() or croak "No current build!";

    croak "'$build' does not support filters"
        unless $build->can('add_filter');

    croak "'filter_items' should only ever be called in void context"
        if defined wantarray;

    $build->add_filter(@_);
}

lib/Test/Stream/Plugin/Exception.pm  view on Meta::CPAN

use strict;
use warnings;

use Test::Stream::Util qw/try/;
use Carp qw/croak/;

use Test::Stream::Exporter qw/import default_exports/;
default_exports qw/lives dies/;
no Test::Stream::Exporter;

sub lives(&) {
    my $code = shift;
    my ($ok, $err) = &try($code);
    return 1 if $ok;
    warn $err;
    return 0;
}

sub dies(&) {
    my $code = shift;
    my ($ok, $err) = &try($code);
    return undef if $ok;
    return $err;
}

1;

__END__

lib/Test/Stream/Plugin/Intercept.pm  view on Meta::CPAN

use Test::Stream::Util qw/try/;
use Test::Stream::Context qw/context/;

use Test::Stream::Hub::Interceptor();
use Test::Stream::Hub::Interceptor::Terminator();

use Test::Stream::Exporter qw/import default_exports/;
default_exports qw/intercept/;
no Test::Stream::Exporter;

sub intercept(&) {
    my $code = shift;

    my $ctx = context();

    my $ipc;
    if ($INC{'Test/Stream/IPC.pm'}) {
        my ($driver) = Test::Stream::IPC->drivers;
        $ipc = $driver->new;
    }

lib/Test/Stream/Plugin/Warnings.pm  view on Meta::CPAN

use strict;
use warnings;

use Carp qw/croak/;
use Test::Stream::Util qw/protect/;

use Test::Stream::Exporter qw/import default_exports/;
default_exports qw/warning warns no_warnings/;
no Test::Stream::Exporter;

sub warning(&) {
    my $warnings = &warns(@_) || [];
    if (@$warnings != 1) {
        warn $_ for @$warnings;
        croak "Got " . scalar(@$warnings) . " warnings, expected exactly 1"
    }
    return $warnings->[0];
}

sub no_warnings(&) {
    my $warnings = &warns(@_);
    return 1 unless defined $warnings;
    warn $_ for @$warnings;
    return 0;
}

sub warns(&) {
    my @warnings;
    local $SIG{__WARN__} = sub {
        push @warnings => @_;
    };
    &protect(@_);
    return undef unless @warnings;
    return \@warnings;
}

1;

lib/Test/Stream/Util.pm  view on Meta::CPAN

    # No ref, easy!
    return $masks->{$file}->{$line}->{$name} = {%$mask}
        unless $ref;

    # Merge new mask into old
    %$ref = (%$ref, %$mask);
    return;
}

sub _manual_protect(&) {
    my $code = shift;

    rename_anon_sub('protect', $code, caller) if CAN_SET_SUB_NAME;

    my ($ok, $error);
    {
        my ($msg, $no) = ($@, $!);
        $ok = eval {
            BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 3}) }
            $code->();
            1
        } || 0;
        $error = $@ || "Error was squashed!\n";
        ($@, $!) = ($msg, $no);
    }
    die $error unless $ok;
    return $ok;
}

sub _local_protect(&) {
    my $code = shift;

    rename_anon_sub('protect', $code, caller) if CAN_SET_SUB_NAME;

    my ($ok, $error);
    {
        local ($@, $!);
        $ok = eval {
            BEGIN { update_mask(__FILE__, __LINE__ + 1, '*', {hide => 3}) }
            $code->();
            1
        } || 0;
        $error = $@ || "Error was squashed!\n";
    }
    die $error unless $ok;
    return $ok;
}

sub _manual_try(&;@) {
    my $code = shift;
    my $args = \@_;
    my $error;
    my $ok;

    rename_anon_sub('try', $code, caller) if CAN_SET_SUB_NAME;

    {
        my ($msg, $no) = ($@, $!);
        my $die = delete $SIG{__DIE__};

lib/Test/Stream/Util.pm  view on Meta::CPAN

            $SIG{__DIE__} = $die;
        }
        else {
            delete $SIG{__DIE__};
        }
    }

    return ($ok, $error);
}

sub _local_try(&;@) {
    my $code = shift;
    my $args = \@_;
    my $error;
    my $ok;

    rename_anon_sub('try', $code, caller) if CAN_SET_SUB_NAME;

    {
        local ($@, $!, $SIG{__DIE__});
        $ok = eval {

t/modules/Context.t  view on Meta::CPAN

use Test::Stream::Context qw/context release/;

can_ok(__PACKAGE__, qw/context release/);

my $error = dies { context(); 1 };
my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1);
like($error, qr/^\Q$exception\E/, "Got the exception" );

my $ref;
my $frame;
sub wrap(&) {
    my $ctx = context();
    my ($pkg, $file, $line, $sub) = caller(0);
    $frame = [$pkg, $file, $line, $sub];

    $_[0]->($ctx);

    $ref = "$ctx";

    $ctx->release;
}