view release on metacpan or  search on metacpan

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

package Assert::Refute::Report;

use 5.006;
use strict;
use warnings;
our $VERSION = '0.1701';

=head1 NAME

Assert::Refute::Report - Contract execution class for Assert::Refute suite

=head1 DESCRIPTION

This class represents one specific application of contract.
It is mutable, but can only changed in one way
(there is no undo of tests and diagnostic messages).
Eventually a C<done_testing> locks it completely, leaving only
L</QUERYING PRIMITIVES> for inspection.

See L<Assert::Refute::Contract> for contract I<definition>.

=head1 SYNOPSIS

    my $c = Assert::Refute::Report->new;
    $c->refute ( $cond, $message );
    $c->refute ( $cond2, $message2 );
    # .......
    $c->done_testing; # no more refute after this

    $c->get_count;    # how many tests were run
    $c->is_passing;   # did any of them fail?
    $c->get_tap;      # return printable summary in familiar format

=cut

# Now this module is the CORE of Assert::Refute.
# There are 3 things for which performance matters:
# 1) new()
# 2) refute( 0, ... )
# 3) done_testing()
# The rest can wait.

use Carp;
use Scalar::Util qw( blessed weaken );

use Assert::Refute::Build qw(to_scalar);

# Always add basic testing primitives to the arsenal
require Assert::Refute::T::Basic;

my $ERROR_DONE = "done_testing was called, no more changes may be added";

=head1 METHODS

=head3 new

    Assert::Refute::Report->new();

No arguments are currently supported.

=cut

# NOTE keep it simple for performance reasons
sub new {
    bless {
        fail   => {},
        count  => 0,
    }, shift;
};

=head2 RUNNING PRIMITIVES

=head3 plan( tests => $n )

Plan to run exactly n tests.
This is not required, and L</done_testing> (see below)
is needed at the end anyway.

=head3 plan( skip_all => $reason )

Plan to run no tests at all.
As of current, this does not prevent any future checks from being run.

In both cases,
dies if there's already a plan, or tests are being run, or done_testing
was seen.

If plan is not fullfilled by the time of C<done_testing> call,
a message indicating plan violation will be added,
and the report will become unconditionally failing.

=cut

my %allow_plan;
$allow_plan{$_}++ for qw( tests skip_all title );

sub plan {
    my $self = shift;
    $self->_croak("Odd number of arguments in plan()")
        if @_ % 2;
    my %args = @_;

    my @extra = grep { !$allow_plan{$_} } keys %args;
    $self->_croak( "Unknown options to plan(): ".join ",", sort @extra )

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

    if (defined $self->{plan_tests}) {
        push @mess, _plan_to_tap( $self->{plan_tests}, $self->{plan_skip} )
            unless $verbosity < 0;
    };

    foreach my $n ( 0 .. $self->{count}, -1 ) {
        # Report test details.
        # Only append the logs for
        #   premature (0) and postmortem (-1) messages
        if ($n > 0) {
            my $reason = $self->{fail}{$n};
            my ($level, $prefix)  = $reason ? (-2, "not ok") : (0, "ok");
            my $name   = $self->{name}{$n} ? "$n - $self->{name}{$n}" : $n;
            push @mess, [ 0, $level, "$prefix $name" ];

            if ($self->{subcontract}{$n}) {
                push @mess, map {
                    [ $_->[0]+1, $_->[1], $_->[2] ];
                } @{ $self->{subcontract}{$n}->get_log( $verbosity ) };
            };

            if (ref $reason eq 'ARRAY') {
                push @mess, map {
                    [ 0, -1, to_scalar( $_ ) ]
                } @$reason;
            } elsif ($reason and $reason ne 1) {
                push @mess, [ 0, -1, to_scalar( $reason ) ];
            };
        };

        # and all following diags
        if (my $rest = $self->{messages}{$n} ) {
            push @mess, grep { $_->[1] <= $verbosity } @$rest;
        };
    };

    if (!defined $self->{plan_tests} and $self->{done}) {
        push @mess, _plan_to_tap( $self->get_count )
            unless $verbosity < 0;
    };

    return \@mess;
};

sub _plan_to_tap {
    my ($n, $skip) = @_;

    my $line = "1..".$n;
    $line .= " # SKIP $skip"
        if defined $skip;
    return [ 0, 0, $line ];
};

=head2 set_parent

    $report->set_parent($bigger_report);
    $report->set_parent(undef);

Indicate that a contract is part of a larger one.
The parent object should be an L<Assert::Refute::Report> instance.
The parent object reference will be weakened to avoid memory leak.

Provide C<undef> as argument to erase parent information.

Returns self, so that calls to set_parent can be chained.

This is used internally by L</subcontract>.

B<NOTE> As of 0.16, no C<isa>/C<DOES> check on the argument is enforced.
It must be blessed, however.
This MAY change in the future.

=cut

sub set_parent {
    my ($self, $parent) = @_;

    if (blessed $parent) {
        $self->{parent} = $parent;
        # avoid a circular loop because $self is likely to be stored
        # in parent as subcontract
        weaken $self->{parent};
    } elsif (!defined $parent) {
        delete $self->{parent};
    } else {
        $self->_croak('parent must be a Report object, not a '.(ref $parent || 'scalar'))
    };
    return $self;
};

=head2 get_parent

Return parent contract, i.e. the contract we are subcontract of, if any.

Always check get_parent to be defined
as it will vanish if parent object goes out of scope.
This is done so to avoid memory leak in subcontract call.

=cut

# Dumb getter
sub get_parent {
    return $_[0]->{parent};
};

=head2 get_depth

Returns 0 is there is no parent, or parent's depth + 1.
This of this as "this contract's indentation level".

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

=cut

sub get_depth {
    my $self = shift;

    if (!exists $self->{depth}) {
        my $parent = $self->get_parent;
        $self->{depth} = $parent ? $parent->get_depth + 1 : 0;
    };

    return $self->{depth};
};

sub _croak {
    my ($self, $mess) = @_;

    $mess ||= "Something terrible happened";
    $mess =~ s/\n+$//s;

    my $fun = (caller 1)[3];
    $fun =~ s/(.*)::/${1}->/;

    croak "$fun(): $mess";
};

=head1 LICENSE AND COPYRIGHT

This module is part of L<Assert::Refute> suite.

Copyright 2017-2018 Konstantin S. Uvarin. C<< <khedin at cpan.org> >>