File Coverage

blib/lib/Mock/Quick/Util.pm

Criterion	Covered	Total	%
statement	76	78	97.4
branch	21	24	87.5
condition	14	18	77.7
subroutine	19	19	100.0
pod	0	7	0.0
total	130	146	89.0

package Mock::Quick::Util;
use strict;
use warnings;

use base 'Exporter';
use Scalar::Util qw/blessed/;
use Mock::Quick::Method;
use Carp qw/croak/;

our $CLEAR = 'clear';
our @EXPORT = qw/
    class_meth
    obj_meth
    alt_meth
    call
    param
    inject
    purge_util
    super
/;

sub inject {
    my ( $package, $name, $code ) = @_;
    no warnings 'redefine';
    no strict 'refs';
    *{"$package\::$name"} = $code;
}

sub call {
    my $self = shift;
    require Mock::Quick::Object::Control;
    my $control = Mock::Quick::Object::Control->new( $self );
    my $name = shift;

    my $class = blessed( $self );
    croak "Can't call method on an unblessed reference"
        unless $class;

    if ( $control->strict ) {
        croak "Can't locate object method \"$name\" in this instance"
            unless exists $self->{$name};
    }

    if ( @_ && ref $_[0] && $_[0] == \$CLEAR ) {
        delete $self->{ $name };
        delete $control->metrics->{$name};
        return;
    }

    $control->metrics->{$name}++;

    return $self->{ $name }->( $self, @_ )
        if exists(  $self->{ $name })
        && blessed( $self->{ $name })
        && blessed( $self->{ $name })->isa( 'Mock::Quick::Method' );

    return $self->{$name} = shift(@_)
        if blessed( $_[0] ) && blessed( $_[0] )->isa( 'Mock::Quick::Method' );

    param( $self, $name, @_ );
}

sub param {
    my $self = shift;
    my $name = shift;

    $self->{$name} = shift(@_) if @_;

    # Prevent autovivication
    return unless exists( $self->{ $name });
    return $self->{ $name };
}

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

    my $sub = sub {
        goto &$block unless blessed( $_[0] );
        unshift @_ => ( shift(@_), $name );
        goto &call;
    };

    inject( $caller, $name, $sub );
}

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

    my $sub = sub {
        goto &$block if blessed( $_[0] );
        Carp::croak( "Can't locate object method \"$name\" via package \"$caller\"" );
    };

    inject( $caller, $name, $sub );
}

sub alt_meth {
    my ( $name, %alts ) = @_;
    my $caller = caller;

    croak "You must provide an action for both 'class' and 'obj'"
        unless $alts{class} && $alts{obj};

    my $sub = sub {
        goto &{ $alts{obj }} if blessed( $_[0] );
        goto &{ $alts{ class }};
    };

    inject( $caller, $name, $sub );
}

sub purge_util {
    my $caller = caller;
    for my $sub ( @EXPORT ) {
        no strict 'refs';
        my $ref = \%{"$caller\::"};
        delete $ref->{ $sub };
    }
}

1;

__END__

=head1 NAME

Mock::Quick::Util - Uitls for L<Mock::Quick>.

=head1 AUTHORS

Chad Granum L<[e-mail]>

=head1 COPYRIGHT

Copyright (C) 2011 Chad Granum

Mock-Quick is free software; Standard perl licence.

Mock-Quick is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the license for more details.