Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Merge branch 'ReplacementMocking'

  • Loading branch information...
commit eeb37664b4bc8917527ac42a07bba07a0650fde1 2 parents 757f2ec + b53aad9
Chad Granum authored April 02, 2011
169  lib/Mock/Quick/Class.pm
@@ -8,12 +8,48 @@ use Carp qw/croak/;
8 8
 
9 9
 our $ANON = 'AAAAAAAAAA';
10 10
 
11  
-sub package { shift->{'-package'}}
  11
+sub package      { shift->{'-package'}  }
  12
+sub inc          { shift->{'-inc'}      }
  13
+sub is_takeover  { shift->{'-takeover'} }
  14
+sub is_implement { shift->{'-implement'}}
12 15
 
13 16
 sub takeover {
14 17
     my $class = shift;
15  
-    my ( $package ) = @_;
16  
-    return bless( { -package => $package, -takeover => 1 }, $class );
  18
+    my ( $package, %params ) = @_;
  19
+
  20
+    my $self = bless( { -package => $package, -takeover => 1 }, $class );
  21
+
  22
+    for my $key ( keys %params ) {
  23
+        croak "param '$key' is not valid in a takeover"
  24
+            if $key =~ m/^-/;
  25
+        $self->override( $key => $params{$key} );
  26
+    }
  27
+
  28
+    return $self;
  29
+}
  30
+
  31
+sub implement {
  32
+    my $class = shift;
  33
+    my ( $package, %params ) = @_;
  34
+    my $caller = delete $params{'-caller'} || [caller()];
  35
+
  36
+    my $inc = $package;
  37
+    $inc =~ s|::|/|g;
  38
+    $inc .= '.pm';
  39
+
  40
+    croak "$package has already been loaded, cannot implement it."
  41
+        if $INC{$inc};
  42
+
  43
+    $INC{$inc} = $caller->[1];
  44
+
  45
+    my $self = bless(
  46
+        { -package => $package, -implement => 1, -inc => $inc },
  47
+        $class
  48
+    );
  49
+
  50
+    $self->_configure( %params );
  51
+
  52
+    return $self;
17 53
 }
18 54
 
19 55
 alt_meth new => (
@@ -21,29 +57,47 @@ alt_meth new => (
21 57
     class => sub {
22 58
         my $class = shift;
23 59
         my %params = @_;
  60
+
  61
+        croak "You cannot combine '-takeover' and '-implement' arguments"
  62
+            if $params{'-takeover'} && $params{'-implement'};
  63
+
  64
+        return $class->takeover( delete( $params{'-takeover'} ), %params )
  65
+            if $params{'-takeover'};
  66
+
  67
+        return $class->implement( delete( $params{'-implement'} ), %params )
  68
+            if $params{'-implement'};
  69
+
24 70
         my $package = __PACKAGE__ . "::__ANON__::" . $ANON++;
25 71
 
26 72
         my $self = bless( { %params, -package => $package }, $class );
27 73
 
28  
-        for my $key ( keys %params ) {
29  
-            my $value = $params{$key};
30  
-
31  
-            if ( $key =~ m/^-/ ) {
32  
-                $self->configure( $key, $value );
33  
-            }
34  
-            elsif( _is_sub_ref( $value )) {
35  
-                inject( $package, $key, $value );
36  
-            }
37  
-            else {
38  
-                inject( $package, $key, sub { $value });
39  
-            }
40  
-        }
  74
+        $self->_configure( %params );
41 75
 
42 76
         return $self;
43 77
     }
44 78
 );
45 79
 
46  
-sub configure {
  80
+sub _configure {
  81
+    my $self = shift;
  82
+    my %params = @_;
  83
+    my $package = $self->package;
  84
+
  85
+    for my $key ( keys %params ) {
  86
+        my $value = $params{$key};
  87
+
  88
+        if ( $key =~ m/^-/ ) {
  89
+            $self->_configure_pair( $key, $value );
  90
+        }
  91
+        elsif( _is_sub_ref( $value )) {
  92
+            inject( $package, $key, $value );
  93
+        }
  94
+        else {
  95
+            inject( $package, $key, sub { $value });
  96
+        }
  97
+    }
  98
+}
  99
+
  100
+sub _configure_pair {
47 101
     my $self = shift;
48 102
     my ( $param, $value ) = @_;
49 103
     my $package = $self->package;
@@ -120,12 +174,12 @@ sub restore {
120 174
             inject( $self->package, $name, $sub );
121 175
         }
122 176
         else {
123  
-            $self->clear( $name );
  177
+            $self->_clear( $name );
124 178
         }
125 179
     }
126 180
 }
127 181
 
128  
-sub clear {
  182
+sub _clear {
129 183
     my $self = shift;
130 184
     my ( $name ) = @_;
131 185
     my $package = $self->package;
@@ -138,14 +192,15 @@ sub undefine {
138 192
     my $self = shift;
139 193
     my $package = $self->package;
140 194
     croak "Refusing to undefine a class that was taken over."
141  
-        if $self->{'-takeover'};
  195
+        if $self->is_takeover;
142 196
     no strict 'refs';
143 197
     undef( *{"$package\::"} );
  198
+    delete $INC{$self->inc} if $self->is_implement;
144 199
 }
145 200
 
146 201
 sub DESTROY {
147 202
     my $self = shift;
148  
-    return unless $self->{'-takeover'};
  203
+    return unless $self->is_takeover;
149 204
     for my $sub ( keys %{$self} ) {
150 205
         next if $sub =~ m/^-/;
151 206
         $self->restore( $sub );
@@ -168,7 +223,63 @@ Provides class mocking for L<Mock::Quick>
168 223
 
169 224
 =head1 SYNOPSIS
170 225
 
171  
-=head2 MOCKING CLASSES
  226
+=head2 IMPLEMENT A CLASS
  227
+
  228
+This will implement a class at the namespace provided via the -implement
  229
+argument. The class must not already be loaded. Once complete the real class
  230
+will be prevented from loading until you call undefine() on the control object.
  231
+
  232
+    use Mock::Quick::Class;
  233
+
  234
+    my $control = Mock::Quick::Class->new(
  235
+        -implement => 'My::Package',
  236
+
  237
+        # Insert a generic new() method (blessed hash)
  238
+        -with_new => 1,
  239
+
  240
+        # Inheritance
  241
+        -subclass => 'Some::Class',
  242
+        # Can also do
  243
+        -subclass => [ 'Class::A', 'Class::B' ],
  244
+
  245
+        # generic get/set attribute methods.
  246
+        -attributes => [ qw/a b c d/ ],
  247
+
  248
+        # Method that simply returns a value.
  249
+        simple => 'value',
  250
+
  251
+        # Custom method.
  252
+        method => sub { ... },
  253
+    );
  254
+
  255
+    my $obj = $control->package->new;
  256
+    # OR
  257
+    my $obj = My::Package->new;
  258
+
  259
+    # Override a method
  260
+    $control->override( foo => sub { ... });
  261
+
  262
+    # Restore it to the original
  263
+    $control->restore( 'foo' );
  264
+
  265
+    # Remove the namespace we created, which would allow the real thing to load
  266
+    # in a require or use statement.
  267
+    $control->undefine();
  268
+
  269
+You can also use the 'implement' method instead of new:
  270
+
  271
+    use Mock::Quick::Class;
  272
+
  273
+    my $control = Mock::Quick::Class->implement(
  274
+        'Some::Package',
  275
+        %args
  276
+    );
  277
+
  278
+=head2 ANONYMOUS MOCKED CLASS
  279
+
  280
+This is if you just need to generate a class where the package name does not
  281
+matter. This is done when the -takeover and -implement arguments are both
  282
+ommited.
172 283
 
173 284
     use Mock::Quick::Class;
174 285
 
@@ -202,7 +313,7 @@ Provides class mocking for L<Mock::Quick>
202 313
     # Remove the anonymous namespace we created.
203 314
     $control->undefine();
204 315
 
205  
-=head2 TAKING OVER EXISTING CLASSES
  316
+=head2 TAKING OVER EXISTING/LOADED CLASSES
206 317
 
207 318
     use Mock::Quick::Class;
208 319
 
@@ -214,9 +325,19 @@ Provides class mocking for L<Mock::Quick>
214 325
     # Restore it to the original
215 326
     $control->restore( 'foo' );
216 327
 
217  
-    # Destroy the control object and completely restore the original class Some::Package.
  328
+    # Destroy the control object and completely restore the original class
  329
+    # Some::Package.
218 330
     $control = undef;
219 331
 
  332
+You can also do this through new()
  333
+
  334
+    use Mock::Quick::Class;
  335
+
  336
+    my $control = Mock::Quick::Class->new(
  337
+        -takeover => 'Some::Package',
  338
+        %overrides
  339
+    );
  340
+
220 341
 =head1 AUTHORS
221 342
 
222 343
 =over 4
16  t/Class.t
@@ -91,7 +91,7 @@ tests takeover => sub {
91 91
     $obj->restore( 'foo' );
92 92
     is( Baz->foo, 'foo', 'original' );
93 93
 
94  
-    $obj = $CLASS->takeover( 'Baz' );
  94
+    $obj = $CLASS->new( -takeover => 'Baz' );
95 95
     is( Baz->foo, 'foo', 'original' );
96 96
     $obj->override( 'foo', sub { 'new foo' });
97 97
     is( Baz->foo, 'new foo', "override" );
@@ -99,5 +99,19 @@ tests takeover => sub {
99 99
     is( Baz->foo, 'foo', 'original' );
100 100
 };
101 101
 
  102
+tests implement => sub {
  103
+    my $obj = $CLASS->implement( 'Foox', a => sub { 'a' }, -with_new => 1 );
  104
+    lives_ok { require Foox; 1 } "Did not try to load Foox";
  105
+    can_ok( 'Foox', 'new' );
  106
+    $obj->undefine();
  107
+    throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/,  "try to load Foox";
  108
+
  109
+    $obj = $CLASS->new( -implement => 'Foox', a => sub { 'a' }, -with_new => 1 );
  110
+    lives_ok { require Foox; 1 } "Did not try to load Foox";
  111
+    can_ok( 'Foox', 'new' );
  112
+    $obj->undefine();
  113
+    throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/,  "try to load Foox";
  114
+};
  115
+
102 116
 run_tests;
103 117
 done_testing;

0 notes on commit eeb3766

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