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