File Coverage

blib/lib/Mock/Quick/Class.pm

Criterion	Covered	Total	%
statement	160	160	100.0
branch	40	48	83.3
condition	16	21	76.1
subroutine	35	35	100.0
pod	8	12	66.6
total	259	276	93.8

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

use Mock::Quick::Util;
use Scalar::Util qw/blessed weaken/;
use Carp qw/croak confess carp/;

our @CARP_NOT = ('Mock::Quick', 'Mock::Quick::Object');
our $ANON = 'AAAAAAAAAA';

sub package      { shift->{'-package'}  }
sub inc          { shift->{'-inc'}      }
sub is_takeover  { shift->{'-takeover'} }
sub is_implement { shift->{'-implement'}}

sub metrics {
    my $self = shift;
    $self->{'-metrics'} ||= {};
    return $self->{'-metrics'};
}

sub takeover {
    my $class = shift;
    my ( $proto, %params ) = @_;
    my $package = blessed( $proto ) || $proto;

    my $self = bless( { -package => $package, -takeover => 1 }, $class );

    for my $key ( keys %params ) {
        croak "param '$key' is not valid in a takeover"
            if $key =~ m/^-/;
        $self->override( $key => $params{$key} );
    }

    $self->inject_meta();

    return $self;
}

sub implement {
    my $class = shift;
    my ( $package, %params ) = @_;
    my $caller = delete $params{'-caller'} || [caller()];

    my $inc = $package;
    $inc =~ s|::|/|g;
    $inc .= '.pm';

    croak "$package has already been loaded, cannot implement it."
        if $INC{$inc};

    $INC{$inc} = $caller->[1];

    my $self = bless(
        { -package => $package, -implement => 1, -inc => $inc },
        $class
    );

    $self->inject_meta();

    $self->_configure( %params );

    return $self;
}

alt_meth new => (
    obj   => sub { my $self = shift; $self->package->new(@_) },
    class => sub {
        my $class = shift;
        my %params = @_;

        croak "You cannot combine '-takeover' and '-implement' arguments"
            if $params{'-takeover'} && $params{'-implement'};

        return $class->takeover( delete( $params{'-takeover'} ), %params )
            if $params{'-takeover'};

        return $class->implement( delete( $params{'-implement'} ), %params )
            if $params{'-implement'};

        my $package = __PACKAGE__ . "::__ANON__::" . $ANON++;

        my $self = bless( { %params, -package => $package }, $class );

        $self->inject_meta();

        $self->_configure( %params );

        return $self;
    }
);

sub inject_meta {
    my $self = shift;
    my $weak_self = $self;
    weaken $weak_self;
    inject( $self->package, 'MQ_CONTROL', sub { $weak_self } );
}

sub _configure {
    my $self = shift;
    my %params = @_;
    my $package = $self->package;
    my $metrics = $self->metrics;

    for my $key ( keys %params ) {
        my $value = $params{$key};

        if ( $key =~ m/^-/ ) {
            $self->_configure_pair( $key, $value );
        }
        elsif( _is_sub_ref( $value )) {
            inject( $package, $key, sub { $metrics->{$key}++; $value->(@_) });
        }
        else {
            inject( $package, $key, sub { $metrics->{$key}++; $value });
        }
    }
}

sub _configure_pair {
    my $control = shift;
    my ( $param, $value ) = @_;
    my $package = $control->package;
    my $metrics = $control->metrics;

    if ( $param eq '-subclass' ) {
        $value = [ $value ] unless ref $value eq 'ARRAY';
        no strict 'refs';
        push @{"$package\::ISA"} => @$value;
    }
    elsif ( $param eq '-attributes' ) {
        $value = [ $value ] unless ref $value eq 'ARRAY';
        for my $attr ( @$value ) {
            inject( $package, $attr, sub {
                my $self = shift;

                croak "$attr() called on class '$self' instead of an instance"
                    unless blessed( $self );

                $metrics->{$attr}++;
                ( $self->{$attr} ) = @_ if @_;
                return $self->{$attr};
            });
        }
    }
    elsif ( $param eq '-with_new' ) {
        inject( $package, 'new', sub {
            my $class = shift;
            croak "Expected hash, received reference to hash"
                if @_ == 1 and ref $_[0] eq 'HASH';
            my %proto = @_;
            $metrics->{new}++;

            croak "new() cannot be called on an instance"
                if blessed( $class );

            return bless( \%proto, $class );
        });
    }
}

sub _is_sub_ref {
    my $in = shift;
    my $type = ref $in;
    my $class = blessed( $in );

    return 1 if $type && $type eq 'CODE';
    return 1 if $class && $class->isa( 'Mock::Quick::Method' );
    return 0;
}

sub override {
    my $self = shift;
    my $package = $self->package;
    my %pairs = @_;
    my @originals;
    my $metrics = $self->metrics;

    for my $name ( keys %pairs ) {
        my $orig_value = $pairs{$name};

        carp "Overriding non-existent method '$name'"
            if $self->is_takeover && !$package->can($name);

        my $real_value = _is_sub_ref( $orig_value )
            ? sub { $metrics->{$name}++; return $orig_value->(@_) }
            : sub { $metrics->{$name}++; return $orig_value };

        my $original = $self->original( $name );
        inject( $package, $name, $real_value );

        push @originals, $original;
    }

    return @originals;
}

sub original {
    my $self = shift;
    my ( $name ) = @_;
    unless ( exists $self->{$name} ) {
        $self->{$name} = $self->package->can( $name ) || undef;
    }
    return $self->{$name};
}

sub restore {
    my $self = shift;

    for my $name ( @_ ) {
        my $original = $self->original($name);
        delete $self->metrics->{$name};

        if ( $original ) {
            my $sub = _is_sub_ref( $original ) ? $original : sub { $original };
            inject( $self->package, $name, $sub );
        }
        else {
            $self->_clear( $name );
        }
    }
}

sub _clear {
    my $self = shift;
    my ( $name ) = @_;
    my $package = $self->package;
    no strict 'refs';
    my $ref = \%{"$package\::"};
    delete $ref->{ $name };
}

sub undefine {
    my $self = shift;
    my $package = $self->package;
    croak "Refusing to undefine a class that was taken over."
        if $self->is_takeover;
    no strict 'refs';
    undef( *{"$package\::"} );
    delete $INC{$self->inc} if $self->is_implement;
}

sub DESTROY {
    my $self = shift;
    return $self->undefine unless $self->is_takeover;

    my $package = $self->package;

    {
        no strict 'refs';
        no warnings 'redefine';

        my $ref = \%{"$package\::"};
        delete $ref->{MQ_CONTROL};
    }

    for my $sub ( keys %{$self} ) {
        next if $sub =~ m/^-/;
        $self->restore( $sub );
    }
}

purge_util();

1;

__END__