view release on metacpan or  search on metacpan

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

=item * C<export> => 1    - add function to @EXPORT
(Exporter still has to be used by target module explicitly).

=item * C<export_ok> => 1 - add function to @EXPORT_OK (don't export by default).

=item * C<no_create> => 1 - don't generate a function at all, just add to
L<Assert::Refute>'s methods.

=item * C<manual> => 1 - don't generate any code.
Instead, assume that user has already done that and just add a method
to L<Assert::Refute::Report> and a prototyped exportable wrapper.

This may be useful to create refutations based on subcontract or such.

B<[EXPERIMENTAL]>.

=item * C<args> => C<nnn> - number of arguments.
This will generate a prototyped function
accepting C<nnn> scalars + optional description.

=item * C<list> => 1 - create a list prototype instead.
Mutually exclusive with C<args>.

=item * C<block> => 1 - create a block function.

=item * C<no_proto> => 1 - skip prototype, function will have to be called
with parentheses.

=back

The name must not start with C<set_>, C<get_>, or C<do_>.
Also colliding with a previously defined name would case an exception.

=cut

my %Backend;
my %Carp_not;
my $trash_can = __PACKAGE__."::generated::For::Cover::To::See";
my %known;
$known{$_}++ for qw(args list block no_proto manual
    export export_ok no_create);

sub build_refute(@) { ## no critic # Moose-like DSL for the win!
    my ($name, $cond, %opt) = @_;

    my $class = "Assert::Refute::Report";

    if ($name =~ /^(get_|set_|do_)/) {
        croak "build_refute(): fucntion name shall not start with get_, set_, or do_";
    };
    if (my $backend = ( $class->can($name) && ($Backend{$name} || $class )) ) {
        croak "build_refute(): '$name' already registered by $backend";
    };
    my @extra = grep { !$known{$_} } keys %opt;
    croak "build_refute(): unknown options: @extra"
        if @extra;
    croak "build_refute(): list and args options are mutually exclusive"
        if $opt{list} and defined $opt{args};

    my @caller = caller(0);
    my $target = $opt{target} || $caller[0];

    confess "Too bad (@caller)" if !$target or $target eq __PACKAGE__;

    my $nargs = $opt{args} || 0;
    $nargs = 9**9**9 if $opt{list};

    $nargs++ if $opt{block};

    # TODO Add executability check if $block
    my $method  = $opt{manual} ? $cond : sub {
        my $self = shift;
        my $message; $message = pop unless @_ <= $nargs;

        return $self->refute( scalar $cond->(@_), $message );
    };
    my $wrapper = $opt{manual} ? sub {
        return $cond->( $Assert::Refute::DRIVER || current_contract(), @_ );
    } : sub {
        my $message; $message = pop unless @_ <= $nargs;
        return (
            # Ugly hack for speed in happy case
            $Assert::Refute::DRIVER || current_contract()
        )->refute( scalar $cond->(@_), $message );
    };
    if (!$opt{no_proto} and ($opt{block} || $opt{list} || defined $opt{args})) {
        my $proto = $opt{list} ? '@' : '$' x ($opt{args} || 0);
        $proto = "&$proto" if $opt{block};
        $proto .= ';$' unless $opt{list};

        # '&' for set_proto to work on a scalar, not {CODE;}
        &set_prototype( $wrapper, $proto );
    };

    $Backend{$name}   = "$target at $caller[1] line $caller[2]"; # just for the record
    my $todo_carp_not = !$Carp_not{ $target }++;
    my $todo_create   = !$opt{no_create};
    my $export        = $opt{export} ? "EXPORT" : $opt{export_ok} ? "EXPORT_OK" : "";

    # Magic below, beware!
    no strict 'refs'; ## no critic # really need magic here

    # set up method for OO interface
    *{ $class."::$name" } = $method;

    # FIXME UGLY HACK - somehow it makes Devel::Cover see the code in report
    *{ $trash_can."::$name" } = $cond;

    if ($todo_create) {
        *{ $target."::$name" } = $wrapper;
        push @{ $target."::".$export }, $name
            if $export;
    };
    if ($todo_carp_not) {
        no warnings 'once';
        push @{ $target."::CARP_NOT" }, "Assert::Refute::Contract", $class;
    };

    # magic ends here