Test-Simple

 view release on metacpan or  search on metacpan

lib/Test2/API.pm  view on Meta::CPAN

# Private, for use in Test2::API::Context
sub _contexts_ref                  { $INST->contexts }
sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks }
sub _context_init_callbacks_ref    { $INST->context_init_callbacks }
sub _context_release_callbacks_ref { $INST->context_release_callbacks }
sub _add_uuid_via_ref              { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) }

# Private, for use in Test2::IPC
sub _set_ipc { $INST->set_ipc(@_) }

sub context_do(&;@) {
    my $code = shift;
    my @args = @_;

    my $ctx = context(level => 1);

    my $want = wantarray;

    my @out;
    my $ok = eval {
        $want          ? @out    = $code->($ctx, @args) :

lib/Test2/API.pm  view on Meta::CPAN

    $ctx->release;

    die $err unless $ok;

    return @out    if $want;
    return $out[0] if defined $want;
    return;
}

sub no_context(&;$) {
    my ($code, $hid) = @_;
    $hid ||= $STACK->top->hid;

    my $ctx = $CONTEXTS->{$hid};
    delete $CONTEXTS->{$hid};
    my $ok = eval { $code->(); 1 };
    my $err = $@;

    $CONTEXTS->{$hid} = $ctx;
    weaken($CONTEXTS->{$hid});

lib/Test2/API.pm  view on Meta::CPAN

Removing the old context and creating a new one...
    EOT
}

sub release($;$) {
    $_[0]->release;
    return $_[1];
}

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

    my $events = _intercept($code, deep => 0);

    $ctx->release;

    return $events;
}

sub intercept_deep(&) {
    my $code = shift;
    my $ctx = context();

    my $events = _intercept($code, deep => 1);

    $ctx->release;

    return $events;
}

lib/Test2/Tools/Compare.pm  view on Meta::CPAN

    }
    else {
        $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]);
        $ctx->$_autodump($got);
    }

    $ctx->release;
    return $delta ? 1 : 0;
}

sub meta(&)       { build('Test2::Compare::Meta',          @_) }
sub meta_check(&) { build('Test2::Compare::Meta',          @_) }
sub hash(&)       { build('Test2::Compare::Hash',          @_) }
sub array(&)      { build('Test2::Compare::Array',         @_) }
sub bag(&)        { build('Test2::Compare::Bag',           @_) }
sub object(&)     { build('Test2::Compare::Object',        @_) }
sub subset(&)     { build('Test2::Compare::OrderedSubset', @_) }

sub U() {
    my @caller = caller;
    Test2::Compare::Custom->new(
        code => sub { defined $_ ? 0 : 1 }, name => 'UNDEFINED', operator => '!DEFINED()',
        file => $caller[1],
        lines => [$caller[2]],
    );
}

lib/Test2/Tools/Compare.pm  view on Meta::CPAN

    my ($class_name, @args) = @_;
    my @caller = caller;
    return Test2::Compare::Isa->new(
        file  => $caller[1],
        lines => [$caller[2]],
        input => $class_name,
        @args,
    );
}

sub filter_items(&) {
    defined( 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/Test2/Tools/Exception.pm  view on Meta::CPAN

use warnings;

our $VERSION = '1.302210';

use Carp qw/carp/;
use Test2::API qw/context test2_add_pending_diag test2_clear_pending_diags/;

our @EXPORT = qw/dies lives try_ok/;
use base 'Exporter';

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

    defined wantarray or carp "Useless use of dies() in void context";

    local ($@, $!, $?);
    my $ok = eval { $code->(); 1 };
    my $err = $@;

    return undef if $ok;

    unless ($err) {
        my $ctx = context();
        $ctx->alert("Got exception as expected, but exception is falsy (undef, '', or 0)...");
        $ctx->release;
    }

    return $err;
}

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

    defined wantarray or carp "Useless use of lives() in void context";

    my $err;
    {
        local ($@, $!, $?);
        eval { $code->(); 1 } and return 1;
        $err = $@;
    }

    test2_add_pending_diag("Exception: $err");

    # If the eval failed we want to set $@ to the error.
    $@ = $err;
    return 0;
}

sub try_ok(&;$) {
    my ($code, $name) = @_;

    my $ok = &lives($code);
    my $err = $@;

    my @diag = test2_clear_pending_diags();

    # Context should be obtained AFTER code is run so that events inside the
    # codeblock report inside the codeblock itself. This will also preserve $@
    # as thrown inside the codeblock.

lib/Test2/Tools/Tiny.pm  view on Meta::CPAN

    $ctx->plan($max);
    $ctx->release;
}

sub done_testing {
    my $ctx = context();
    $ctx->done_testing;
    $ctx->release;
}

sub warnings(&) {
    my $code = shift;
    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings => @_ };
    $code->();
    return \@warnings;
}

sub exception(&) {
    my $code = shift;
    local ($@, $!, $SIG{__DIE__});
    my $ok = eval { $code->(); 1 };
    my $error = $@ || 'SQUASHED ERROR';
    return $ok ? undef : $error;
}

sub tests {
    my ($name, $code) = @_;
    my $ctx = context();

lib/Test2/Tools/Tiny.pm  view on Meta::CPAN

    $be->($name) if $be;

    my $bool = run_subtest($name, $code, 1);

    $ctx->release;

    return $bool;
}

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

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

    my $handles = test2_stack->top->format->handles;
    my ($ok, $e);
    {
        my ($out_fh, $err_fh);

        ($ok, $e) = try {

lib/Test2/Tools/Warnings.pm  view on Meta::CPAN

use warnings;

our $VERSION = '1.302210';

use Carp qw/carp/;
use Test2::API qw/context test2_add_pending_diag/;

our @EXPORT = qw/warns warning warnings no_warnings/;
use base 'Exporter';

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

    defined wantarray or carp "Useless use of warns() in void context";

    my $warnings = 0;
    local $SIG{__WARN__} = sub { $warnings++ };
    $code->();
    return $warnings;
}

sub no_warnings(&) {
    defined wantarray or carp "Useless use of no_warnings() in void context";

    my $warnings = &warnings(@_);
    return 1 if !@$warnings;

    test2_add_pending_diag(@$warnings);

    return 0;
}

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

    defined wantarray or carp "Useless use of warning() in void context";

    my @warnings;
    {
        local $SIG{__WARN__} = sub { push @warnings => @_ };
        $code->();
        return unless @warnings;
    }

lib/Test2/Tools/Warnings.pm  view on Meta::CPAN

    if (@warnings > 1) {
        my $ctx = context();
        $ctx->alert("Extra warnings in warning { ... }");
        $ctx->note($_) for @warnings;
        $ctx->release;
    }

    return $warnings[0];
}

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

    defined wantarray or carp "Useless use of warnings() in void context";

    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings => @_ };
    $code->();

    return \@warnings;
}

lib/Test2/Util.pm  view on Meta::CPAN

my $can_really_fork;
sub CAN_REALLY_FORK () {
    return $can_really_fork
        if defined $can_really_fork;
    $can_really_fork = !!$Config{d_fork};
    no warnings 'redefine';
    *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 };
    $can_really_fork;
}

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

    my $die = delete $SIG{__DIE__};

    eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";

    $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__};

    return (!defined($err), $err);
}

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

    no warnings;
    local $SIG{__DIE__};
    eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";

    return (!defined($err), $err);
}

lib/Test2/Util.pm  view on Meta::CPAN

        };
        *do_unlink = sub {
            my ($file) = @_;
            return (1) if unlink($file);
            return (0, "$!");
        };
    }
}

#for backwards compatibility
sub try_sig_mask(&) {
    require Test2::Util::Sig;
    goto &Test2::Util::Sig::try_sig_mask;
}

1;

__END__

=pod

lib/Test2/Util/Sig.pm  view on Meta::CPAN

our $VERSION = '1.302210';

use POSIX();
use Test2::Util qw/try IS_WIN32/;

our @EXPORT_OK = qw{
    try_sig_mask
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }

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

    my ($old, $blocked);
    unless(IS_WIN32) {
        my $to_block = POSIX::SigSet->new(
            POSIX::SIGINT(),
            POSIX::SIGALRM(),
            POSIX::SIGHUP(),
            POSIX::SIGTERM(),
            POSIX::SIGUSR1(),

t/HashBase.t  view on Meta::CPAN

use strict;
use warnings;

use Test::More;


sub warnings(&) {
    my $code = shift;
    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings => @_ };
    $code->();
    return \@warnings;
}

sub exception(&) {
    my $code = shift;
    local ($@, $!, $SIG{__DIE__});
    my $ok = eval { $code->(); 1 };
    my $error = $@ || 'SQUASHED ERROR';
    return $ok ? undef : $error;
}

BEGIN {
    $INC{'Object/HashBase/Test/HBase.pm'} = __FILE__;

t/Legacy/Regression/736_use_ok.t  view on Meta::CPAN

BEGIN {
    $INC{'MyWarner.pm'} = 1;
    package MyWarner;

    sub import {
        warnings::warnif('deprecated', "Deprecated! run for your lives!");
    }
}

sub capture(&) {
    my $warn;
    local $SIG{__WARN__} = sub { $warn = shift };
    $_[0]->();
    return $warn || "";
}

{
local $TODO = "known to fail on $]" if "$]" <= 5.006002;
my $file = __FILE__;
my $line = __LINE__ + 4;

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

    test2_add_callback_context_init
    test2_add_callback_context_release
};

my $error = exception { 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;
}

t/Test2/modules/IPC/Driver/Files.t  view on Meta::CPAN

use File::Spec;
use List::Util qw/shuffle/;
use strict;
use warnings;

if ("$]" < 5.008) {
    print "1..0 # SKIP Test cannot run on perls below 5.8.0\n";
    exit 0;
}

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

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

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

        ($ok, $e) = try {

t/modules/Plugin/SRand.t  view on Meta::CPAN

use Test2::Tools::Basic;
use Test2::API qw/intercept test2_stack context/;
use Test2::Tools::Compare qw/array event end is like/;
use Test2::Tools::Target 'Test2::Plugin::SRand';
use Test2::Tools::Warnings qw/warning/;

test2_stack->top;
my ($root) = test2_stack->all;

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

    # This is to force loading to happen
    my $ctx = context();

    my @events;

    my $l = $root->listen(sub {
        my ($h, $e) = @_;
        push @events => $e;

t/modules/Tools/Defer.t  view on Meta::CPAN

    def is => (1, 1, "1 is 1");
    def is => ({}, {}, "hash is hash");

    def ok => (0, 'lies');
    def is => (0, 1, "1 is not 0");
    def is => ({}, [], "a hash is not an array");
}

use Test2::Bundle::Extended -target => 'Test2::Tools::Defer';

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

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

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

        ($ok, $e) = Test2::Util::try(sub {