File Coverage

blib/lib/Mock/Quick/Object.pm

Criterion	Covered	Total	%
statement	40	42	95.2
branch	3	4	75.0
condition			n/a
subroutine	13	15	86.6
pod	0	3	0.0
total	56	64	87.5

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

use Mock::Quick::Util;
use Mock::Quick::Object::Control;
use Carp ();
use Scalar::Util ();

our $AUTOLOAD;

class_meth new => sub {
    my $class = shift;
    my %proto = @_;
    return bless \%proto, $class;
};

sub AUTOLOAD {
    # Do not shift this, we need it when we use goto &$sub
    my ($self) = @_;
    my ( $package, $sub ) = ( $AUTOLOAD =~ m/^(.+)::([^:]+)$/ );
    $AUTOLOAD = undef;

    Carp::croak "Can't locate object method \"$sub\" via package \"$package\""
        unless Scalar::Util::blessed( $self );

    my $code = $self->can( $sub );
    Carp::croak "Can't locate object method \"$sub\" in this instance"
        unless $code;

    goto &$code;
};

alt_meth can => (
    class => sub { no warnings 'misc'; goto &UNIVERSAL::can },
    obj => sub {
        my ( $self, $name ) = @_;

        my $control = Mock::Quick::Object::Control->new( $self );
        return if $control->strict && !exists $self->{$name};

        my $sub;
        {
            no warnings 'misc';
            $sub = UNIVERSAL::can( $self, $name );
        }
        $sub ||= sub {
            unshift @_ => ( shift( @_ ), $name );
            goto &call;
        };
        inject( Scalar::Util::blessed( $self ), $name, $sub );
        return $sub;
    },
);

# http://perldoc.perl.org/perlobj.html#Default-UNIVERSAL-methods
# DOES is equivalent to isa by default
sub isa     { no warnings 'misc'; goto &UNIVERSAL::isa     }
sub DOES    { goto &isa                                    }
sub VERSION { no warnings 'misc'; goto &UNIVERSAL::VERSION }

obj_meth DESTROY => sub {
    my $self = shift;
    Mock::Quick::Object::Control->new( $self )->_clean;
    unshift @_ => ( $self, 'DESTROY' );
    goto &call;
};

purge_util();

1;

__END__

=head1 NAME

Mock::Quick::Object - Object mocking for Mock::Quick

=head1 DESCRIPTION

Provides object mocking. See L<Mock::Quick> for a better interface.

=head1 SYNOPSIS

    use Mock::Quick::Object;
    use Mock::Quick::Method;

    my $obj = Mock::Quick::Object->new(
        foo => 'bar',            # define attribute
        do_it => qmeth { ... },  # define method
        ...
    );

    is( $obj->foo, 'bar' );
    $obj->foo( 'baz' );
    is( $obj->foo, 'baz' );

    $obj->do_it();

    # define the new attribute automatically
    $obj->bar( 'xxx' );

    # define a new method on the fly
    $obj->baz( Mock::Quick::Method->new( sub { ... });

    # remove an attribute or method
    $obj->baz( \$Mock::Quick::Util::CLEAR );

=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.