1package Mock::Quick::Class;
2use strict;
3use warnings;
4
5use Mock::Quick::Util;
6use Scalar::Util qw/blessed weaken/;
7use Carp qw/croak confess carp/;
8
9our @CARP_NOT = ('Mock::Quick', 'Mock::Quick::Object');
10our $ANON = 'AAAAAAAAAA';
11
12sub package      { shift->{'-package'}  }
13sub inc          { shift->{'-inc'}      }
14sub is_takeover  { shift->{'-takeover'} }
15sub is_implement { shift->{'-implement'}}
16
17sub metrics {
18    my $self = shift;
19    $self->{'-metrics'} ||= {};
20    return $self->{'-metrics'};
21}
22
23sub takeover {
24    my $class = shift;
25    my ( $proto, %params ) = @_;
26    my $package = blessed( $proto ) || $proto;
27
28    my $self = bless( { -package => $package, -takeover => 1 }, $class );
29
30    for my $key ( keys %params ) {
31        croak "param '$key' is not valid in a takeover"
32            if $key =~ m/^-/;
33        $self->override( $key => $params{$key} );
34    }
35
36    $self->inject_meta();
37
38    return $self;
39}
40
41sub implement {
42    my $class = shift;
43    my ( $package, %params ) = @_;
44    my $caller = delete $params{'-caller'} || [caller()];
45
46    my $inc = $package;
47    $inc =~ s|::|/|g;
48    $inc .= '.pm';
49
50    croak "$package has already been loaded, cannot implement it."
51        if $INC{$inc};
52
53    $INC{$inc} = $caller->[1];
54
55    my $self = bless(
56        { -package => $package, -implement => 1, -inc => $inc },
57        $class
58    );
59
60    $self->inject_meta();
61
62    $self->_configure( %params );
63
64    return $self;
65}
66
67alt_meth new => (
68    obj   => sub { my $self = shift; $self->package->new(@_) },
69    class => sub {
70        my $class = shift;
71        my %params = @_;
72
73        croak "You cannot combine '-takeover' and '-implement' arguments"
74            if $params{'-takeover'} && $params{'-implement'};
75
76        return $class->takeover( delete( $params{'-takeover'} ), %params )
77            if $params{'-takeover'};
78
79        return $class->implement( delete( $params{'-implement'} ), %params )
80            if $params{'-implement'};
81
82        my $package = __PACKAGE__ . "::__ANON__::" . $ANON++;
83
84        my $self = bless( { %params, -package => $package }, $class );
85
86        $self->inject_meta();
87
88        $self->_configure( %params );
89
90        return $self;
91    }
92);
93
94sub inject_meta {
95    my $self = shift;
96    my $weak_self = $self;
97    weaken $weak_self;
98    inject( $self->package, 'MQ_CONTROL', sub { $weak_self } );
99}
100
101sub _configure {
102    my $self = shift;
103    my %params = @_;
104    my $package = $self->package;
105    my $metrics = $self->metrics;
106
107    for my $key ( keys %params ) {
108        my $value = $params{$key};
109
110        if ( $key =~ m/^-/ ) {
111            $self->_configure_pair( $key, $value );
112        }
113        elsif( _is_sub_ref( $value )) {
114            inject( $package, $key, sub { $metrics->{$key}++; $value->(@_) });
115        }
116        else {
117            inject( $package, $key, sub { $metrics->{$key}++; $value });
118        }
119    }
120}
121
122sub _configure_pair {
123    my $control = shift;
124    my ( $param, $value ) = @_;
125    my $package = $control->package;
126    my $metrics = $control->metrics;
127
128    if ( $param eq '-subclass' ) {
129        $value = [ $value ] unless ref $value eq 'ARRAY';
130        no strict 'refs';
131        push @{"$package\::ISA"} => @$value;
132    }
133    elsif ( $param eq '-attributes' ) {
134        $value = [ $value ] unless ref $value eq 'ARRAY';
135        for my $attr ( @$value ) {
136            inject( $package, $attr, sub {
137                my $self = shift;
138
139                croak "$attr() called on class '$self' instead of an instance"
140                    unless blessed( $self );
141
142                $metrics->{$attr}++;
143                ( $self->{$attr} ) = @_ if @_;
144                return $self->{$attr};
145            });
146        }
147    }
148    elsif ( $param eq '-with_new' ) {
149        inject( $package, 'new', sub {
150            my $class = shift;
151            croak "Expected hash, received reference to hash"
152                if @_ == 1 and ref $_[0] eq 'HASH';
153            my %proto = @_;
154            $metrics->{new}++;
155
156            croak "new() cannot be called on an instance"
157                if blessed( $class );
158
159            return bless( \%proto, $class );
160        });
161    }
162}
163
164sub _is_sub_ref {
165    my $in = shift;
166    my $type = ref $in;
167    my $class = blessed( $in );
168
169    return 1 if $type && $type eq 'CODE';
170    return 1 if $class && $class->isa( 'Mock::Quick::Method' );
171    return 0;
172}
173
174sub override {
175    my $self = shift;
176    my $package = $self->package;
177    my %pairs = @_;
178    my @originals;
179    my $metrics = $self->metrics;
180
181    for my $name ( keys %pairs ) {
182        my $orig_value = $pairs{$name};
183
184        carp "Overriding non-existent method '$name'"
185            if $self->is_takeover && !$package->can($name);
186
187        my $real_value = _is_sub_ref( $orig_value )
188            ? sub { $metrics->{$name}++; return $orig_value->(@_) }
189            : sub { $metrics->{$name}++; return $orig_value };
190
191        my $original = $self->original( $name );
192        inject( $package, $name, $real_value );
193
194        push @originals, $original;
195    }
196
197    return @originals;
198}
199
200sub original {
201    my $self = shift;
202    my ( $name ) = @_;
203    unless ( exists $self->{$name} ) {
204        $self->{$name} = $self->package->can( $name ) || undef;
205    }
206    return $self->{$name};
207}
208
209sub restore {
210    my $self = shift;
211
212    for my $name ( @_ ) {
213        my $original = $self->original($name);
214        delete $self->metrics->{$name};
215
216        if ( $original ) {
217            my $sub = _is_sub_ref( $original ) ? $original : sub { $original };
218            inject( $self->package, $name, $sub );
219        }
220        else {
221            $self->_clear( $name );
222        }
223    }
224}
225
226sub _clear {
227    my $self = shift;
228    my ( $name ) = @_;
229    my $package = $self->package;
230    no strict 'refs';
231    my $ref = \%{"$package\::"};
232    delete $ref->{ $name };
233}
234
235sub undefine {
236    my $self = shift;
237    my $package = $self->package;
238    croak "Refusing to undefine a class that was taken over."
239        if $self->is_takeover;
240    no strict 'refs';
241    undef( *{"$package\::"} );
242    delete $INC{$self->inc} if $self->is_implement;
243}
244
245sub DESTROY {
246    my $self = shift;
247    return $self->undefine unless $self->is_takeover;
248
249    my $package = $self->package;
250
251    {
252        no strict 'refs';
253        no warnings 'redefine';
254
255        my $ref = \%{"$package\::"};
256        delete $ref->{MQ_CONTROL};
257    }
258
259    for my $sub ( keys %{$self} ) {
260        next if $sub =~ m/^-/;
261        $self->restore( $sub );
262    }
263}
264
265purge_util();
266
2671;
268
269__END__
270
271=head1 NAME
272
273Mock::Quick::Class - Class mocking for Mock::Quick
274
275=head1 DESCRIPTION
276
277Provides class mocking for L<Mock::Quick>
278
279=head1 SYNOPSIS
280
281=head2 IMPLEMENT A CLASS
282
283This will implement a class at the namespace provided via the -implement
284argument. The class must not already be loaded. Once complete the real class
285will be prevented from loading until you call undefine() on the control object.
286
287    use Mock::Quick::Class;
288
289    my $control = Mock::Quick::Class->new(
290        -implement => 'My::Package',
291
292        # Insert a generic new() method (blessed hash)
293        -with_new => 1,
294
295        # Inheritance
296        -subclass => 'Some::Class',
297        # Can also do
298        -subclass => [ 'Class::A', 'Class::B' ],
299
300        # generic get/set attribute methods.
301        -attributes => [ qw/a b c d/ ],
302
303        # Method that simply returns a value.
304        simple => 'value',
305
306        # Custom method.
307        method => sub { ... },
308    );
309
310    my $obj = $control->package->new;
311    # OR
312    my $obj = My::Package->new;
313
314    # Override a method
315    $control->override( foo => sub { ... });
316
317    # Restore it to the original
318    $control->restore( 'foo' );
319
320    # Remove the namespace we created, which would allow the real thing to load
321    # in a require or use statement.
322    $control->undefine();
323
324You can also use the 'implement' method instead of new:
325
326    use Mock::Quick::Class;
327
328    my $control = Mock::Quick::Class->implement(
329        'Some::Package',
330        %args
331    );
332
333=head2 ANONYMOUS MOCKED CLASS
334
335This is if you just need to generate a class where the package name does not
336matter. This is done when the -takeover and -implement arguments are both
337omitted.
338
339    use Mock::Quick::Class;
340
341    my $control = Mock::Quick::Class->new(
342        # Insert a generic new() method (blessed hash)
343        -with_new => 1,
344
345        # Inheritance
346        -subclass => 'Some::Class',
347        # Can also do
348        -subclass => [ 'Class::A', 'Class::B' ],
349
350        # generic get/set attribute methods.
351        -attributes => [ qw/a b c d/ ],
352
353        # Method that simply returns a value.
354        simple => 'value',
355
356        # Custom method.
357        method => sub { ... },
358    );
359
360    my $obj = $control->package->new;
361
362    # Override a method
363    $control->override( foo => sub { ... });
364
365    # Restore it to the original
366    $control->restore( 'foo' );
367
368    # Remove the anonymous namespace we created.
369    $control->undefine();
370
371=head2 TAKING OVER EXISTING/LOADED CLASSES
372
373    use Mock::Quick::Class;
374
375    my $control = Mock::Quick::Class->takeover( 'Some::Package' );
376
377    # Override a method
378    $control->override( foo => sub { ... });
379
380    # Restore it to the original
381    $control->restore( 'foo' );
382
383    # Destroy the control object and completely restore the original class
384    # Some::Package.
385    $control = undef;
386
387You can also do this through new()
388
389    use Mock::Quick::Class;
390
391    my $control = Mock::Quick::Class->new(
392        -takeover => 'Some::Package',
393        %overrides
394    );
395
396=head1 ACCESSING THE CONTROL OBJECY
397
398While the control object exists, it can be accessed via
399C<YOUR::PACKAGE->MQ_CONTROL()>. It is important to note that this method will
400disappear whenever the control object you track falls out of scope.
401
402Example (taken from Class.t):
403
404    $obj = $CLASS->new( -takeover => 'Baz' );
405    $obj->override( 'foo', sub {
406        my $class = shift;
407        return "PREFIX: " . $class->MQ_CONTROL->original( 'foo' )->();
408    });
409
410    is( Baz->foo, "PREFIX: foo", "Override and accessed original through MQ_CONTROL" );
411    $obj = undef;
412
413    is( Baz->foo, 'foo', 'original' );
414    ok( !Baz->can('MQ_CONTROL'), "Removed control" );
415
416=head1 METHODS
417
418=over 4
419
420=item $package = $obj->package()
421
422Get the name of the package controlled by this object.
423
424=item $bool = $obj->is_takeover()
425
426Check if the control object was created to takeover an existing class.
427
428=item $bool = $obj->is_implement()
429
430Check if the control object was created to implement a class.
431
432=item $data = $obj->metrics()
433
434Returns a hash where keys are method names, and values are the number of times
435the method has been called. When a method is altered or removed the key is
436deleted.
437
438=item $obj->override( name => sub { ... })
439
440Override a method.
441
442=item $obj->original( $name );
443
444Get the original method (coderef). Note: The first time this is called it find
445and remembers the value of package->can( $name ). This means that if you modify
446or replace the method without using Mock::Quick before this is called, it will
447have the updated method, not the true original.
448
449The override() method will call this first to ensure the original method is
450cached and available for restore(). Once a value is set it is never replaced or
451cleared.
452
453=item $obj->restore( $name )
454
455Restore a method (Resets metrics)
456
457=item $obj->undefine()
458
459Undefine the package controlled by the control.
460
461=back
462
463=head1 AUTHORS
464
465=over 4
466
467=item Chad Granum L<exodist7@gmail.com>
468
469=item Glen Hinkle L<glen@empireenterprises.com>
470
471=back
472
473=head1 COPYRIGHT
474
475Copyright (C) 2011 Chad Granum
476
477Mock-Quick is free software; Standard perl licence.
478
479Mock-Quick is distributed in the hope that it will be useful, but WITHOUT ANY
480WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
481PARTICULAR PURPOSE. See the license for more details.
482