view release on metacpan or  search on metacpan

lib/Assert/Refute.pm  view on Meta::CPAN

            %conf = (%conf, %$_);
            $need_conf++;
        } elsif (!ref $_ and $_ eq '{}') {
            # TODO 0.15 remove together with auto-carp
            $need_conf++; # allow for -MAssert::Refute={}
        } elsif (!ref $_) {
            push @exp, $_;
        } else {
            croak "Unexpected argument in Assert::Refute->import: ".ref $_;
        };
    };

    $class->configure( \%conf, scalar caller ) if $need_conf;
    $class->export_to_level(1, undef, @exp);
};

my %known_callback = (
    skip => '',
    carp => sub {
        my $report = shift;
        warn $report->get_tap . _report_mess( $report );
    },
    croak => sub {
        my $report = shift;
        die $report->get_tap . _report_mess( $report );
    },
);

# TODO maybe public method in Report?
sub _report_mess {
    my $report = shift;

    my $state = $report->is_passing ? "passed" : "failed";
    my $title = $report->get_title;
    my $str   = $title ? "Contract '$title' $state" : "Contract $state";
    return Carp::shortmess($str);
};

my %default_conf = (
    on_fail => 'carp',
    on_pass => 'skip',
);

=head2 try_refute { ... }

Check whether given contract BLOCK containing zero or more assertions passes.

Contract will fail if any of the assertions fails,
a C<plan> is declared and not fulfilled,
or an exception is thrown.
Otherwise it is assumed to pass.

The BLOCK must accept one argument, the contract execution report,
likely a L<Assert::Refute::Report> instance.

More arguments MAY be added in the future.
Return value is ignored.

A read-only report instance is returned by C<try_refute> instead.

If C<on_pass>/C<on_fail> callbacks were specified during C<use> or
using C<configure>, they will also be executed if appropriate.

If C<NDEBUG> or C<PERL_NDEBUG> environment variable is set at compile time,
this block is replaced with a stub
which returns an unconditionally passing report.

This is basically what one expects from a module in C<Assert::*> namespace.

=cut

sub try_refute(&;@) { ## no critic # need prototype
    my ( $block, @arg ) = @_;

    # Should a missing config even happen? Ok, play defensively...
    my $conf = $CALLER_CONF{+caller};
    if( !$conf ) {
        $conf = __PACKAGE__->configure( {}, scalar caller );
    };
    return $conf->{skip_all} if exists $conf->{skip_all};

    my $report = $conf->{driver}->new;
    eval {
        $report->do_run($block);
        1;
    } || do {
        $report->done_testing(
            $@ || Carp::shortmess( 'Contract execution interrupted' ) );
    };

    # perform whatever action is needed
    my $callback = $conf->{ $report->is_passing ? "on_pass" : "on_fail" };
    $callback->($report) if $callback;

    return $report;
};

=head2 assert_refute { ... }

Check whether given contract BLOCK containing zero or more assertions passes.

Contract will fail if any of the assertions fail
or a C<plan> is declared and not fulfilled.
Otherwise it is assumed to pass.

Unlike with try_refute, exceptions are just let through.

The BLOCK must accept one argument, the contract execution report,
likely a L<Assert::Refute::Report> instance.

More arguments MAY be added in the future.
Return value is ignored.

A read-only report instance is returned by C<try_refute> instead.

If C<on_pass>/C<on_fail> callbacks were specified during C<use> or
using C<configure>, they will also be executed if appropriate.

If C<NDEBUG> or C<PERL_NDEBUG> environment variable is set at compile time,
this block is replaced with a stub
which returns an unconditionally passing report.

This is basically what one expects from a module in C<Assert::*> namespace.

B<[EXPERIMENTAL]>. Name and behavior MAY change in the future.
Should this function prove useful, it will become the successor
or C<try_refute>.

=cut

sub assert_refute(&;@) { ## no critic # need prototype
    unshift @_, '';

    goto &_real_assert;
};

=head2 refute_invariant "name" => sub { ... }

A named runtime assertion.

Exactly as above, except that a title is added to the report object
which will be appended to the emitted warning/error (if any).

Title can be queried via C<get_title> method in report object.

B<[EXPERIMENTAL]>. Name and meaning may change in the future.

=cut

sub refute_invariant(@) { ## no critic # need prototype
    my ( $name, $block, @arg ) = @_;

    croak q{Usage: refute_invariant "name" => sub { ... }"}
        unless $name and ref $block eq 'CODE';

    goto &_real_assert;
};

sub _real_assert {
    my ( $name, $block ) = @_;

    # Should a missing config even happen? Ok, play defensively...
    my $conf = $CALLER_CONF{+caller};
    if( !$conf ) {
        # TODO add configure_global & use default configuration
        $conf = __PACKAGE__->configure( { on_fail => 'carp' }, scalar caller );
    };
    return $conf->{skip_all} if exists $conf->{skip_all};

    my $report = $conf->{driver}->new->set_title($name)->do_run($block);

    # perform whatever action is needed
    my $callback = $conf->{ $report->is_passing ? "on_pass" : "on_fail" };
    $callback->($report) if $callback;

    return $report;
};

=head2 refute_and_report { ... }

Run a block of code with a fresh L<Assert::Refute::Report> object as argument.
Lock the report afterwards and return it.

For instance,

    my $report = refute_and_report {
        my $c = shift;
        $c->is( $price * $amount, $total, "Numbers add up" );
        $c->like( $header, qr/<h1>/, "Header as expected" );
        $c->can_ok( $duck, "quack" );
    };

Or alternatively one may resort to L<Test::More>-like DSL:

    use Assert::Refute qw(:all);
    my $report = refute_and_report {
        is      $price * $amount, $total, "Numbers add up";
        like    $header, qr/<h1>/, "Header as expected";
        can_ok  $duck, "quack";
    };

This method does not adhere C<NDEBUG>, apply callbacks, or handle expections.
It just executes the checks.
Not exported by default.

B<[EXPERIMENTAL]>. Name and behavior MAY change in the future.
Should this function prove useful, it will become the successor
or C<try_refute>.

=cut

sub refute_and_report (&;@) { ## no critic # need prototype
    my ( $block, @arg ) = @_;

    return Assert::Refute::Report->new->do_run($block);
};

=head2 contract { ... }

Save a contract BLOCK for future use:

    my $contract = contract {
        my ($foo, $bar) = @_;
        # conditions here
    };

    # much later
    my $report = $contract->apply( $real_foo, $real_bar );
    # Returns an Assert::Refute::Report with conditions applied

This is similar to how C<prepare> / C<execute> works in L<DBI>.

B<[DEPRECATED]> This function will disappear in v.0.20.

Prior to advent of C<try_refute>, this call used to be the main entry point
to this module.
This is no more the case, and a simple subroutine containing assertions
would fit in most places where C<contract> is appropriate.

Use L<Assert::Refute::Contract/contract> instead.

=cut

sub contract (&@) { ## no critic
    carp "contract{ ... } is DEPRECATED, use Assert::Refute::Contract::contract instead";

    require Assert::Refute::Contract;
    goto &Assert::Refute::Contract::contract;
};

=head2 plan tests => $n

Plan to run exactly C<n> assertions within a contract block.
Plan is optional, contract blocks can run fine without a plan.

A contract will fail unconditionally if plan is present and is not fulfilled.

C<plan> may only be called before executing any assertions.
C<plan> dies if called outside a contract block.

Not exported by default to avoid namespace pollution.

lib/Assert/Refute.pm  view on Meta::CPAN

=head2 contract_is

    contract_is $report, $signature, "Message";

Assert that a contract is fulfilled exactly to the specified extent.
See L<Assert::Refute::Report/get_sign> for signature format.

This may be useful for verifying assertions and contracts themselves.

This is actually a clone of L<Assert::Refute::T::Basic/contract_is>.

=cut

=head2 current_contract

Returns the L<Assert::Refute::Report> object being worked on.

If L<Test::Builder> has been detected and no contract block
is executed explicitly, returns a L<Assert::Refute::Driver::More> instance.
This allows to define assertions and run them uniformly under
both L<Assert::Refute> and L<Test::More> control.

Dies if no contract could be detected.

It is actually a clone of L<Assert::Refute::Build/current_contract>.

=head1 STATIC METHODS

Use these methods to configure Assert::Refute globally.

=head2 configure

    use Assert::Refute \%options;
    Assert::Refute->configure( \%options );
    Assert::Refute->configure( \%options, "My::Package");

Set per-caller configuration values for given package.
C<configure> is called implicitly by C<use Assert::Refute { ... }>
if hash parameter(s) are present.

%options may include:

=over

=item * on_pass - callback to execute if tests pass (default: C<skip>)

=item * on_fail - callback to execute if tests fail (default: C<carp>,
but not just C<Carp::carp> - see below).

=item * driver - use that class instead of L<Assert::Refute::Report>
as contract report.

=item * skip_all - reason for skipping ALL C<try_refute> blocks
in the affected package.
This defaults to C<PERL_NDEBUG> or C<NDEBUG> environment variable.

B<[EXPERIMENTAL]>. Name and meaning MAY change in the future.

=back

The callbacks MUST be either
a C<CODEREF> accepting L<Assert::Refute::Report> object,
or one of predefined strings:

=over

=item * skip - do nothing;

=item * carp - warn the stringified report;

=item * croak - die with stringified report as error message;

=back

Returns the resulting config (with default values added,etc).

As of current, this method only affects C<try_refute>.

=cut

my %conf_known;
$conf_known{$_}++ for qw( on_pass on_fail driver skip_all );

sub configure {
    my ($class, $given_conf, $caller) = @_;

    croak "Usage: $class->configure( \\%hash, \$target )"
        unless ref $given_conf eq 'HASH';

    my @extra = grep { !$conf_known{$_} } keys %$given_conf;
    croak "$class->configure: unknown parameters (@extra)"
        if @extra;

    # configure whoever called us by default
    $caller ||= scalar caller;

    my $conf = { %default_conf, %$given_conf };
    $conf->{on_fail} = _coerce_cb($conf->{on_fail});
    $conf->{on_pass} = _coerce_cb($conf->{on_pass});

    # Load driver
    if( $conf->{driver} ) {
        my $mod = "$conf->{driver}.pm";
        $mod =~ s#::#/#g;
        require $mod;
        croak "$conf->{driver} is not Assert::Refute::Report, cannot use as driver"
            unless $conf->{driver}->isa('Assert::Refute::Report');
    } else {
        $conf->{driver} = 'Assert::Refute::Report'; # this works for sure
    };

    if ($NDEBUG and !$conf->{skip_all}) {
        $conf->{skip_all} = "Assert::Refute turned off via NDEBUG=$NDEBUG";
    };

    if ($conf->{skip_all}) {
        my $default_report = $conf->{driver}->new;
        $default_report->plan( skip_all => $conf->{skip_all} );
        $default_report->done_testing;
        $conf->{skip_all} = $default_report;
    } else {