lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / Test / Mock.pm

package Lire::Test::Mock;

use strict;

use vars qw/%FACTORIES %FACTORY_RESULTS %MOCK_INSTANCES/;

use Class::Inner;
use Devel::Symdump;
use Lire::Utils qw/check_param check_object_param/;
use Carp;

%FACTORIES = ();
%MOCK_INSTANCES = ();
%FACTORY_RESULTS = ();

=pod

=head1 NAME

Lire::Test::Mock - Create mock object

=head1 SYNOPSIS

  use Lire::Report;
  use Lire::Test::Mock;
  use Lire::DlfResult;

  my $mock = new Lire::Test::Mock( 'Lire::Report' );
  $mock->set_result( 'timestamp', $time );
  $mock->timestamp(); # will return $time
  $mock->get_calls(); # [ 'timestamp' ]
  $mock->get_invocation( 'timestamp', 0 ); # [ $mock ]

=head1 DESCRIPTION

This class makes it easy to defined mock objects. Mock objects are
objects which offers the same interface than another object but which
do not share its functionality. This makes it easier to test objects
which requires fixtures which have lots of dependencies.

The mock object can be used to collect information about calls made on
the object. Returns value for such method invocation can also be
specified.

=head2 new( $class, 'method' => $result, 'method' => $result )

Creates a new mock object that will wrap $class. Any other keyword
arguments will be use to initialize the result of methods call. See
set_result() for information on how this works.


=cut

sub new {
    my ( $self, $class, %results ) = @_;

    my $methods = _create_methods( $class );
    $methods->{'new'} = sub { return bless( {},  shift ) };
    $self = new Class::Inner( 'parent' => $class,
                              'methods' => $methods );
    _init_mock( $self, $class, 'new' );

    $self->set_result( %results )
      if %results;

    return $self;
}


=pod

=head2 new_proxy( $class, @constructor_params )

This creates mock object which for the base $class. A proxy mock
object will still monitor calls to the object but the real methods
will be invoked, unless a result was specified using set_result(). Any
remaining parameters will be passed to the new() method which should
be defined in the class.

=head2 new_proxy( $instance )

Makes a Lire::Test::Mock object which is a clone of $instance.

=cut

sub new_proxy {
    my $pkg = shift;
    my $class = shift;

    check_param( $class, 'class' );

    return new_proxy_instance Lire::Test::Mock( $class )
      if ref $class;

    my $args = [ @_ ];
    my $methods = _create_methods( $class );
    my $self = new Class::Inner( 'parent' => $class,
                                 'args' => $args,
                                 'methods' => $methods );
    _init_mock( $self, $class );
    $self->{'_proxy'} = 1;

    return $self;
}

sub new_proxy_instance {
    my ( $pkg, $proto ) = @_;

    check_object_param( $proto, 'proto', 'HASH' );
    my $class = ref $proto;
    my $methods = _create_methods( $class );
    $methods->{'new'} = sub { bless $proto, shift };
    my $self = new Class::Inner( 'parent' => $class,
                                 'methods' => $methods );
    _init_mock( $self, $class );
    $self->{'_proxy'} = 1;

    return $self;
}

=pod

=head2 is_proxy()

Returns whether this mock object will proxy to the real methods
when no results was defined for a specific method.

=cut

sub is_proxy {
    return $_[0]{'_proxy'};
}

sub _init_mock {
    my ( $mock, $class ) = @_;

    $mock->{'_base'} = $class;
    $mock->{'_results'} = {};
    $mock->{'_calls'} = [];
    $mock->{'_invocations'} = {};
    $mock->{'_proxy'} = 0;

    foreach my $name ( list_methods( $class ) ) {
        next if $name eq 'new';
        $mock->{'_invocations'}{$name} = [];
    }

    return;
}

sub _create_methods {
    my $class = $_[0];

    my %methods = ();
    foreach my $name ( list_methods( $class ) ) {
        next if $name eq 'new';
        next if $name eq 'DESTROY';
        $methods{$name} = gen_mock_method( $name );
    }
    $methods{'get_calls'} = \&get_calls;
    $methods{'set_result'} = \&set_result;
    $methods{'get_invocation'} = \&get_invocation;
    $methods{'invocation_count'} = \&invocation_count;
    $methods{'is_proxy'} = \&is_proxy;

    return \%methods;
}

sub gen_mock_method {
    my $name = $_[0];

    return sub { my $self = $_[0];

                 push @{$self->{'_calls'}}, $name;
                 push @{$self->{'_invocations'}{$name}}, [ @_ ];

                 if ( $self->{'_proxy'} &&
                      ! defined $self->{'_results'}{$name} )
                 {
                     my $method = UNIVERSAL::can( $self->{'_base'},
                                                  $name );
                     return $method->( @_ );
                 }
                 return unless exists $self->{'_results'}{$name};

                 my $value = $self->{'_results'}{$name};
                 return $value->( @_ ) if ref $value && ref $value eq 'CODE';
                 return $value;
             };
}

sub list_methods {
    my $class = $_[0];
    check_param( $class, 'class' );

    my @methods = map { $_=~ s/^$class\:://;
                        $_
                    } Devel::Symdump->functions( $class );

    no strict 'refs';
    foreach my $base ( @{"$class\::ISA"} ) {
        push @methods, list_methods( $base );
    }
    my %methods = map { $_ => 1 } @methods;
    return keys %methods
}


=pod

=head2 get_calls()

Returns an array reference containing all the methods called on the
object.

=cut

sub get_calls {
    return [ @{$_[0]{'_calls'}} ];
}

=pod

=head2 invocation_count( $method )

Returns the number of time $method was called.

=cut

sub invocation_count {
    my ( $self, $method ) = @_;

    check_param( $method, 'method' );
    croak "no method '$method' defined in $self->{'_base'}"
      unless exists $self->{'_invocations'}{$method};

    return scalar @{$self->{'_invocations'}{$method}};
}

=pod

=head2 get_invocation( $method, $index )

Returns the parameter that were given when method $method was called.

=cut

sub get_invocation {
    my ( $self, $method, $index ) = @_;

    check_param( $method, 'method' );
    $index ||= 0;

    croak "no method '$method' defined in $self->{'_base'}"
      unless exists $self->{'_invocations'}{$method};

    croak "no invocation $index for method '$method'"
      unless $index < @{$self->{'_invocations'}{$method}};

    return $self->{'_invocations'}{$method}[$index];
}


=pod

=head2 set_result( method => $result, ... )

This assign the result $result to $method. If $result is a code
reference, it will be invoked with the same argument than the method
to compute the result.

=cut

sub set_result {
    my ( $self, %results ) = @_;

    foreach my $method ( keys %results ) {
        croak "no method '$method' defined in $self->{'_base'}"
          unless exists $self->{'_invocations'}{$method};
        $self->{'_results'}{$method} = $results{$method};
    }

    return;
}


=pod

=head1 USING MOCK FACTORIES

Sometime, it is not possible to instatiate a proxy or mock object
during fixture setup. This will usually happen when the object which
we want to track access to is instantiated by the method under test.
In these cases, one can use the set_mock_factory() class method to
change the factory method to one that will return a proxy instance
instead of a real instance. One should call reset_factories() during
tear_down() so that the real factory method become directly accessible
once again.

=head2 set_mock_factory( $class, %results )

Make the new() method of package $class returns proxy Lire::Test::Mock
instance. The created instances will be accessible through the
mock_instances() method. Any other argument will be passed to the
set_result() method when the mock instance is created.

=cut

sub set_mock_factory {
    my ( $pkg, $class, %results ) = @_;

    check_param( $class, 'class' );

    return if exists $FACTORIES{$class};

    my $factory = $class->can( 'new' );
    croak "no new() method in class $class"
      unless $factory;

    no strict 'refs';
    $FACTORIES{$class} = *{"${class}\::new"}{'CODE'};
    $FACTORY_RESULTS{$class} = \%results;
    $MOCK_INSTANCES{$class} = [];
    no warnings 'redefine';
    *{"${class}\::new"} =
      sub { my $self = $factory->( @_ );
            my $mock = new_proxy_instance Lire::Test::Mock( $self );
            $mock->set_result( %{$FACTORY_RESULTS{$class}} );
            push @{$mock->{'_calls'}}, 'new';
            push @{$mock->{'_invocations'}{'new'}}, [ @_ ];
            push @{$MOCK_INSTANCES{$class}}, $mock;
            return $mock;
        };
    return;
}


=pod

=head2 mock_instances( $class )

Returns an array reference containing all the instance that were
created by the installed mock factory in $class. This method will
throw an exception if now mock factory was installed for class $class.

=cut

sub mock_instances {
    my ( $pkg, $class ) = @_;

    check_param( $class, 'class' );

    croak "no mock factory installed for class '$class'"
      unless exists $MOCK_INSTANCES{$class};

    return $MOCK_INSTANCES{$class};
}

=pod

=head2 reset_factories()

Removes all mock factories that were set up using set_mock_factory().

=cut

sub reset_factories {
    my $pkg = $_[0];

    while ( my ( $class, $factory ) = each %FACTORIES ) {
        no strict 'refs';
        no warnings 'redefine';
        if ( $factory ) {
            *{"$class\::new"} = $factory;
        } else {
            delete "$class\::"->{'new'};
        }
    }
    %FACTORIES = ();
    %MOCK_INSTANCES = ();
    %FACTORY_RESULTS = ();

    return;
}


1;

__END__

=pod

=head1 SEE ALSO

Test::Unit::TestCase(3pm)

=head1 VERSION

$Id: Mock.pm,v 1.5 2006/07/23 13:16:32 vanbaal Exp $

=head1 AUTHORS

Francis J. Lacoste <flacoste@logreport.org>

=head1 COPYRIGHT

Copyright (C) 2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program 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
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html. 

=cut