Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Merge branch 'metrics'

  • Loading branch information...
commit a004c68c1d249f1f73d71bf3a0bf762021e3c1f2 2 parents eb3bc9a + 013f513
Chad Granum authored April 02, 2011
9  lib/Mock/Quick.pm
@@ -283,6 +283,15 @@ You can also do this through qclass():
283 283
         %overrides
284 284
     );
285 285
 
  286
+=head1 METRICS
  287
+
  288
+All control objects have a 'metrics' method. The metrics method returns a hash
  289
+where keys are method names, and values are the number of times the method has
  290
+been called. When a method is altered or removed the key is deleted.
  291
+
  292
+Metrics only apply to mocked methods. When you takeover an already loaded class
  293
+metrics will only track overriden methods.
  294
+
286 295
 =head1 EXPORTS
287 296
 
288 297
 Mock-Quick uses L<Exporter::Declare>. This allows for exports to be prefixed or renamed.
73  lib/Mock/Quick/Class.pm
@@ -4,7 +4,7 @@ use warnings;
4 4
 
5 5
 use Mock::Quick::Util;
6 6
 use Scalar::Util qw/blessed/;
7  
-use Carp qw/croak/;
  7
+use Carp qw/croak confess/;
8 8
 
9 9
 our $ANON = 'AAAAAAAAAA';
10 10
 
@@ -13,6 +13,12 @@ sub inc          { shift->{'-inc'}      }
13 13
 sub is_takeover  { shift->{'-takeover'} }
14 14
 sub is_implement { shift->{'-implement'}}
15 15
 
  16
+sub metrics {
  17
+    my $self = shift;
  18
+    $self->{'-metrics'} ||= {};
  19
+    return $self->{'-metrics'};
  20
+}
  21
+
16 22
 sub takeover {
17 23
     my $class = shift;
18 24
     my ( $package, %params ) = @_;
@@ -81,6 +87,7 @@ sub _configure {
81 87
     my $self = shift;
82 88
     my %params = @_;
83 89
     my $package = $self->package;
  90
+    my $metrics = $self->metrics;
84 91
 
85 92
     for my $key ( keys %params ) {
86 93
         my $value = $params{$key};
@@ -89,18 +96,19 @@ sub _configure {
89 96
             $self->_configure_pair( $key, $value );
90 97
         }
91 98
         elsif( _is_sub_ref( $value )) {
92  
-            inject( $package, $key, $value );
  99
+            inject( $package, $key, sub { $metrics->{$key}++; $value->() });
93 100
         }
94 101
         else {
95  
-            inject( $package, $key, sub { $value });
  102
+            inject( $package, $key, sub { $metrics->{$key}++; $value });
96 103
         }
97 104
     }
98 105
 }
99 106
 
100 107
 sub _configure_pair {
101  
-    my $self = shift;
  108
+    my $control = shift;
102 109
     my ( $param, $value ) = @_;
103  
-    my $package = $self->package;
  110
+    my $package = $control->package;
  111
+    my $metrics = $control->metrics;
104 112
 
105 113
     if ( $param eq '-subclass' ) {
106 114
         $value = [ $value ] unless ref $value eq 'ARRAY';
@@ -112,8 +120,11 @@ sub _configure_pair {
112 120
         for my $attr ( @$value ) {
113 121
             inject( $package, $attr, sub {
114 122
                 my $self = shift;
115  
-                croak "$attr() called on '$self' instead of an instance"
  123
+
  124
+                croak "$attr() called on class '$self' instead of an instance"
116 125
                     unless blessed( $self );
  126
+
  127
+                $metrics->{$attr}++;
117 128
                 ( $self->{$attr} ) = @_ if @_;
118 129
                 return $self->{$attr};
119 130
             });
@@ -122,9 +133,12 @@ sub _configure_pair {
122 133
     elsif ( $param eq '-with_new' ) {
123 134
         inject( $package, 'new', sub {
124 135
             my $class = shift;
  136
+            my %proto = @_;
  137
+            $metrics->{new}++;
  138
+
125 139
             croak "new() cannot be called on an instance"
126 140
                 if blessed( $class );
127  
-            my %proto = @_;
  141
+
128 142
             return bless( \%proto, $class );
129 143
         });
130 144
     }
@@ -145,13 +159,14 @@ sub override {
145 159
     my $package = $self->package;
146 160
     my %pairs = @_;
147 161
     my @originals;
  162
+    my $metrics = $self->metrics;
148 163
 
149 164
     for my $name ( keys %pairs ) {
150 165
         my $orig_value = $pairs{$name};
151 166
 
152 167
         my $real_value = _is_sub_ref( $orig_value )
153  
-            ? $orig_value
154  
-            : sub { $orig_value };
  168
+            ? sub { $metrics->{$name}++; return $orig_value->() }
  169
+            : sub { $metrics->{$name}++; return $orig_value };
155 170
 
156 171
         my $original = $package->can( $name );
157 172
         $self->{$name} ||= $original;
@@ -168,6 +183,7 @@ sub restore {
168 183
 
169 184
     for my $name ( @_ ) {
170 185
         my $original = $self->{$name};
  186
+        delete $self->metrics->{$name};
171 187
 
172 188
         if ( $original ) {
173 189
             my $sub = _is_sub_ref( $original ) ? $original : sub { $original };
@@ -200,7 +216,8 @@ sub undefine {
200 216
 
201 217
 sub DESTROY {
202 218
     my $self = shift;
203  
-    return unless $self->is_takeover;
  219
+    return $self->undefine unless $self->is_takeover;
  220
+
204 221
     for my $sub ( keys %{$self} ) {
205 222
         next if $sub =~ m/^-/;
206 223
         $self->restore( $sub );
@@ -338,6 +355,42 @@ You can also do this through new()
338 355
         %overrides
339 356
     );
340 357
 
  358
+=head1 METHODS
  359
+
  360
+=over 4
  361
+
  362
+=item $package = $obj->package()
  363
+
  364
+Get the name of the package controlled by this object.
  365
+
  366
+=item $bool = $obj->is_takeover()
  367
+
  368
+Check if the control object was created to takeover an existing class.
  369
+
  370
+=item $bool = $obj->is_implement()
  371
+
  372
+Check if the control object was created to implement a class.
  373
+
  374
+=item $data = $obj->metrics()
  375
+
  376
+Returns a hash where keys are method names, and values are the number of times
  377
+the method has been called. When a method is altered or removed the key is
  378
+deleted.
  379
+
  380
+=item $obj->override( name => sub { ... })
  381
+
  382
+Override a method.
  383
+
  384
+=item $obj->restore( $name )
  385
+
  386
+Restore a method (Resets metrics)
  387
+
  388
+=item $obj->undefine()
  389
+
  390
+Undefine the package controlled by the control.
  391
+
  392
+=back
  393
+
341 394
 =head1 AUTHORS
342 395
 
343 396
 =over 4
15  lib/Mock/Quick/Object/Control.pm
@@ -34,7 +34,8 @@ sub set_attributes {
34 34
 sub clear {
35 35
     my $self = shift;
36 36
     for my $field ( @_ ) {
37  
-        delete $self->target->{ $field };
  37
+        delete $self->target->{$field};
  38
+        delete $self->metrics->{$field};
38 39
     }
39 40
 }
40 41
 
@@ -44,6 +45,12 @@ sub strict {
44 45
     return $META{$self->target}->{strict};
45 46
 }
46 47
 
  48
+sub metrics {
  49
+    my $self = shift;
  50
+    $META{$self->target}->{metrics} ||= {};
  51
+    return $META{$self->target}->{metrics};
  52
+}
  53
+
47 54
 sub _clean {
48 55
     my $self = shift;
49 56
     delete $META{$self->target};
@@ -96,6 +103,12 @@ Remove attributes/methods.
96 103
 
97 104
 Enable/Disable strict mode.
98 105
 
  106
+=item $data = $control->metrics()
  107
+
  108
+Returns a hash where keys are method names, and values are the number of times
  109
+the method has been called. When a method is altered or removed the key is
  110
+deleted.
  111
+
99 112
 =back
100 113
 
101 114
 =head1 AUTHORS
3  lib/Mock/Quick/Util.pm
@@ -43,9 +43,12 @@ sub call {
43 43
 
44 44
     if ( @_ && ref $_[0] && $_[0] == \$CLEAR ) {
45 45
         delete $self->{ $name };
  46
+        delete $control->metrics->{$name};
46 47
         return;
47 48
     }
48 49
 
  50
+    $control->metrics->{$name}++;
  51
+
49 52
     return $self->{ $name }->( $self, @_ )
50 53
         if exists(  $self->{ $name })
51 54
         && blessed( $self->{ $name })
4  t/Class.t
@@ -105,11 +105,13 @@ tests implement => sub {
105 105
     can_ok( 'Foox', 'new' );
106 106
     $obj->undefine();
107 107
     throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/,  "try to load Foox";
  108
+    $obj = undef;
108 109
 
109 110
     $obj = $CLASS->new( -implement => 'Foox', a => sub { 'a' }, -with_new => 1 );
110 111
     lives_ok { require Foox; 1 } "Did not try to load Foox";
111 112
     can_ok( 'Foox', 'new' );
112  
-    $obj->undefine();
  113
+    ok( $obj, "Keeping it in scope." );
  114
+    $obj = undef;
113 115
     throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/,  "try to load Foox";
114 116
 };
115 117
 
57  t/metrics.t
... ...
@@ -0,0 +1,57 @@
  1
+#!/usr/bin/perl
  2
+use strict;
  3
+use warnings;
  4
+
  5
+use Test::More;
  6
+use Fennec::Lite;
  7
+use Mock::Quick;
  8
+
  9
+our $CLASS;
  10
+
  11
+BEGIN {
  12
+    $CLASS = 'Mock::Quick::Class';
  13
+    use_ok( $CLASS );
  14
+
  15
+    package Foo;
  16
+
  17
+    sub foo { 'foo' }
  18
+    sub bar { 'bar' }
  19
+    sub baz { 'baz' }
  20
+
  21
+    1;
  22
+}
  23
+
  24
+tests object => sub {
  25
+    my ($one, $control) = qobj( foo => 'bar', baz => qmeth { 'baz' });
  26
+    $one->foo for 1 .. 4;
  27
+    $one->baz for 1 .. 10;
  28
+
  29
+    is_deeply( $control->metrics, { foo => 4, baz => 10 }, "Kept metrics" );
  30
+
  31
+    $control->clear( 'foo' );
  32
+    is_deeply( $control->metrics, { baz => 10 }, "Call count clears with method" );
  33
+
  34
+    $one->baz( qclear() );
  35
+    is_deeply( $control->metrics, {}, "Call count clears with method" );
  36
+
  37
+    $control->set_methods( foo => sub { 'foo' });
  38
+    $one->foo();
  39
+    is_deeply( $control->metrics, { foo => 1 }, "Kept metrics" );
  40
+};
  41
+
  42
+tests class => sub {
  43
+    my $class = qclass( -with_new => 1, foo => sub { 'bar' });
  44
+    my $one = $class->new();
  45
+    $one->foo() for 1 .. 4;
  46
+
  47
+    $class->override( bar => 'baz' );
  48
+    $one->bar() for 1 .. 6;
  49
+
  50
+    is_deeply( $class->metrics, { new => 1, foo => 4, bar => 6 }, "metrics" );
  51
+
  52
+    $class->restore( 'foo' );
  53
+    is_deeply( $class->metrics, { new => 1, bar => 6 }, "metrics with restored method" );
  54
+};
  55
+
  56
+run_tests;
  57
+done_testing;

0 notes on commit a004c68

Please sign in to comment.
Something went wrong with that request. Please try again.