r13591 - in /branches/upstream/libtest-mockmodule-perl: ./ current/ current/lib/ current/lib/Test/ current/t/
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Sat Jan 26 08:13:57 UTC 2008
Author: dmn
Date: Sat Jan 26 08:13:57 2008
New Revision: 13591
URL: http://svn.debian.org/wsvn/?sc=1&rev=13591
Log:
[svn-inject] Installing original source of libtest-mockmodule-perl
Added:
branches/upstream/libtest-mockmodule-perl/
branches/upstream/libtest-mockmodule-perl/current/
branches/upstream/libtest-mockmodule-perl/current/Changes
branches/upstream/libtest-mockmodule-perl/current/MANIFEST
branches/upstream/libtest-mockmodule-perl/current/MANIFEST.SKIP
branches/upstream/libtest-mockmodule-perl/current/META.yml
branches/upstream/libtest-mockmodule-perl/current/Makefile.PL
branches/upstream/libtest-mockmodule-perl/current/README
branches/upstream/libtest-mockmodule-perl/current/lib/
branches/upstream/libtest-mockmodule-perl/current/lib/Test/
branches/upstream/libtest-mockmodule-perl/current/lib/Test/MockModule.pm
branches/upstream/libtest-mockmodule-perl/current/t/
branches/upstream/libtest-mockmodule-perl/current/t/mockmodule.t (with props)
branches/upstream/libtest-mockmodule-perl/current/t/pod.t (with props)
branches/upstream/libtest-mockmodule-perl/current/t/pod_coverage.t (with props)
Added: branches/upstream/libtest-mockmodule-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/Changes?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/Changes (added)
+++ branches/upstream/libtest-mockmodule-perl/current/Changes Sat Jan 26 08:13:57 2008
@@ -1,0 +1,20 @@
+Revision history for Test::MockModule
+$Id: Changes,v 1.5 2005/03/24 22:23:38 simonflack Exp $
+
+v0.05 2004-03-24
+ - unmock() accepts a list of subroutines to unmock. Thanks to David Wheeler
+ for the suggestion and patch
+ - Added t/pod_coverage.t
+
+v0.04 2004-12-12
+ - You can now mock a subroutine with a scalar value or a reference
+ (install sub that returns the value). Thanks to Ovid for the suggestion.
+
+v0.03 2004-12-05
+ - Restores subs/methods that previously didn't exist (undefine them)
+
+v0.02 2004-11-28
+ - Fixed restoring inherited methods
+
+v0.01 2004-11-28
+ - Initial revision
Added: branches/upstream/libtest-mockmodule-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/MANIFEST?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/MANIFEST (added)
+++ branches/upstream/libtest-mockmodule-perl/current/MANIFEST Sat Jan 26 08:13:57 2008
@@ -1,0 +1,10 @@
+Changes
+Makefile.PL
+MANIFEST
+MANIFEST.SKIP
+README
+lib/Test/MockModule.pm
+t/mockmodule.t
+t/pod.t
+t/pod_coverage.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libtest-mockmodule-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/MANIFEST.SKIP?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libtest-mockmodule-perl/current/MANIFEST.SKIP Sat Jan 26 08:13:57 2008
@@ -1,0 +1,8 @@
+^blib
+^bak
+~$
+(?:^|/)[Mm]akefile(?:\.old)?$
+(?:^|/)pm_to_blib$
+^Test-MockModule-\d+\.\d+\.(zip|tar\.gz|tgz)$
+[Cc][Vv][Ss]/
+^\.releaserc
Added: branches/upstream/libtest-mockmodule-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/META.yml?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/META.yml (added)
+++ branches/upstream/libtest-mockmodule-perl/current/META.yml Sat Jan 26 08:13:57 2008
@@ -1,0 +1,12 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Test-MockModule
+version: 0.05
+version_from: lib/Test/MockModule.pm
+installdirs: site
+requires:
+ Scalar::Util: 0
+ Test::More: 0.45
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libtest-mockmodule-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/Makefile.PL?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/Makefile.PL (added)
+++ branches/upstream/libtest-mockmodule-perl/current/Makefile.PL Sat Jan 26 08:13:57 2008
@@ -1,0 +1,11 @@
+# $Id: Makefile.PL,v 1.1.1.1 2004/11/28 23:38:28 simonflack Exp $
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ 'NAME' => 'Test::MockModule',
+ 'VERSION_FROM' => 'lib/Test/MockModule.pm',
+ 'PREREQ_PM' => { 'Test::More' => 0.45,
+ 'Scalar::Util' => 0, },
+ ($] >= 5.005 ?
+ (ABSTRACT_FROM => 'lib/Test/MockModule.pm',
+ AUTHOR => 'Simon Flack') : ()),
+);
Added: branches/upstream/libtest-mockmodule-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/README?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/README (added)
+++ branches/upstream/libtest-mockmodule-perl/current/README Sat Jan 26 08:13:57 2008
@@ -1,0 +1,17 @@
+Test::MockModule - mock subroutines in a module
+
+See the LICENSE section in lib/Test/MockObject.pm for usage and distribution
+rights
+
+QUICK START:
+
+commands in the source directory:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+ Then delete the source directory tree since it's no longer needed.
+
+ run 'perldoc Test::MockModule' to read the full documentation.
+
Added: branches/upstream/libtest-mockmodule-perl/current/lib/Test/MockModule.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/lib/Test/MockModule.pm?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/lib/Test/MockModule.pm (added)
+++ branches/upstream/libtest-mockmodule-perl/current/lib/Test/MockModule.pm Sat Jan 26 08:13:57 2008
@@ -1,0 +1,278 @@
+# $Id: MockModule.pm,v 1.7 2005/03/24 22:23:38 simonflack Exp $
+package Test::MockModule;
+use strict qw/subs vars/;
+use vars qw/$VERSION/;
+use Scalar::Util qw/reftype weaken/;
+use Carp;
+$VERSION = '0.05';#sprintf'%d.%02d', q$Revision: 1.7 $ =~ /: (\d+)\.(\d+)/;
+
+my %mocked;
+sub new {
+ my $class = shift;
+ my ($package, %args) = @_;
+ if ($package && (my $existing = $mocked{$package})) {
+ return $existing;
+ }
+
+ croak "Cannot mock $package" if $package && $package eq $class;
+ unless (_valid_package($package)) {
+ $package = 'undef' unless defined $package;
+ croak "Invalid package name $package";
+ }
+
+ unless ($args{no_auto} || ${"$package\::VERSION"}) {
+ (my $load_package = "$package.pm") =~ s{::}{/}g;
+ TRACE("$package is empty, loading $load_package");
+ require $load_package;
+ }
+
+ TRACE("Creating MockModule object for $package");
+ my $self = bless {
+ _package => $package,
+ _mocked => {},
+ }, $class;
+ $mocked{$package} = $self;
+ weaken $mocked{$package};
+ return $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->unmock_all;
+}
+
+sub get_package {
+ my $self = shift;
+ return $self->{_package};
+}
+
+sub mock {
+ my $self = shift;
+
+ while (my ($name, $value) = splice @_, 0, 2) {
+ my $code = sub { };
+ if (ref $value && reftype $value eq 'CODE') {
+ $code = $value;
+ } elsif (defined $value) {
+ $code = sub {$value};
+ }
+
+ TRACE("$name: $code");
+ croak "Invalid subroutine name: $name" unless _valid_subname($name);
+ my $sub_name = _full_name($self, $name);
+ if (!$self->{_mocked}{$name}) {
+ TRACE("Storing existing $sub_name");
+ $self->{_mocked}{$name} = 1;
+ $self->{_orig}{$name} = defined &{$sub_name} ? \&$sub_name
+ : $self->{_package}->can($name);
+ }
+ TRACE("Installing mocked $sub_name");
+ _replace_sub($sub_name, $code);
+ }
+}
+
+sub original {
+ my $self = shift;
+ my ($name) = @_;
+ return carp _full_name($self, $name) . " is not mocked"
+ unless $self->{_mocked}{$name};
+ return $self->{_orig}{$name};
+}
+
+sub unmock {
+ my $self = shift;
+
+ for my $name (@_) {
+ croak "Invalid subroutine name: $name" unless _valid_subname($name);
+
+ my $sub_name = _full_name($self, $name);
+ unless ($self->{_mocked}{$name}) {
+ carp $sub_name . " was not mocked";
+ next;
+ }
+
+ TRACE("Restoring original $sub_name");
+ _replace_sub($sub_name, $self->{_orig}{$name});
+ delete $self->{_mocked}{$name};
+ delete $self->{_orig}{$name};
+ }
+ return $self;
+}
+
+sub unmock_all {
+ my $self = shift;
+ foreach (keys %{$self->{_mocked}}) {
+ $self->unmock($_);
+ }
+}
+
+sub is_mocked {
+ my $self = shift;
+ my ($name) = shift;
+ return $self->{_mocked}{$name};
+}
+
+sub _full_name {
+ my ($self, $sub_name) = @_;
+ sprintf "%s::%s", $self->{_package}, $sub_name;
+}
+
+sub _valid_package {
+ defined($_[0]) && $_[0] =~ /^[a-z_]\w*(?:::\w+)*$/i;
+}
+
+sub _valid_subname {
+ $_[0] =~ /^[a-z_]\w*$/i;
+}
+
+sub _replace_sub {
+ my ($sub_name, $coderef) = @_;
+ # from Test::MockObject
+ local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /redefined/ };
+ if (defined $coderef) {
+ *{$sub_name} = $coderef;
+ } else {
+ TRACE("removing subroutine: $sub_name");
+ my ($package, $sub) = $sub_name =~ /(.*::)(.*)/;
+ my %symbols = %{$package};
+
+ # save a copy of all non-code slots
+ my %slot;
+ foreach (qw(ARRAY FORMAT HASH IO SCALAR)) {
+ next unless defined(my $elem = *{$symbols{$sub}}{$_});
+ $slot{$_} = $elem;
+ }
+
+ # clear the symbol table entry for the subroutine
+ undef *$sub_name;
+
+ # restore everything except the code slot
+ return unless keys %slot;
+ foreach (keys %slot) {
+ *$sub_name = $slot{$_};
+ }
+ }
+}
+
+# Log::Trace stubs
+sub TRACE {}
+sub DUMP {}
+
+1;
+
+=pod
+
+=head1 NAME
+
+Test::MockModule - Override subroutines in a module for unit testing
+
+=head1 SYNOPSIS
+
+ use Module::Name;
+ use Test::MockModule;
+
+ {
+ my $module = new Test::MockModule('Module::Name');
+ $module->mock('subroutine', sub { ... });
+ Module::Name::subroutine(@args); # mocked
+ }
+
+ Module::Name::subroutine(@args); # original subroutine
+
+=head1 DESCRIPTION
+
+C<Test::MockModule> lets you temporarily redefine subroutines in other packages
+for the purposes of unit testing.
+
+A C<Test::MockModule> object is set up to mock subroutines for a given
+module. The object remembers the original subroutine so it can be easily
+restored. This happens automatically when all MockModule objects for the given
+module go out of scope, or when you C<unmock()> the subroutine.
+
+=head1 METHODS
+
+=over 4
+
+=item new($package[, %options])
+
+Returns an object that will mock subroutines in the specified C<$package>.
+
+If there is no C<$VERSION> defined in C<$package>, the module will be
+automatically loaded. You can override this behaviour by setting the C<no_auto>
+option:
+
+ my $mock = new Test::MockModule('Module::Name', no_auto => 1);
+
+=item get_package()
+
+Returns the target package name for the mocked subroutines
+
+=item is_mocked($subroutine)
+
+Returns a boolean value indicating whether or not the subroutine is currently
+mocked
+
+=item mock($subroutine =E<gt> \E<amp>coderef)
+
+Temporarily replaces one or more subroutines in the mocked module. A subroutine
+can be mocked with a code reference or a scalar. A scalar will be recast as a
+subroutine that returns the scalar.
+
+The following statements are equivalent:
+
+ $module->mock(purge => 'purged');
+ $module->mock(purge => sub { return 'purged'});
+
+ $module->mock(updated => [localtime()]);
+ $module->mock(updated => sub { return [localtime()]});
+
+However, C<undef> is a special case. If you mock a subroutine with C<undef> it
+will install an empty subroutine
+
+ $module->mock(purge => undef);
+ $module->mock(purge => sub { });
+
+rather than a subroutine that returns C<undef>:
+
+ $module->mock(purge => sub { undef });
+
+You can call C<mock()> for the same subroutine many times, but when you call
+C<unmock()>, the original subroutine is restored (not the last mocked
+instance).
+
+=item original($subroutine)
+
+Returns the original (unmocked) subroutine
+
+=item unmock($subroutine [, ...])
+
+Restores the original C<$subroutine>. You can specify a list of subroutines to
+C<unmock()> in one go.
+
+=item unmock_all()
+
+Restores all the subroutines in the package that were mocked. This is
+automatically called when all C<Test::MockObject> objects for the given package
+go out of scope.
+
+=back
+
+=head1 SEE ALSO
+
+L<Test::MockObject::Extends>
+
+L<Sub::Override>
+
+=head1 AUTHOR
+
+Simon Flack E<lt>simonflk _AT_ cpan.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004 Simon Flack E<lt>simonflk _AT_ cpan.orgE<gt>.
+All rights reserved
+
+You may distribute under the terms of either the GNU General Public License or
+the Artistic License, as specified in the Perl README file.
+
+=cut
Added: branches/upstream/libtest-mockmodule-perl/current/t/mockmodule.t
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/t/mockmodule.t?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/t/mockmodule.t (added)
+++ branches/upstream/libtest-mockmodule-perl/current/t/mockmodule.t Sat Jan 26 08:13:57 2008
@@ -1,0 +1,149 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 41;
+
+require_ok('Test::MockModule');
+
+package Test_Package;
+our $VERSION=1;
+sub listify {
+ my ($lower, $upper) = @_;
+ return ($lower .. $upper);
+}
+package main;
+
+# new()
+ok(Test::MockModule->can('new'), 'new()');
+eval {Test::MockModule->new('Test::MockModule')};
+like($@, qr/Cannot mock Test::MockModule/, '... cannot mock itself');
+eval {Test::MockModule->new('12Monkeys')};
+like($@, qr/Invalid package name/, ' ... croaks if package looks invalid');
+eval {Test::MockModule->new()};
+like($@, qr/Invalid package name/, ' ... croaks if package is undefined');
+
+{
+ {
+ Test::MockModule->new('CGI', no_auto => 1);
+ ok(!$INC{'CGI.pm'}, '... no_auto prevents module being loaded');
+ }
+
+ my $mcgi = Test::MockModule->new('CGI');
+ ok($INC{'CGI.pm'}, '... module loaded if !$VERSION');
+ ok($mcgi->isa('Test::MockModule'), '... returns a Test::MockModule object');
+ my $mcgi2 = Test::MockModule->new('CGI');
+ is($mcgi, $mcgi2,
+ "... returns existing object if there's already one for the package");
+
+ # get_package()
+ ok($mcgi->can('get_package'), 'get_package');
+ is($mcgi->get_package, 'CGI', '... returns the package name');
+
+ # mock()
+ # prime CGI routines
+ CGI->Vars; CGI->param;
+
+ ok($mcgi->can('mock'), 'mock()');
+ eval {$mcgi->mock(q[p-ram])};
+
+ like($@, qr/Invalid subroutine name: /,
+ '... dies if a subroutine name is invalid');
+
+ my $orig_param = \&CGI::param;
+ $mcgi->mock('param', sub {return qw(abc def)});
+ my @params = CGI::param();
+ is_deeply(\@params, ['abc', 'def'],
+ '... replaces the subroutine with a mocked sub');
+
+ $mcgi->mock('param' => undef);
+ @params = CGI::param();
+ is_deeply(\@params, [], '... which is an empty sub if !defined');
+
+ $mcgi->mock(param => 'The quick brown fox jumped over the lazy dog');
+ my $a2z = CGI::param();
+ is($a2z, 'The quick brown fox jumped over the lazy dog',
+ '... or a subroutine returning the supplied value');
+
+ my $ref = [1,2,3];
+ $mcgi->mock(param => $ref);
+ @params = CGI::param();
+ is($params[0], $ref,
+ '... given a reference, install a sub that returns said reference');
+
+ my $blessed_code = bless sub { return 'Hello World' }, 'FOO';
+ $mcgi->mock(param => $blessed_code);
+ @params = CGI::param();
+ is($params[0], 'Hello World', '... a blessed coderef is properly detected');
+
+ $mcgi->mock(Just => 'another', Perl => 'Hacker');
+ @params = (CGI::Just(), CGI::Perl());
+ is_deeply(\@params, ['another', 'Hacker'],
+ '... can mock multiple subroutines at a time');
+
+
+ # original()
+ ok($mcgi->can('original'), 'original()');
+ is($mcgi->original('param'), $orig_param,
+ '... returns the original subroutine');
+ my ($warn);
+ local $SIG{__WARN__} = sub {$warn = shift};
+ $mcgi->original('Vars');
+ like($warn, qr/ is not mocked/, "... warns if a subroutine isn't mocked");
+
+ # unmock()
+ ok($mcgi->can('unmock'), 'unmock()');
+ eval {$mcgi->unmock('V at rs')};
+ like($@, qr/Invalid subroutine name/,
+ '... dies if the subroutine is invalid');
+
+ $warn = '';
+ $mcgi->unmock('Vars');
+ like($warn, qr/ was not mocked/, "... warns if a subroutine isn't mocked");
+
+ $mcgi->unmock('param');
+ is(\&{"CGI::param"}, $orig_param, '... restores the original subroutine');
+
+ # unmock_all()
+ ok($mcgi->can('unmock_all'), 'unmock_all');
+ $mcgi->mock('Vars' => sub {1}, param => sub {2});
+ ok(CGI::Vars() == 1 && CGI::param() == 2,
+ 'mock: can mock multiple subroutines');
+ my @orig = ($mcgi->original('Vars'), $mcgi->original('param'));
+ $mcgi->unmock_all();
+ ok(\&CGI::Vars eq $orig[0] && \&CGI::param eq $orig[1],
+ '... removes all mocked subroutines');
+
+ # is_mocked()
+ ok($mcgi->can('is_mocked'), 'is_mocked');
+ ok(!$mcgi->is_mocked('param'), '... returns false for non-mocked sub');
+ $mcgi->mock('param', sub { return 'This sub is mocked' });
+ is(CGI::param(), 'This sub is mocked', '... mocked params');
+ ok($mcgi->is_mocked('param'), '... returns true for non-mocked sub');
+}
+
+isnt(CGI::param(), 'This sub is mocked',
+ '... params is unmocked when object goes out of scope');
+
+# test inherited methods
+package Test_Parent;
+sub method { 1 }
+package Test_Child;
+ at Test_Child::ISA = 'Test_Parent';
+package main;
+
+my $test_mock = Test::MockModule->new('Test_Child', no_auto => 1);
+ok(Test_Child->can('method'), 'test class inherits from parent');
+$test_mock->mock('method' => sub {2});
+is(Test_Child->method, 2, 'mocked subclass method');
+$test_mock->unmock('method');
+ok(Test_Child->can('method'), 'unmocked subclass method still exists');
+is(Test_Child->method, 1, 'mocked subclass method');
+
+# test restoring non-existant functions
+$test_mock->mock(ISA => sub {'basic test'});
+can_ok(Test_Child => 'ISA');
+is(Test_Child::ISA(), 'basic test',
+ "testing a mocked sub that didn't exist before");
+$test_mock->unmock('ISA');
+ok(!Test_Child->can('ISA') && $Test_Child::ISA[0] eq 'Test_Parent',
+ "restoring an undefined sub doesn't clear out the rest of the symbols");
+
Propchange: branches/upstream/libtest-mockmodule-perl/current/t/mockmodule.t
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libtest-mockmodule-perl/current/t/pod.t
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/t/pod.t?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/t/pod.t (added)
+++ branches/upstream/libtest-mockmodule-perl/current/t/pod.t Sat Jan 26 08:13:57 2008
@@ -1,0 +1,6 @@
+#!/usr/bin/perl
+#$Id: pod.t,v 1.1.1.1 2004/11/28 23:38:28 simonflack Exp $
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
Propchange: branches/upstream/libtest-mockmodule-perl/current/t/pod.t
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libtest-mockmodule-perl/current/t/pod_coverage.t
URL: http://svn.debian.org/wsvn/branches/upstream/libtest-mockmodule-perl/current/t/pod_coverage.t?rev=13591&op=file
==============================================================================
--- branches/upstream/libtest-mockmodule-perl/current/t/pod_coverage.t (added)
+++ branches/upstream/libtest-mockmodule-perl/current/t/pod_coverage.t Sat Jan 26 08:13:57 2008
@@ -1,0 +1,6 @@
+#!/usr/bin/perl
+#$Id: pod_coverage.t,v 1.1 2005/03/24 22:23:38 simonflack Exp $
+use Test::More;
+eval "use Test::Pod::Coverage 1.00";
+plan skip_all => "Test::Pod::Coverage 1.00 required for testing pod coverage" if $@;
+all_pod_coverage_ok({also_private => [qr/^TRACE(?:F|_HERE)?|DUMP$/]});
Propchange: branches/upstream/libtest-mockmodule-perl/current/t/pod_coverage.t
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-perl-cvs-commits
mailing list