view release on metacpan or  search on metacpan

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

    my @extra = grep { !$new_arg{$_} } keys %opt;
    croak( "Unknown options: @extra" )
        if @extra;

    $opt{need_object}   = $opt{need_object} ? 1 : 0;

    # argument count:
    # * n means exactly n
    # * (n, m) means from n to m
    # * (n, -1) means from n to inf
    my $args = $opt{args};
    $args = [0, -1] unless defined $args; # == 0 is ok
    $args = [ $args, $args ] unless ref $args eq 'ARRAY';
    $args->[1] = 9**9**9 if $args->[1] < 0;
    croak "Meaningless argument limits [$args->[0], $args->[1]]"
        unless $args->[0] <= $args->[1];
    $opt{args} = $args;

    # TODO validate driver
    $opt{driver}    ||= $def_driver;

    bless \%opt, $class;
};

=head2 adjust( %overrides )

Return a copy of this object with some overridden fields.

The name is not perfect, better ideas wanted.

%overrides may include:

=over

=item * driver - the class to perform tests.

=back

=cut

sub adjust {
    my ($self, %opt) = @_;

    my @dont = grep { $opt{$_} } @new_essential;
    croak( "Attempt to override essential parameters @dont" )
        if @dont;

    if (defined $opt{backend}) {
        # TODO 0.20 kill it
        carp( (ref $self)."->adjust: 'backend' is deprecated, use 'driver' instead");
        $opt{driver} = delete $opt{backend};
    };

    return (ref $self)->new( %$self, %opt );
};

=head2 apply( @parameters )

Spawn a new execution log object and run contract against it.

Returns a locked L<Assert::Refute::Report> instance.

=cut

sub apply {
    my ($self, @args) = @_;

    my $c = $self->{driver};
    $c = $c->new unless ref $c;
    # TODO plan tests, argument check etc

    croak "contract->apply: expected from $self->{args}[0] to $self->{args}[1] parameters"
        unless $self->{args}[0] <= @args and @args <= $self->{args}[1];

    unshift @args, $c if $self->{need_object};
    local $Assert::Refute::DRIVER = $c;
    eval {
        $self->{code}->( @args );
        $c->done_testing
            unless $c->is_done;
        1;
    } || do {
        $c->done_testing($@ || "Unexpected end of tests");
    };

    # At this point, done_testing *has* been called unless of course
    #    it is broken and dies, in which case tests will fail.
    return $c;
};

=head1 LICENSE AND COPYRIGHT

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

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

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L<http://www.perlfoundation.org/artistic_license_2_0>

=cut

1; # End of Assert::Refute::Contract