Permalink
Browse files

Merge branch 'metrics'

  • Loading branch information...
2 parents eb3bc9a + 013f513 commit a004c68c1d249f1f73d71bf3a0bf762021e3c1f2 @exodist committed Apr 3, 2011
Showing with 149 additions and 12 deletions.
  1. +9 −0 lib/Mock/Quick.pm
  2. +63 −10 lib/Mock/Quick/Class.pm
  3. +14 −1 lib/Mock/Quick/Object/Control.pm
  4. +3 −0 lib/Mock/Quick/Util.pm
  5. +3 −1 t/Class.t
  6. +57 −0 t/metrics.t
View
@@ -283,6 +283,15 @@ You can also do this through qclass():
%overrides
);
+=head1 METRICS
+
+All control objects have a 'metrics' method. The metrics method returns a hash
+where keys are method names, and values are the number of times the method has
+been called. When a method is altered or removed the key is deleted.
+
+Metrics only apply to mocked methods. When you takeover an already loaded class
+metrics will only track overriden methods.
+
=head1 EXPORTS
Mock-Quick uses L<Exporter::Declare>. This allows for exports to be prefixed or renamed.
View
@@ -4,7 +4,7 @@ use warnings;
use Mock::Quick::Util;
use Scalar::Util qw/blessed/;
-use Carp qw/croak/;
+use Carp qw/croak confess/;
our $ANON = 'AAAAAAAAAA';
@@ -13,6 +13,12 @@ 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 ( $package, %params ) = @_;
@@ -81,6 +87,7 @@ sub _configure {
my $self = shift;
my %params = @_;
my $package = $self->package;
+ my $metrics = $self->metrics;
for my $key ( keys %params ) {
my $value = $params{$key};
@@ -89,18 +96,19 @@ sub _configure {
$self->_configure_pair( $key, $value );
}
elsif( _is_sub_ref( $value )) {
- inject( $package, $key, $value );
+ inject( $package, $key, sub { $metrics->{$key}++; $value->() });
}
else {
- inject( $package, $key, sub { $value });
+ inject( $package, $key, sub { $metrics->{$key}++; $value });
}
}
}
sub _configure_pair {
- my $self = shift;
+ my $control = shift;
my ( $param, $value ) = @_;
- my $package = $self->package;
+ my $package = $control->package;
+ my $metrics = $control->metrics;
if ( $param eq '-subclass' ) {
$value = [ $value ] unless ref $value eq 'ARRAY';
@@ -112,8 +120,11 @@ sub _configure_pair {
for my $attr ( @$value ) {
inject( $package, $attr, sub {
my $self = shift;
- croak "$attr() called on '$self' instead of an instance"
+
+ croak "$attr() called on class '$self' instead of an instance"
unless blessed( $self );
+
+ $metrics->{$attr}++;
( $self->{$attr} ) = @_ if @_;
return $self->{$attr};
});
@@ -122,9 +133,12 @@ sub _configure_pair {
elsif ( $param eq '-with_new' ) {
inject( $package, 'new', sub {
my $class = shift;
+ my %proto = @_;
+ $metrics->{new}++;
+
croak "new() cannot be called on an instance"
if blessed( $class );
- my %proto = @_;
+
return bless( \%proto, $class );
});
}
@@ -145,13 +159,14 @@ sub override {
my $package = $self->package;
my %pairs = @_;
my @originals;
+ my $metrics = $self->metrics;
for my $name ( keys %pairs ) {
my $orig_value = $pairs{$name};
my $real_value = _is_sub_ref( $orig_value )
- ? $orig_value
- : sub { $orig_value };
+ ? sub { $metrics->{$name}++; return $orig_value->() }
+ : sub { $metrics->{$name}++; return $orig_value };
my $original = $package->can( $name );
$self->{$name} ||= $original;
@@ -168,6 +183,7 @@ sub restore {
for my $name ( @_ ) {
my $original = $self->{$name};
+ delete $self->metrics->{$name};
if ( $original ) {
my $sub = _is_sub_ref( $original ) ? $original : sub { $original };
@@ -200,7 +216,8 @@ sub undefine {
sub DESTROY {
my $self = shift;
- return unless $self->is_takeover;
+ return $self->undefine unless $self->is_takeover;
+
for my $sub ( keys %{$self} ) {
next if $sub =~ m/^-/;
$self->restore( $sub );
@@ -338,6 +355,42 @@ You can also do this through new()
%overrides
);
+=head1 METHODS
+
+=over 4
+
+=item $package = $obj->package()
+
+Get the name of the package controlled by this object.
+
+=item $bool = $obj->is_takeover()
+
+Check if the control object was created to takeover an existing class.
+
+=item $bool = $obj->is_implement()
+
+Check if the control object was created to implement a class.
+
+=item $data = $obj->metrics()
+
+Returns a hash where keys are method names, and values are the number of times
+the method has been called. When a method is altered or removed the key is
+deleted.
+
+=item $obj->override( name => sub { ... })
+
+Override a method.
+
+=item $obj->restore( $name )
+
+Restore a method (Resets metrics)
+
+=item $obj->undefine()
+
+Undefine the package controlled by the control.
+
+=back
+
=head1 AUTHORS
=over 4
@@ -34,7 +34,8 @@ sub set_attributes {
sub clear {
my $self = shift;
for my $field ( @_ ) {
- delete $self->target->{ $field };
+ delete $self->target->{$field};
+ delete $self->metrics->{$field};
}
}
@@ -44,6 +45,12 @@ sub strict {
return $META{$self->target}->{strict};
}
+sub metrics {
+ my $self = shift;
+ $META{$self->target}->{metrics} ||= {};
+ return $META{$self->target}->{metrics};
+}
+
sub _clean {
my $self = shift;
delete $META{$self->target};
@@ -96,6 +103,12 @@ Remove attributes/methods.
Enable/Disable strict mode.
+=item $data = $control->metrics()
+
+Returns a hash where keys are method names, and values are the number of times
+the method has been called. When a method is altered or removed the key is
+deleted.
+
=back
=head1 AUTHORS
View
@@ -43,9 +43,12 @@ sub call {
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 })
View
@@ -105,11 +105,13 @@ tests implement => sub {
can_ok( 'Foox', 'new' );
$obj->undefine();
throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/, "try to load Foox";
+ $obj = undef;
$obj = $CLASS->new( -implement => 'Foox', a => sub { 'a' }, -with_new => 1 );
lives_ok { require Foox; 1 } "Did not try to load Foox";
can_ok( 'Foox', 'new' );
- $obj->undefine();
+ ok( $obj, "Keeping it in scope." );
+ $obj = undef;
throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/, "try to load Foox";
};
View
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+use Fennec::Lite;
+use Mock::Quick;
+
+our $CLASS;
+
+BEGIN {
+ $CLASS = 'Mock::Quick::Class';
+ use_ok( $CLASS );
+
+ package Foo;
+
+ sub foo { 'foo' }
+ sub bar { 'bar' }
+ sub baz { 'baz' }
+
+ 1;
+}
+
+tests object => sub {
+ my ($one, $control) = qobj( foo => 'bar', baz => qmeth { 'baz' });
+ $one->foo for 1 .. 4;
+ $one->baz for 1 .. 10;
+
+ is_deeply( $control->metrics, { foo => 4, baz => 10 }, "Kept metrics" );
+
+ $control->clear( 'foo' );
+ is_deeply( $control->metrics, { baz => 10 }, "Call count clears with method" );
+
+ $one->baz( qclear() );
+ is_deeply( $control->metrics, {}, "Call count clears with method" );
+
+ $control->set_methods( foo => sub { 'foo' });
+ $one->foo();
+ is_deeply( $control->metrics, { foo => 1 }, "Kept metrics" );
+};
+
+tests class => sub {
+ my $class = qclass( -with_new => 1, foo => sub { 'bar' });
+ my $one = $class->new();
+ $one->foo() for 1 .. 4;
+
+ $class->override( bar => 'baz' );
+ $one->bar() for 1 .. 6;
+
+ is_deeply( $class->metrics, { new => 1, foo => 4, bar => 6 }, "metrics" );
+
+ $class->restore( 'foo' );
+ is_deeply( $class->metrics, { new => 1, bar => 6 }, "metrics with restored method" );
+};
+
+run_tests;
+done_testing;

0 comments on commit a004c68

Please sign in to comment.