Mock-Quick-1.110000755001750001750 012567370552 14014 5ustar00exodistexodist000000000000Mock-Quick-1.110/Build.PL000444001750001750 134412567370552 15447 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Mock::Quick', license => 'perl', dist_author => 'Chad Granum ', create_readme => 1, requires => { 'Carp' => 0, 'Scalar::Util' => 0, 'Exporter::Declare' => '0.103', }, build_requires => { 'Test::Simple' => 0.88, 'Test::Exception' => 0.29, 'Fennec::Lite' => '0.004', }, meta_merge => { resources => { repository => 'http://github.com/exodist/Mock-Quick', bugtracker => 'http://github.com/exodist/Mock-Quick/issues', }, } ); $build->create_build_script; Mock-Quick-1.110/META.json000444001750001750 346312567370552 15600 0ustar00exodistexodist000000000000{ "abstract" : "Quickly mock objects and classes, even temporarily replace them,", "author" : [ "Chad Granum " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4214", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Mock-Quick", "prereqs" : { "build" : { "requires" : { "Fennec::Lite" : "0.004", "Test::Exception" : "0.29", "Test::Simple" : "0.88" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter::Declare" : "0.103", "Scalar::Util" : "0" } } }, "provides" : { "Mock::Quick" : { "file" : "lib/Mock/Quick.pm", "version" : "1.110" }, "Mock::Quick::Class" : { "file" : "lib/Mock/Quick/Class.pm" }, "Mock::Quick::Method" : { "file" : "lib/Mock/Quick/Method.pm" }, "Mock::Quick::Object" : { "file" : "lib/Mock/Quick/Object.pm" }, "Mock::Quick::Object::Control" : { "file" : "lib/Mock/Quick/Object/Control.pm" }, "Mock::Quick::Util" : { "file" : "lib/Mock/Quick/Util.pm" }, "Object::Quick" : { "file" : "lib/Object/Quick.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/exodist/Mock-Quick/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/exodist/Mock-Quick" } }, "version" : "1.110" } Mock-Quick-1.110/META.yml000444001750001750 220512567370552 15421 0ustar00exodistexodist000000000000--- abstract: 'Quickly mock objects and classes, even temporarily replace them,' author: - 'Chad Granum ' build_requires: Fennec::Lite: '0.004' Test::Exception: '0.29' Test::Simple: '0.88' configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4214, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Mock-Quick provides: Mock::Quick: file: lib/Mock/Quick.pm version: '1.110' Mock::Quick::Class: file: lib/Mock/Quick/Class.pm Mock::Quick::Method: file: lib/Mock/Quick/Method.pm Mock::Quick::Object: file: lib/Mock/Quick/Object.pm Mock::Quick::Object::Control: file: lib/Mock/Quick/Object/Control.pm Mock::Quick::Util: file: lib/Mock/Quick/Util.pm Object::Quick: file: lib/Object/Quick.pm requires: Carp: '0' Exporter::Declare: '0.103' Scalar::Util: '0' resources: bugtracker: http://github.com/exodist/Mock-Quick/issues license: http://dev.perl.org/licenses/ repository: http://github.com/exodist/Mock-Quick version: '1.110' Mock-Quick-1.110/README000444001750001750 2250512567370552 15055 0ustar00exodistexodist000000000000NAME Mock::Quick - Quickly mock objects and classes, even temporarily replace them, side-effect free. DESCRIPTION Mock-Quick is here to solve the current problems with Mocking libraries. There are a couple Mocking libraries available on CPAN. The primary problems with these libraries include verbose syntax, and most importantly side-effects. Some Mocking libraries expect you to mock a specific class, and will unload it then redefine it. This is particularly a problem if you only want to override a class on a lexical level. Mock-Object provides a declarative mocking interface that results in a very concise, but clear syntax. There are separate facilities for mocking object instances, and classes. You can quickly create an instance of an object with custom attributes and methods. You can also quickly create an anonymous class, optionally inheriting from another, with whatever methods you desire. Mock-Object also provides a tool that provides an OO interface to overriding methods in existing classes. This tool also allows for the restoration of the original class methods. Best of all this is a localized tool, when your control object falls out of scope the original class is restored. SYNOPSIS MOCKING OBJECTS use Mock::Quick; my $obj = qobj( foo => 'bar', # define attribute do_it => qmeth { ... }, # define method ... ); is( $obj->foo, 'bar' ); $obj->foo( 'baz' ); is( $obj->foo, 'baz' ); $obj->do_it(); # define the new attribute automatically $obj->bar( 'xxx' ); # define a new method on the fly $obj->baz( qmeth { ... }); # remove an attribute or method $obj->baz( qclear() ); STRICTER MOCK use Mock::Quick; my $obj = qstrict( foo => 'bar', # define attribute do_it => qmeth { ... }, # define method ... ); is( $obj->foo, 'bar' ); $obj->foo( 'baz' ); is( $obj->foo, 'baz' ); $obj->do_it(); # remove an attribute or method $obj->baz( qclear() ); You can no longer auto-vivify accessors and methods in strict mode: # Cannot define the new attribute automatically dies_ok { $obj->bar( 'xxx' ) }; # 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. 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(). Take Control my $control = qcontrol( $obj ); Add Attributes $control->set_attributes( foo => 'bar', ... ); Add Methods $control->set_methods( do_it => sub { ... }, # No need to use qmeth() ... ); Clear Attributes/Methods $control->clear( qw/foo do_it .../ ); Toggle strict $control->strict( $BOOL ); Create With Control my $obj = qobj ...; my $obj = qstrict ...; my ( $obj, $control ) = qobjc ...; my ( $sobj, $scontrol ) = qstrictc ...; MOCKING CLASSES Note: the control object returned here is of type Mock::Quick::Class, whereas control objects for qobj style objects are of Mock::Quick::Object::Control. 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 ); 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 omitted. use Mock::Quick; my $control = qclass( # 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; # Override a method $control->override( foo => sub { ... }); # Restore it to the original $control->restore( 'foo' ); # Remove the anonymous namespace we created. $control->undefine(); TAKING OVER EXISTING/LOADED CLASSES use Mock::Quick; 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. $control = undef; You can also do this through qclass(): use Mock::Quick; my $control = qclass( -takeover => 'Some::Package', %overrides ); 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 overridden methods. EXPORTS Mock-Quick uses Exporter::Declare. This allows for exports to be prefixed or renamed. See "RENAMING IMPORTED ITEMS" in Exporter::Declare for more information. $obj = qobj( attribute => value, ... ) ( $obj, $control ) = qobjc( 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 Mock::Quick::Object for more. $obj = qstrict( attribute => value, ... ) ( $obj, $control ) = qstrictc( attribute => value, ... ) Create a stricter object, get/set accessors will not autovivify into existence for undefined attributes. $control = qclass( -config => ..., name => $value || sub { ... }, ... ) Define an anonymous package with the desired methods and specifications. See Mock::Quick::Class for more. $control = qclass( -takeover => $package, %overrides ) $control = qtakeover( $package, %overrides ); Take over an existing class. See Mock::Quick::Class for more. $control = qimplement( $package, -config => ..., name => $value || sub { ... }, ... ) $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. qclear() Returns a special reference that when used as an argument, will cause Mock::Quick::Object methods to be cleared. qmeth { my $self = shift; ... } Define a method for an Mock::Quick::Object instance. default_export qcontrol => sub { Mock::Quick::Object::Control->new( @_ ) }; AUTHORS Chad Granum exodist7@gmail.com Ben Hengst notbenh@cpan.org CONTRIBUTORS Contributors are listed as authors in modules they have touched. Ben Hengst notbenh@cpan.org Glen Hinkle glen@empireenterprises.com 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. Mock-Quick-1.110/Changes000444001750001750 33612567370552 15426 0ustar00exodistexodist0000000000001.110 2015-08-26 10:02:22-07:00 America/Los_Angeles - Fix Test from 1.109 to skip when required module is missing 1.109 2015-08-26 08:51:08-07:00 America/Los_Angeles - Fix #16, overloading + compare warning Mock-Quick-1.110/MANIFEST000444001750001750 60412567370552 15262 0ustar00exodistexodist000000000000Build.PL Changes lib/Mock/Quick.pm lib/Mock/Quick/Class.pm lib/Mock/Quick/Method.pm lib/Mock/Quick/Object.pm lib/Mock/Quick/Object/Control.pm lib/Mock/Quick/Util.pm lib/Object/Quick.pm MANIFEST This list of files MANIFEST.SKIP README t/Class.t t/clear_warn.t t/intercept.t t/Method.t t/metrics.t t/Mock-Quick.t t/Object-Quick.t t/Object.t t/object_control.t t/Util.t META.yml META.json Mock-Quick-1.110/MANIFEST.SKIP000444001750001750 6512567370552 16010 0ustar00exodistexodist000000000000^MYMETA.yml$ _build blib .git ^Build$ ^MYMETA\.json$ Mock-Quick-1.110/lib000755001750001750 012567370552 14562 5ustar00exodistexodist000000000000Mock-Quick-1.110/lib/Object000755001750001750 012567370552 15770 5ustar00exodistexodist000000000000Mock-Quick-1.110/lib/Object/Quick.pm000444001750001750 274012567370552 17542 0ustar00exodistexodist000000000000package Object::Quick; use strict; use warnings; use Mock::Quick::Object; use Mock::Quick::Method; use Mock::Quick::Util; use Carp qw/croak carp/; sub import { carp "Object::Quick is depricated, use Mock::Quick instead."; my $class = shift; my $caller = caller; my ( @names, %args ); for my $i ( @_ ) { if( $i =~ m/^-/ ) { $args{$i}++; } else { push @names => $i; } } if ( $args{'-obj'} ) { $names[0] ||= 'obj'; $names[1] ||= 'method'; $names[2] ||= 'clear'; } croak <new( @_ )}) if $names[0]; inject( $caller, $names[1], sub(&) { Mock::Quick::Method->new( @_ )}) if $names[1]; inject( $caller, $names[2], sub { \$Mock::Quick::Util::CLEAR }) if $names[2]; } 1; __END__ =head1 NAME Object::Quick - Depricated, see L =head1 DESCRIPTION Legacy interface to L =head1 AUTHORS Chad Granum L =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. Mock-Quick-1.110/lib/Mock000755001750001750 012567370552 15453 5ustar00exodistexodist000000000000Mock-Quick-1.110/lib/Mock/Quick.pm000444001750001750 2542512567370552 17252 0ustar00exodistexodist000000000000package Mock::Quick; use strict; 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; use Carp qw/carp/; our $VERSION = '1.110'; import_arguments qw/intercept/; sub after_import { my $class = shift; my ( $importer, $specs ) = @_; return unless $specs->config->{intercept}; my $intercept = $specs->config->{intercept}; no strict 'refs'; *{"$importer\::QINTERCEPT"} = sub { $intercept }; } my %CLASS_RELATED = ( qclass => 'new', qtakeover => 'takeover', qimplement => 'implement', ); for my $operation ( keys %CLASS_RELATED ) { my $meth = $CLASS_RELATED{$operation}; default_export $operation => sub { my @args = @_; return Mock::Quick::Class->$meth(@args) if defined wantarray; my $caller = caller; return $caller->QINTERCEPT->(sub { Mock::Quick::Class->$meth(@args) }) if $caller->can( 'QINTERCEPT' ); carp "Return value is ignored, your mock is destroyed as soon as it is created."; }; } 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; }; default_export qobjc => sub { my $obj = Mock::Quick::Object->new(@_); my $control = Mock::Quick::Object::Control->new($obj); $control->strict(0); return ( $obj, $control ); }; default_export qstrict => sub { my $obj = Mock::Quick::Object->new(@_); my $control = Mock::Quick::Object::Control->new($obj); $control->strict(1); return $obj; }; default_export qstrictc => sub { my $obj = Mock::Quick::Object->new(@_); my $control = Mock::Quick::Object::Control->new($obj); $control->strict(1); return ( $obj, $control ); }; default_export qclear => sub { \$Mock::Quick::Util::CLEAR }; default_export qmeth => sub(&) { Mock::Quick::Method->new(@_) }; purge_util(); 1; __END__ =pod =head1 NAME Mock::Quick - Quickly mock objects and classes, even temporarily replace them, side-effect free. =head1 DESCRIPTION Mock-Quick is here to solve the current problems with Mocking libraries. There are a couple Mocking libraries available on CPAN. The primary problems with these libraries include verbose syntax, and most importantly side-effects. Some Mocking libraries expect you to mock a specific class, and will unload it then redefine it. This is particularly a problem if you only want to override a class on a lexical level. Mock-Object provides a declarative mocking interface that results in a very concise, but clear syntax. There are separate facilities for mocking object instances, and classes. You can quickly create an instance of an object with custom attributes and methods. You can also quickly create an anonymous class, optionally inheriting from another, with whatever methods you desire. Mock-Object also provides a tool that provides an OO interface to overriding methods in existing classes. This tool also allows for the restoration of the original class methods. Best of all this is a localized tool, when your control object falls out of scope the original class is restored. =head1 SYNOPSIS =head2 MOCKING OBJECTS use Mock::Quick; my $obj = qobj( foo => 'bar', # define attribute do_it => qmeth { ... }, # define method ... ); is( $obj->foo, 'bar' ); $obj->foo( 'baz' ); is( $obj->foo, 'baz' ); $obj->do_it(); # define the new attribute automatically $obj->bar( 'xxx' ); # define a new method on the fly $obj->baz( qmeth { ... }); # remove an attribute or method $obj->baz( qclear() ); =head2 STRICTER MOCK use Mock::Quick; my $obj = qstrict( foo => 'bar', # define attribute do_it => qmeth { ... }, # define method ... ); is( $obj->foo, 'bar' ); $obj->foo( 'baz' ); is( $obj->foo, 'baz' ); $obj->do_it(); # remove an attribute or method $obj->baz( qclear() ); You can no longer auto-vivify accessors and methods in strict mode: # Cannot define the new attribute automatically dies_ok { $obj->bar( 'xxx' ) }; # 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. =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 $control->strict( $BOOL ); =item Create With Control my $obj = qobj ...; my $obj = qstrict ...; my ( $obj, $control ) = qobjc ...; my ( $sobj, $scontrol ) = qstrictc ...; =back =head2 MOCKING CLASSES B the control object returned here is of type L, whereas control objects for qobj style objects are of L. =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 omitted. use Mock::Quick; my $control = qclass( # 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; # Override a method $control->override( foo => sub { ... }); # Restore it to the original $control->restore( 'foo' ); # Remove the anonymous namespace we created. $control->undefine(); =head3 TAKING OVER EXISTING/LOADED CLASSES use Mock::Quick; 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. $control = undef; You can also do this through qclass(): use Mock::Quick; my $control = qclass( -takeover => 'Some::Package', %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 overridden methods. =head1 EXPORTS Mock-Quick uses L. This allows for exports to be prefixed or renamed. See L for more information. =over 4 =item $obj = qobj( attribute => value, ... ) =item ( $obj, $control ) = qobjc( 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 for more. =item $obj = qstrict( attribute => value, ... ) =item ( $obj, $control ) = qstrictc( attribute => value, ... ) Create a stricter object, get/set accessors will not autovivify into existence for undefined attributes. =item $control = qclass( -config => ..., name => $value || sub { ... }, ... ) Define an anonymous package with the desired methods and specifications. See L for more. =item $control = qclass( -takeover => $package, %overrides ) =item $control = qtakeover( $package, %overrides ); Take over an existing class. See L 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 Mock::Quick::Object methods to be cleared. =item qmeth { my $self = shift; ... } Define a method for an L instance. default_export qcontrol => sub { Mock::Quick::Object::Control->new( @_ ) }; =back =head1 AUTHORS Chad Granum L Ben Hengst L =head1 CONTRIBUTORS Contributors are listed as authors in modules they have touched. =over 4 =item Ben Hengst L =item Glen Hinkle L =back =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. Mock-Quick-1.110/lib/Mock/Quick000755001750001750 012567370552 16527 5ustar00exodistexodist000000000000Mock-Quick-1.110/lib/Mock/Quick/Class.pm000444001750001750 2703212567370552 20313 0ustar00exodistexodist000000000000package Mock::Quick::Class; use strict; use warnings; use Mock::Quick::Util; use Scalar::Util qw/blessed weaken/; use Carp qw/croak confess carp/; our @CARP_NOT = ('Mock::Quick', 'Mock::Quick::Object'); our $ANON = 'AAAAAAAAAA'; sub package { shift->{'-package'} } 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 ( $proto, %params ) = @_; my $package = blessed( $proto ) || $proto; my $self = bless( { -package => $package, -takeover => 1 }, $class ); for my $key ( keys %params ) { croak "param '$key' is not valid in a takeover" if $key =~ m/^-/; $self->override( $key => $params{$key} ); } $self->inject_meta(); return $self; } sub implement { my $class = shift; my ( $package, %params ) = @_; my $caller = delete $params{'-caller'} || [caller()]; my $inc = $package; $inc =~ s|::|/|g; $inc .= '.pm'; croak "$package has already been loaded, cannot implement it." if $INC{$inc}; $INC{$inc} = $caller->[1]; my $self = bless( { -package => $package, -implement => 1, -inc => $inc }, $class ); $self->inject_meta(); $self->_configure( %params ); return $self; } alt_meth new => ( obj => sub { my $self = shift; $self->package->new(@_) }, class => sub { my $class = shift; my %params = @_; croak "You cannot combine '-takeover' and '-implement' arguments" if $params{'-takeover'} && $params{'-implement'}; return $class->takeover( delete( $params{'-takeover'} ), %params ) if $params{'-takeover'}; return $class->implement( delete( $params{'-implement'} ), %params ) if $params{'-implement'}; my $package = __PACKAGE__ . "::__ANON__::" . $ANON++; my $self = bless( { %params, -package => $package }, $class ); $self->inject_meta(); $self->_configure( %params ); return $self; } ); sub inject_meta { my $self = shift; my $weak_self = $self; weaken $weak_self; inject( $self->package, 'MQ_CONTROL', sub { $weak_self } ); } sub _configure { my $self = shift; my %params = @_; my $package = $self->package; my $metrics = $self->metrics; for my $key ( keys %params ) { my $value = $params{$key}; if ( $key =~ m/^-/ ) { $self->_configure_pair( $key, $value ); } elsif( _is_sub_ref( $value )) { inject( $package, $key, sub { $metrics->{$key}++; $value->(@_) }); } else { inject( $package, $key, sub { $metrics->{$key}++; $value }); } } } sub _configure_pair { my $control = shift; my ( $param, $value ) = @_; my $package = $control->package; my $metrics = $control->metrics; if ( $param eq '-subclass' ) { $value = [ $value ] unless ref $value eq 'ARRAY'; no strict 'refs'; push @{"$package\::ISA"} => @$value; } elsif ( $param eq '-attributes' ) { $value = [ $value ] unless ref $value eq 'ARRAY'; for my $attr ( @$value ) { inject( $package, $attr, sub { my $self = shift; croak "$attr() called on class '$self' instead of an instance" unless blessed( $self ); $metrics->{$attr}++; ( $self->{$attr} ) = @_ if @_; return $self->{$attr}; }); } } elsif ( $param eq '-with_new' ) { inject( $package, 'new', sub { my $class = shift; croak "Expected hash, received reference to hash" if @_ == 1 and ref $_[0] eq 'HASH'; my %proto = @_; $metrics->{new}++; croak "new() cannot be called on an instance" if blessed( $class ); return bless( \%proto, $class ); }); } } sub _is_sub_ref { my $in = shift; my $type = ref $in; my $class = blessed( $in ); return 1 if $type && $type eq 'CODE'; return 1 if $class && $class->isa( 'Mock::Quick::Method' ); return 0; } sub override { my $self = shift; my $package = $self->package; my %pairs = @_; my @originals; my $metrics = $self->metrics; for my $name ( keys %pairs ) { my $orig_value = $pairs{$name}; carp "Overriding non-existent method '$name'" if $self->is_takeover && !$package->can($name); my $real_value = _is_sub_ref( $orig_value ) ? sub { $metrics->{$name}++; return $orig_value->(@_) } : sub { $metrics->{$name}++; return $orig_value }; my $original = $self->original( $name ); inject( $package, $name, $real_value ); push @originals, $original; } return @originals; } sub original { my $self = shift; my ( $name ) = @_; unless ( exists $self->{$name} ) { $self->{$name} = $self->package->can( $name ) || undef; } return $self->{$name}; } sub restore { my $self = shift; for my $name ( @_ ) { my $original = $self->original($name); delete $self->metrics->{$name}; if ( $original ) { my $sub = _is_sub_ref( $original ) ? $original : sub { $original }; inject( $self->package, $name, $sub ); } else { $self->_clear( $name ); } } } sub _clear { my $self = shift; my ( $name ) = @_; my $package = $self->package; no strict 'refs'; my $ref = \%{"$package\::"}; delete $ref->{ $name }; } sub undefine { my $self = shift; my $package = $self->package; croak "Refusing to undefine a class that was taken over." if $self->is_takeover; no strict 'refs'; undef( *{"$package\::"} ); delete $INC{$self->inc} if $self->is_implement; } sub DESTROY { my $self = shift; return $self->undefine unless $self->is_takeover; my $package = $self->package; { no strict 'refs'; no warnings 'redefine'; my $ref = \%{"$package\::"}; delete $ref->{MQ_CONTROL}; } for my $sub ( keys %{$self} ) { next if $sub =~ m/^-/; $self->restore( $sub ); } } purge_util(); 1; __END__ =head1 NAME Mock::Quick::Class - Class mocking for Mock::Quick =head1 DESCRIPTION Provides class mocking for L =head1 SYNOPSIS =head2 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::Class; my $control = Mock::Quick::Class->new( -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 'implement' method instead of new: use Mock::Quick::Class; my $control = Mock::Quick::Class->implement( 'Some::Package', %args ); =head2 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 omitted. use Mock::Quick::Class; my $control = Mock::Quick::Class->new( # 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; # Override a method $control->override( foo => sub { ... }); # Restore it to the original $control->restore( 'foo' ); # Remove the anonymous namespace we created. $control->undefine(); =head2 TAKING OVER EXISTING/LOADED CLASSES use Mock::Quick::Class; my $control = Mock::Quick::Class->takeover( 'Some::Package' ); # 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. $control = undef; You can also do this through new() use Mock::Quick::Class; my $control = Mock::Quick::Class->new( -takeover => 'Some::Package', %overrides ); =head1 ACCESSING THE CONTROL OBJECY While the control object exists, it can be accessed via CMQ_CONTROL()>. It is important to note that this method will disappear whenever the control object you track falls out of scope. Example (taken from Class.t): $obj = $CLASS->new( -takeover => 'Baz' ); $obj->override( 'foo', sub { my $class = shift; return "PREFIX: " . $class->MQ_CONTROL->original( 'foo' )->(); }); is( Baz->foo, "PREFIX: foo", "Override and accessed original through MQ_CONTROL" ); $obj = undef; is( Baz->foo, 'foo', 'original' ); ok( !Baz->can('MQ_CONTROL'), "Removed control" ); =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->original( $name ); Get the original method (coderef). Note: The first time this is called it find and remembers the value of package->can( $name ). This means that if you modify or replace the method without using Mock::Quick before this is called, it will have the updated method, not the true original. The override() method will call this first to ensure the original method is cached and available for restore(). Once a value is set it is never replaced or cleared. =item $obj->restore( $name ) Restore a method (Resets metrics) =item $obj->undefine() Undefine the package controlled by the control. =back =head1 AUTHORS =over 4 =item Chad Granum L =item Glen Hinkle L =back =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. Mock-Quick-1.110/lib/Mock/Quick/Method.pm000444001750001750 163712567370552 20451 0ustar00exodistexodist000000000000package Mock::Quick::Method; use strict; use warnings; use Carp (); use Scalar::Util (); sub new { my $class = shift; my ($sub) = @_; # Fixes #11 return $sub if $sub && Scalar::Util::blessed($sub) && $sub->isa($class); Carp::croak "Constructor to $class takes a single codeblock" unless ref $sub eq 'CODE'; return bless $sub, $class; } 1; __END__ =head1 NAME Mock::Quick::Method - Simple method wrapper =head1 DESCRIPTION See L and L for more details. =head1 AUTHORS Chad Granum L =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. Mock-Quick-1.110/lib/Mock/Quick/Util.pm000444001750001750 575312567370552 20151 0ustar00exodistexodist000000000000package Mock::Quick::Util; use strict; use warnings; use base 'Exporter'; use Scalar::Util qw/blessed/; use Mock::Quick::Method; use Carp qw/croak/; our $CLEAR = 'clear'; our @EXPORT = qw/ class_meth obj_meth alt_meth call param inject purge_util super /; sub inject { my ( $package, $name, $code ) = @_; no warnings 'redefine'; no strict 'refs'; *{"$package\::$name"} = $code; } 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 ( $control->strict ) { croak "Can't locate object method \"$name\" in this instance" unless exists $self->{$name}; } if ( @_ && ref $_[0] && "$_[0]" eq "" . \$CLEAR ) { delete $self->{ $name }; delete $control->metrics->{$name}; return; } $control->metrics->{$name}++; return $self->{ $name }->( $self, @_ ) if exists( $self->{ $name }) && blessed( $self->{ $name }) && blessed( $self->{ $name })->isa( 'Mock::Quick::Method' ); return $self->{$name} = shift(@_) if blessed( $_[0] ) && blessed( $_[0] )->isa( 'Mock::Quick::Method' ); param( $self, $name, @_ ); } sub param { my $self = shift; my $name = shift; $self->{$name} = shift(@_) if @_; # Prevent autovivication return unless exists( $self->{ $name }); return $self->{ $name }; } sub class_meth { my ( $name, $block ) = @_; my $caller = caller; my $sub = sub { goto &$block unless blessed( $_[0] ); unshift @_ => ( shift(@_), $name ); goto &call; }; inject( $caller, $name, $sub ); } sub obj_meth { my ( $name, $block ) = @_; my $caller = caller; my $sub = sub { goto &$block if blessed( $_[0] ); Carp::croak( "Can't locate object method \"$name\" via package \"$caller\"" ); }; inject( $caller, $name, $sub ); } sub alt_meth { my ( $name, %alts ) = @_; my $caller = caller; croak "You must provide an action for both 'class' and 'obj'" unless $alts{class} && $alts{obj}; my $sub = sub { goto &{ $alts{obj }} if blessed( $_[0] ); goto &{ $alts{ class }}; }; inject( $caller, $name, $sub ); } sub purge_util { my $caller = caller; for my $sub ( @EXPORT ) { no strict 'refs'; my $ref = \%{"$caller\::"}; delete $ref->{ $sub }; } } 1; __END__ =head1 NAME Mock::Quick::Util - Uitls for L. =head1 AUTHORS Chad Granum L =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. Mock-Quick-1.110/lib/Mock/Quick/Object.pm000444001750001750 552412567370552 20436 0ustar00exodistexodist000000000000package Mock::Quick::Object; use strict; use warnings; use Mock::Quick::Util; use Mock::Quick::Object::Control; use Carp (); use Scalar::Util (); our $AUTOLOAD; class_meth new => sub { my $class = shift; my %proto = @_; return bless \%proto, $class; }; sub AUTOLOAD { # Do not shift this, we need it when we use goto &$sub my ($self) = @_; my ( $package, $sub ) = ( $AUTOLOAD =~ m/^(.+)::([^:]+)$/ ); $AUTOLOAD = undef; Carp::croak "Can't locate object method \"$sub\" via package \"$package\"" unless Scalar::Util::blessed( $self ); 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'; $sub = UNIVERSAL::can( $self, $name ); } $sub ||= sub { unshift @_ => ( shift( @_ ), $name ); goto &call; }; inject( Scalar::Util::blessed( $self ), $name, $sub ); return $sub; }, ); # http://perldoc.perl.org/perlobj.html#Default-UNIVERSAL-methods # DOES is equivalent to isa by default sub isa { no warnings 'misc'; goto &UNIVERSAL::isa } sub DOES { goto &isa } sub VERSION { no warnings 'misc'; goto &UNIVERSAL::VERSION } obj_meth DESTROY => sub { my $self = shift; Mock::Quick::Object::Control->new( $self )->_clean; unshift @_ => ( $self, 'DESTROY' ); goto &call; }; purge_util(); 1; __END__ =head1 NAME Mock::Quick::Object - Object mocking for Mock::Quick =head1 DESCRIPTION Provides object mocking. See L for a better interface. =head1 SYNOPSIS use Mock::Quick::Object; use Mock::Quick::Method; my $obj = Mock::Quick::Object->new( foo => 'bar', # define attribute do_it => qmeth { ... }, # define method ... ); is( $obj->foo, 'bar' ); $obj->foo( 'baz' ); is( $obj->foo, 'baz' ); $obj->do_it(); # define the new attribute automatically $obj->bar( 'xxx' ); # define a new method on the fly $obj->baz( Mock::Quick::Method->new( sub { ... }); # remove an attribute or method $obj->baz( \$Mock::Quick::Util::CLEAR ); =head1 AUTHORS Chad Granum L =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. Mock-Quick-1.110/lib/Mock/Quick/Object000755001750001750 012567370552 17735 5ustar00exodistexodist000000000000Mock-Quick-1.110/lib/Mock/Quick/Object/Control.pm000444001750001750 502512567370552 22052 0ustar00exodistexodist000000000000package 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}; delete $self->metrics->{$field}; } } sub strict { my $self = shift; ($META{$self->target}->{strict}) = @_ if @_; 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}; } 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. =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 Chad Granum L =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. Mock-Quick-1.110/t000755001750001750 012567370552 14257 5ustar00exodistexodist000000000000Mock-Quick-1.110/t/Util.t000444001750001750 370312567370552 15521 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Fennec::Lite; use Test::Exception; use Mock::Quick::Method; use Mock::Quick::Object; BEGIN { tests load => sub { require_ok qw/Mock::Quick::Util/; lives_ok { Mock::Quick::Util->import() } "Import"; can_ok( __PACKAGE__, @Mock::Quick::Util::EXPORT ); }; run_tests; } tests inject => sub { inject( 'main', 'blah', sub { 'blah' }); can_ok( 'main', 'blah' ); is( blah(), 'blah', "injected sub" ); }; tests obj_meth => sub { obj_meth foo => sub { 'foo' }; can_ok( __PACKAGE__, 'foo' ); dies_ok { __PACKAGE__->foo } "Class form dies"; lives_and { is( bless( {}, __PACKAGE__ )->foo, 'foo', "Object form works" ); } "Object form should not die."; }; tests alt_meth => sub { alt_meth alpha => ( obj => sub { 'o' }, class => sub { 'c' }, ); is( __PACKAGE__->alpha, 'c', "Class version" ); is( bless( {}, __PACKAGE__ )->alpha, 'o', "Object version" ); }; tests call => sub { my $ref = bless({}, 'Mock::Quick::Object'); is( call( $ref, 'a' ), undef, "Not set" ); is( call( $ref, 'a', 'a' ), 'a', "Alter" ); is( call( $ref, 'a' ), 'a', "Altered" ); is( call( $ref, 'a', \$Mock::Quick::Util::CLEAR ), undef, "Cleared" ); is( call( $ref, 'a' ), undef, "Not set" ); call( $ref, 'a', Mock::Quick::Method->new( sub { 'xxx' })); is( call( $ref, 'a', 'foo' ), 'xxx', "Called method" ); is( call( $ref, 'a', \$Mock::Quick::Util::CLEAR ), undef, "Cleared" ); is( call( $ref, 'a' ), undef, "Not set" ); }; tests class_meth => sub { my $ref = bless( { baz => 'baz' }, 'Mock::Quick::Object' ); class_meth baz => sub { 'class baz' }; is( $ref->baz, 'baz', "Object form" ); is( __PACKAGE__->baz, 'class baz', "Class Form" ); }; run_tests; tests purge => sub { purge_util(); ok( !__PACKAGE__->can( $_ ), "$_ purged" ) for @Mock::Quick::Util::EXPORT; }; run_tests; done_testing; Mock-Quick-1.110/t/Object.t000444001750001750 176312567370552 16016 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Fennec::Lite; use Mock::Quick::Method; our $CLASS; BEGIN { $CLASS = 'Mock::Quick::Object'; use_ok( $CLASS ); } tests get_set => sub { my $obj = $CLASS->new( foo => 'bar' ); ok( $obj->can('zed'), "can do random sub" ); is( $obj->foo(), 'bar', "have property" ); ok( !$obj->baz(), "No property set" ); is( $obj->baz( 1 ), 1, "setting property" ); is( $obj->baz(), 1, "Stored value" ); }; tests methods => sub { my @args; my $obj = $CLASS->new( foo => Mock::Quick::Method->new( sub { @args = @_; return "foo was called"; }), ); is( $obj->foo( qw/bar baz/ ), "foo was called", "called virtualmethod" ); is_deeply( \@args, [ $obj, qw/bar baz/ ], "Correct arguments", ); is( $obj->foo( \$Mock::Quick::Util::CLEAR ), undef, "clearing method" ); is( $obj->foo(), undef, "cleared method" ); }; run_tests; done_testing; Mock-Quick-1.110/t/clear_warn.t000444001750001750 73012567370552 16676 0ustar00exodistexodist000000000000use strict; use warnings; use Test::More; BEGIN { unless(eval { require Path::Class; 1 }) { Test::More->import(skip_all => 'Path::Class is needed for this test'); exit 0; } } use Mock::Quick; use Path::Class; my $x = qobj(foo => qmeth { print "# My file is $_[1]\n" }); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; $x->foo( file(".") ); } ok(!@warnings, "No warnings") || print STDERR @warnings; done_testing; Mock-Quick-1.110/t/Mock-Quick.t000444001750001750 532412567370552 16550 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Fennec::Lite; BEGIN { require_ok( 'Mock::Quick' ); Mock::Quick->import(); can_ok( __PACKAGE__, qw/ qobj qclass qtakeover qclear qmeth /); package Foo; package Foo::Test::Me; } tests object => sub { is( qclear(), \$Mock::Quick::Util::CLEAR, "clear returns the clear reference" ); my $one = qobj( foo => 'bar' ); isa_ok( $one, 'Mock::Quick::Object' ); is( $one->foo, 'bar', "created properly" ); is( $one->foo( 'blah' ), 'blah', "Setting foo" ); is( $one->foo, 'blah', "foo was set" ); my $two = qmeth { 'vm' }; isa_ok( $two, 'Mock::Quick::Method' ); is( $two->(), "vm", "virtual method" ); my $three = qobj( foo => qmeth { 'bar' } ); is( $three->foo, 'bar', "ran virtual method" ); $three->foo( qclear() ); ok( !$three->foo, "cleared" ); my $four = qstrict( foo => qmeth { 'bar' } ); is( $four->foo, 'bar', "ran virtual method" ); throws_ok { $four->baz } qr/Can't locate object method "baz" in this instance/, "Strict mode"; $four->foo( qclear() ); throws_ok { $four->foo } qr/Can't locate object method "foo" in this instance/, "Strict mode"; my ( $five, $fcontrol ) = qobjc( foo => 'bar' ); isa_ok( $five, 'Mock::Quick::Object' ); isa_ok( $fcontrol, 'Mock::Quick::Object::Control' ); ok( !$fcontrol->strict, "not strict" ); my ( $six, $scontrol ) = qstrictc( foo => 'bar' ); isa_ok( $six, 'Mock::Quick::Object' ); isa_ok( $scontrol, 'Mock::Quick::Object::Control' ); ok( $scontrol->strict, "strict" ); is( $six->foo, 'bar', "created properly" ); is( $six->foo( 'blah' ), 'blah', "Setting foo" ); is( $six->foo, 'blah', "foo was set" ); }; tests class => sub { my $one = qclass( foo => 'bar' ); isa_ok( $one, 'Mock::Quick::Class' ); can_ok( $one->package, 'foo' ); my $two = qtakeover( 'Foo' ); isa_ok( $two, 'Mock::Quick::Class' ); is( $two->package, 'Foo', "took over Foo" ); my $three = qimplement( 'Foox', -with_new => 1 ); lives_ok { require Foox; 1 } "Did not try to load Foox"; can_ok( 'Foox', 'new' ); $three->undefine(); throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/, "try to load Foox"; my $inst = bless {}, 'Foo::Test::Me'; my $four = qtakeover $inst => ( foo => sub { 1 }); is( $inst->foo, 1, "Overrode the class from the instance" ); my @warn; { local $SIG{__WARN__} = sub { push @warn => @_ }; qtakeover 'foo' => ( xxx => 'noop' ); } like( $warn[0], qr/Return value is ignored, your mock is destroyed as soon as it is created/, "Warned about no-op" ); }; run_tests; done_testing; Mock-Quick-1.110/t/Method.t000444001750001750 105412567370552 16021 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Fennec::Lite; use Test::Exception; our $CLASS; BEGIN { $CLASS = 'Mock::Quick::Method'; use_ok($CLASS); } tests create => sub { my $code = sub { 1 }; my $obj = $CLASS->new($code); isa_ok( $obj, $CLASS ); is( $CLASS->new($code), $obj, "Building a method with the same sub twice succeeds" ); }; tests error => sub { throws_ok { $CLASS->new("foo") } qr/Constructor to $CLASS takes a single codeblock/, "Must be created with codeblock"; }; run_tests; done_testing; Mock-Quick-1.110/t/Object-Quick.t000444001750001750 255612567370552 17071 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { $SIG{__WARN__} = sub { my $msg = shift; print STDERR $msg unless $msg =~ m/Object::Quick is depricated/; }; require_ok('Object::Quick'); Object::Quick->import(); ok( !__PACKAGE__->can($_), "$_ not imported" ) for qw/obj method clear/; Object::Quick->import('objx'); ok( !__PACKAGE__->can($_), "$_ not imported" ) for qw/obj method clear/; can_ok( __PACKAGE__, 'objx' ); Object::Quick->import( 'objy', 'vmy' ); ok( !__PACKAGE__->can($_), "$_ not imported" ) for qw/obj method clear/; can_ok( __PACKAGE__, 'objy', 'vmy' ); Object::Quick->import( 'objz', 'vmz', 'clearz' ); ok( !__PACKAGE__->can($_), "$_ not imported" ) for qw/obj method clear/; can_ok( __PACKAGE__, 'objz', 'vmz', 'clearz' ); Object::Quick->import('-obj'); can_ok( __PACKAGE__, qw/obj method clear/ ); } is( clear(), \$Mock::Quick::Util::CLEAR, "clear returns the clear reference" ); my $one = obj( foo => 'bar' ); isa_ok( $one, 'Mock::Quick::Object' ); is( $one->foo, 'bar', "created properly" ); my $two = method { 'vm' }; isa_ok( $two, 'Mock::Quick::Method' ); is( $two->(), "vm", "virtual method" ); my $three = obj( foo => method { 'bar' } ); is( $three->foo, 'bar', "ran virtual method" ); $three->foo( clear() ); ok( !$three->foo, "cleared" ); done_testing; Mock-Quick-1.110/t/metrics.t000444001750001750 273112567370552 16252 0ustar00exodistexodist000000000000#!/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) = qobjc( 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" ); my @args; ($one, $control) = qobjc( foo => 'bar', baz => qmeth { @args = @_ }); $one->baz( 'a', 'b' ); is_deeply( [ @args ], [ $one, 'a', 'b' ], "Got Arguments" ); }; 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; Mock-Quick-1.110/t/intercept.t000444001750001750 125212567370552 16576 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Fennec::Lite; our @INTERCEPT; BEGIN { require_ok( 'Mock::Quick' ); Mock::Quick->import( '-all', '-intercept' => sub { push @INTERCEPT => @_; }); package Foo; } tests intercept => sub { qtakeover 'Foo' => ( bar => sub { 'bar' }, ); ok( !Foo->can('bar'), "Mock has not happened yet" ); is( @INTERCEPT, 1, "Intercepted the mock" ); my $control = pop( @INTERCEPT )->(); ok( Foo->can('bar'), "Mock happened" ); isa_ok( $control, 'Mock::Quick::Class' ); $control = undef; ok( !Foo->can('bar'), "Mock has been removed" ); }; run_tests; done_testing; Mock-Quick-1.110/t/Class.t000444001750001750 1105012567370552 15663 0ustar00exodistexodist000000000000#!/usr/bin/perl package Foo::Bar; use strict; use warnings; use Test::More; use Test::Exception; use Fennec::Lite random => 0; use Mock::Quick::Method; our $CLASS; BEGIN { $CLASS = 'Mock::Quick::Class'; use_ok($CLASS); package Foo; 1; package Bar; 1; package Baz; sub foo { 'foo' } sub bar { 'bar' } sub baz { 'baz' } 1; } tests create => sub { my $i = 1; my $obj = $CLASS->new( -with_new => 1, foo => 'bar', baz => sub { $i++ } ); isa_ok( $obj, $CLASS ); is( $obj->package, "$CLASS\::__ANON__\::AAAAAAAAAA", "First package" ); can_ok( $obj->package, qw/new foo baz/ ); isa_ok( $obj->new, $obj->package ); is( $obj->new->baz, 1, "sub run 1" ); is( $obj->new->baz, 2, "sub run 2" ); $obj = $CLASS->new( -subclass => 'Foo' ); isa_ok( $obj, $CLASS ); is( $obj->package, "$CLASS\::__ANON__\::AAAAAAAAAB", "Second package" ); ok( !$obj->package->can('new'), "no new" ); isa_ok( $obj->package, 'Foo' ); $obj = $CLASS->new( -subclass => [qw/Foo Bar/] ); isa_ok( $obj, $CLASS ); is( $obj->package, "$CLASS\::__ANON__\::AAAAAAAAAC", "Third package" ); isa_ok( $obj->package, 'Foo' ); isa_ok( $obj->package, 'Bar' ); $obj = $CLASS->new( -with_new => 1, -attributes => [qw/a b c/] ); can_ok( $obj->package, qw/a b c/ ); my $one = $obj->package->new; $one->a('a'); is( $one->a, 'a', "get/set" ); }; tests override => sub { my $obj = $CLASS->new( foo => 'bar' ); is( $obj->package->foo, 'bar', "original value" ); $obj->override( 'foo', sub { 'baz' } ); is( $obj->package->foo, 'baz', "overriden" ); $obj->restore('foo'); is( $obj->package->foo, 'bar', "original value" ); $obj->override( bub => Mock::Quick::Method->new( sub { print "VVV\n", return [@_] } ) ); is_deeply( $obj->package->bub( 'a', 'b' ), [$obj->package, 'a', 'b'], "got args" ); $obj->override( 'bar', sub { 'xxx' } ); is( $obj->package->bar, 'xxx', "overriden" ); $obj->restore('bar'); ok( !$obj->package->can('bar'), "original value is nill" ); # Multiple overrides $obj->override( foo => sub { 'foo' }, bar => sub { 'bar' } ); is $obj->package->foo => 'foo', "overriden"; is $obj->package->bar => 'bar', "overriden"; $obj->restore(qw/ foo bar /); is $obj->package->foo => 'bar', "original value"; ok !$obj->package->can('bar'), "original value is nil"; }; tests undefine => sub { my $obj = $CLASS->new( foo => 'bar' ); can_ok( $obj->package, 'foo' ); $obj->undefine; no strict 'refs'; ok( !keys %{$obj->package . '::'}, "anon package undefined" ); ok( !$obj->package->can('foo'), "no more foo method" ); }; tests takeover => sub { my $obj = $CLASS->takeover('Baz'); is( Baz->foo, 'foo', 'original' ); $obj->override( 'foo', sub { 'new foo' } ); is( Baz->foo, 'new foo', "override" ); $obj->restore('foo'); is( Baz->foo, 'foo', 'original' ); $obj = $CLASS->new( -takeover => 'Baz' ); is( Baz->foo, 'foo', 'original' ); $obj->override( 'foo', sub { 'new foo' } ); is( Baz->foo, 'new foo', "override" ); $obj = undef; is( Baz->foo, 'foo', 'original' ); $obj = $CLASS->new( -takeover => 'Baz' ); $obj->override( 'foo', sub { my $class = shift; return "PREFIX: " . $class->MQ_CONTROL->original('foo')->(); } ); is( Baz->foo, "PREFIX: foo", "Override and accessed original through MQ_CONTROL" ); $obj = undef; is( Baz->foo, 'foo', 'original' ); ok( !Baz->can('MQ_CONTROL'), "Removed control" ); $obj = $CLASS->takeover('Baz'); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; $obj->override('not_implemented', sub { 'xxx' }); } is(@warnings, 1, "got a warnings"); like($warnings[0], qr/Overriding non-existent method 'not_implemented'/, "Warning is what we wanted"); }; tests implement => sub { my $obj = $CLASS->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(); 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' ); ok( $obj, "Keeping it in scope." ); $obj = undef; throws_ok { require Foox; 1 } qr/Can't locate Foox\.pm/, "try to load Foox"; }; run_tests; done_testing; Mock-Quick-1.110/t/object_control.t000444001750001750 171512567370552 17613 0ustar00exodistexodist000000000000#!/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;