Skip to content
Browse files

Object control

  • Loading branch information...
1 parent 275ba4f commit 594c1523982c434d16c24de69b73e03dba756f98 @exodist committed Apr 2, 2011
Showing with 336 additions and 25 deletions.
  1. +157 −16 lib/Mock/Quick.pm
  2. +11 −2 lib/Mock/Quick/Object.pm
  3. +113 −0 lib/Mock/Quick/Object/Control.pm
  4. +3 −7 lib/Mock/Quick/Util.pm
  5. +10 −0 t/Mock-Quick.t
  6. +42 −0 t/object_control.t
View
173 lib/Mock/Quick.pm
@@ -4,24 +4,35 @@ use warnings;
use Exporter::Declare;
use Mock::Quick::Class;
use Mock::Quick::Object;
+use Mock::Quick::Object::Control;
use Mock::Quick::Method;
use Mock::Quick::Util;
our $VERSION = '1.001';
-default_export qobj => sub { Mock::Quick::Object->new( @_ ) };
-default_export qclass => sub { Mock::Quick::Class->new( @_ ) };
-default_export qtakeover => sub { Mock::Quick::Class->takeover( @_ ) };
-default_export qimplement => sub { Mock::Quick::Class->implement( @_ )};
-default_export qclear => sub { \$Mock::Quick::Util::CLEAR };
+default_export qclass => sub { Mock::Quick::Class->new( @_ ) };
+default_export qtakeover => sub { Mock::Quick::Class->takeover( @_ ) };
+default_export qimplement => sub { Mock::Quick::Class->implement( @_ ) };
+default_export qcontrol => sub { Mock::Quick::Object::Control->new( @_ ) };
+
+default_export qobj => sub {
+ my $obj = Mock::Quick::Object->new( @_ );
+ my $control = Mock::Quick::Object::Control->new( $obj );
+ $control->strict(0);
+ return $obj unless wantarray;
+ return ( $obj, $control );
+};
default_export qstrict => sub {
my $obj = Mock::Quick::Object->new( @_ );
- strict->{ $obj } = 1;
- return $obj;
+ my $control = Mock::Quick::Object::Control->new( $obj );
+ $control->strict(1);
+ return $obj unless wantarray;
+ return ( $obj, $control );
};
-default_export qmeth => sub(&){ Mock::Quick::Method->new( @_ )};
+default_export qclear => sub { \$Mock::Quick::Util::CLEAR };
+default_export qmeth => sub(&){ Mock::Quick::Method->new( @_ )};
purge_util();
@@ -111,12 +122,110 @@ You can no longer auto-vivify accessors and methods in strict mode:
# Cannot define a new method on the fly
dies_ok { $obj->baz( qmeth { ... }) };
-In order to add methods/accessors you need to create a control object:
+In order to add methods/accessors you need to create a control object.
+
+=head2 CONTROL OBJECTS
+
+Control objects are objects that let you interface a mocked object. They let
+you add attributes and methods, or even clear them. This is unnecessary unless
+you use strict mocking, or choose not to import qmeth() and qclear().
+
+=over 4
+
+=item Take Control
+
+ my $control = qcontrol( $obj );
+
+=item Add Attributes
+
+ $control->set_attributes(
+ foo => 'bar',
+ ...
+ );
+
+=item Add Methods
+
+ $control->set_methods(
+ do_it => sub { ... }, # No need to use qmeth()
+ ...
+ );
+
+=item Clear Attributes/Methods
+
+ $control->clear( qw/foo do_it .../ );
+
+=item Toggle strict
- TODO
+ $control->strict( $BOOL );
+
+=item Create With Control
+
+ my ( $obj, $control ) = qobj ...;
+ my ( $sobj, $scontrol ) = qstrict ...;
+
+=back
=head2 MOCKING CLASSES
+B<Note:> the control object returned here is of type L<Mock::Quick::Class>,
+wheras control objects for qobj style objects are of
+L<Mock::Quick::Object::Control>.
+
+=head3 IMPLEMENT A CLASS
+
+This will implement a class at the namespace provided via the -implement
+argument. The class must not already be loaded. Once complete the real class
+will be prevented from loading until you call undefine() on the control object.
+
+ use Mock::Quick;
+
+ my $control = qclass(
+ -implement => 'My::Package',
+
+ # Insert a generic new() method (blessed hash)
+ -with_new => 1,
+
+ # Inheritance
+ -subclass => 'Some::Class',
+ # Can also do
+ -subclass => [ 'Class::A', 'Class::B' ],
+
+ # generic get/set attribute methods.
+ -attributes => [ qw/a b c d/ ],
+
+ # Method that simply returns a value.
+ simple => 'value',
+
+ # Custom method.
+ method => sub { ... },
+ );
+
+ my $obj = $control->package->new;
+ # OR
+ my $obj = My::Package->new;
+
+ # Override a method
+ $control->override( foo => sub { ... });
+
+ # Restore it to the original
+ $control->restore( 'foo' );
+
+ # Remove the namespace we created, which would allow the real thing to load
+ # in a require or use statement.
+ $control->undefine();
+
+You can also use the qimplement() method instead of qclass:
+
+ use Mock::Quick;
+
+ my $control = qimplement 'Some::Package' => ( %args );
+
+=head3 ANONYMOUS MOCKED CLASS
+
+This is if you just need to generate a class where the package name does not
+matter. This is done when the -takeover and -implement arguments are both
+ommited.
+
use Mock::Quick;
my $control = qclass(
@@ -138,7 +247,7 @@ In order to add methods/accessors you need to create a control object:
method => sub { ... },
);
- my $obj = $control->packahe->new;
+ my $obj = $control->package->new;
# Override a method
$control->override( foo => sub { ... });
@@ -149,21 +258,31 @@ In order to add methods/accessors you need to create a control object:
# Remove the anonymous namespace we created.
$control->undefine();
-=head2 TAKING OVER EXISTING CLASSES
+=head3 TAKING OVER EXISTING/LOADED CLASSES
use Mock::Quick;
- my $control = qtakeover( 'Some::Package' );
+ my $control = qtakeover 'Some::Package' => ( %overrides );
# Override a method
$control->override( foo => sub { ... });
# Restore it to the original
$control->restore( 'foo' );
- # Destroy the control object and completely restore the original class Some::Package.
+ # Destroy the control object and completely restore the original class
+ # Some::Package.
$control = undef;
+You can also do this through qclass():
+
+ use Mock::Quick;
+
+ my $control = qclass(
+ -takeover => 'Some::Package',
+ %overrides
+ );
+
=head1 EXPORTS
Mock-Quick uses L<Exporter::Declare>. This allows for exports to be prefixed or renamed.
@@ -173,24 +292,43 @@ See L<Exporter::Declare/RENAMING IMPORTED ITEMS> for more information.
=item $obj = qobj( attribute => value, ... )
+=item ( $obj, $control ) = qobj( attribute => value, ... )
+
Create an object. Every possible attribute works fine as a get/set accessor.
You can define other methods using qmeth {...} and assigning that to an
attribute. You can clear a method using qclear() as an argument.
See L<Mock::Quick::Object> for more.
+=item $obj = qstrict( attribute => value, ... )
+
+=item ( $obj, $control ) = qstrict( attribute => value, ... )
+
+Create a stricter object, get/set accessors will not autovivify into existance
+for undefined attributes.
+
=item $control = qclass( -config => ..., name => $value || sub { ... }, ... )
Define an anonymous package with the desired methods and specifications.
See L<Mock::Quick::Class> for more.
-=item $control = qtakeover( $package )
+=item $control = qclass( -takeover => $package, %overrides )
+
+=item $control = qtakeover( $package, %overrides );
-Take control over an existing class.
+Take over an existing class.
See L<Mock::Quick::Class> for more.
+=item $control = qimplement( $package, -config => ..., name => $value || sub { ... }, ... )
+
+=item $control = qclass( -implement => $package, ... )
+
+Implement the given package to specifications, altering %INC so that the real
+class will not load. Destroying the control object will once again allow the
+original to load.
+
=item qclear()
Returns a special reference that when used as an argument, will cause
@@ -200,6 +338,9 @@ Mock::Quick::Object methods to be cleared.
Define a method for an L<Mock::Quick::Object> instance.
+default_export qcontrol => sub { Mock::Quick::Object::Control->new( @_ ) };
+
+
=back
=head1 AUTHORS
View
13 lib/Mock/Quick/Object.pm
@@ -3,6 +3,7 @@ use strict;
use warnings;
use Mock::Quick::Util;
+use Mock::Quick::Object::Control;
use Carp ();
use Scalar::Util ();
@@ -23,13 +24,21 @@ sub AUTOLOAD {
Carp::croak "Can't locate object method \"$sub\" via package \"$package\""
unless Scalar::Util::blessed( $self );
- goto &{ $self->can( $sub )};
+ my $code = $self->can( $sub );
+ Carp::croak "Can't locate object method \"$sub\" in this instance"
+ unless $code;
+
+ goto &$code;
};
alt_meth can => (
class => sub { no warnings 'misc'; goto &UNIVERSAL::can },
obj => sub {
my ( $self, $name ) = @_;
+
+ my $control = Mock::Quick::Object::Control->new( $self );
+ return if $control->strict && !exists $self->{$name};
+
my $sub;
{
no warnings 'misc';
@@ -52,7 +61,7 @@ sub VERSION { no warnings 'misc'; goto &UNIVERSAL::VERSION }
obj_meth DESTROY => sub {
my $self = shift;
- delete strict()->{$self};
+ Mock::Quick::Object::Control->new( $self )->_clean;
unshift @_ => ( $self, 'DESTROY' );
goto &call;
};
View
113 lib/Mock/Quick/Object/Control.pm
@@ -0,0 +1,113 @@
+package Mock::Quick::Object::Control;
+use strict;
+use warnings;
+use Mock::Quick::Util;
+use Mock::Quick::Object;
+use Mock::Quick::Method;
+
+our %META;
+
+sub target { shift->{target} }
+
+sub new {
+ my $class = shift;
+ my ( $target ) = @_;
+ return bless( { target => $target }, $class );
+}
+
+sub set_methods {
+ my $self = shift;
+ my %params = @_;
+ for my $key ( keys %params ) {
+ $self->target->{$key} = Mock::Quick::Method->new( $params{$key} );
+ }
+}
+
+sub set_attributes {
+ my $self = shift;
+ my %params = @_;
+ for my $key ( keys %params ) {
+ $self->target->{$key} = $params{$key};
+ }
+}
+
+sub clear {
+ my $self = shift;
+ for my $field ( @_ ) {
+ delete $self->target->{ $field };
+ }
+}
+
+sub strict {
+ my $self = shift;
+ ($META{$self->target}->{strict}) = @_ if @_;
+ return $META{$self->target}->{strict};
+}
+
+sub _clean {
+ my $self = shift;
+ delete $META{$self->target};
+}
+
+purge_util();
+
+1;
+
+__END__
+
+=head1 NAME
+
+Mock::Quick::Object::Control - Control a mocked object after creation
+
+=head1 DESCRIPTION
+
+Control a mocked object after creation.
+
+=head1 SYNOPSIS
+
+ my $obj = Mock::Quick::Object->new( ... );
+ my $control = Mock::Quick::Object::Control->new( $obj );
+
+ $control->set_methods( foo => sub { 'foo' });
+ $control->set_attributes( bar => 'baz' );
+
+ # Make an attribute exist so that it can be used for get/set operations.
+ $control->set_attributes( empty => undef );
+
+=head1 METHODS
+
+=over 4
+
+=item $control = $CLASS->new( $obj )
+
+=item $control->set_methods( name => sub { ... }, ... )
+
+Set/Create methods
+
+=item $control->set_attributes( name => $val, ... )
+
+Set/Create attributes (simple get/set accessors)
+
+=item $control->clear( $name1, $name2, ... )
+
+Remove attributes/methods.
+
+=item $control->strict( $BOOL )
+
+Enable/Disable strict mode.
+
+=back
+
+=head1 AUTHORS
+
+Chad Granum L<exodist7@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2011 Chad Granum
+
+Mock-Quick is free software; Standard perl licence.
+
+Mock-Quick 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 license for more details.
View
10 lib/Mock/Quick/Util.pm
@@ -17,7 +17,6 @@ our @EXPORT = qw/
inject
purge_util
super
- strict
/;
sub inject {
@@ -27,20 +26,17 @@ sub inject {
*{"$package\::$name"} = $code;
}
-{
- my %strict;
- sub strict { \%strict };
-}
-
sub call {
my $self = shift;
+ require Mock::Quick::Object::Control;
+ my $control = Mock::Quick::Object::Control->new( $self );
my $name = shift;
my $class = blessed( $self );
croak "Can't call method on an unblessed reference"
unless $class;
- if ( strict()->{$self} ) {
+ if ( $control->strict ) {
croak "Can't locate object method \"$name\" in this instance"
unless exists $self->{$name};
}
View
10 t/Mock-Quick.t
@@ -41,6 +41,16 @@ tests object => sub {
throws_ok { $four->foo }
qr/Can't locate object method "foo" in this instance/,
"Strict mode";
+
+ my ( $five, $fcontrol ) = qobj( foo => 'bar' );
+ isa_ok( $five, 'Mock::Quick::Object' );
+ isa_ok( $fcontrol, 'Mock::Quick::Object::Control' );
+ ok( !$fcontrol->strict, "not strict" );
+
+ my ( $six, $scontrol ) = qstrict( foo => 'bar' );
+ isa_ok( $six, 'Mock::Quick::Object' );
+ isa_ok( $scontrol, 'Mock::Quick::Object::Control' );
+ ok( $scontrol->strict, "strict" );
};
tests class => sub {
View
42 t/object_control.t
@@ -0,0 +1,42 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+use Fennec::Lite;
+use Mock::Quick::Method;
+use Mock::Quick::Object;
+
+our $CLASS;
+
+BEGIN {
+ $CLASS = 'Mock::Quick::Object::Control';
+ use_ok( $CLASS );
+ can_ok( $CLASS, qw/strict set_methods set_attributes new clear/ );
+}
+
+tests basic => sub {
+ my $obj = Mock::Quick::Object->new( foo => 'foo' );
+ my $control = $CLASS->new( $obj );
+ isa_ok( $control, $CLASS );
+
+ ok( !$control->strict, "not strict" );
+ ok( $control->strict(1), "set strict" );
+ ok( $control->strict(), "is strict" );
+
+ can_ok( $obj, 'foo' );
+
+ ok( !$obj->can( $_ ), "can't $_ yet" ) for qw/ bar baz /;
+
+ $control->set_methods( bar => sub { 'bar' });
+ $control->set_attributes( baz => 'baz' );
+ can_ok( $obj, qw/bar baz/ );
+ is( $obj->bar, 'bar', "got bar" );
+ is( $obj->baz, 'baz', "got baz" );
+
+ $control->clear( 'foo' );
+ ok( !$obj->can('foo'), "no more foo" );
+};
+
+run_tests;
+done_testing;

0 comments on commit 594c152

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