| Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Test/MockModule.pm |
| Statements | Executed 88 statements in 2.47ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 2 | 2 | 1 | 1.22ms | 1.23ms | Test::MockModule::_replace_sub |
| 1 | 1 | 1 | 62µs | 1.32ms | Test::MockModule::unmock |
| 1 | 1 | 1 | 51µs | 126µs | Test::MockModule::mock |
| 1 | 1 | 1 | 30µs | 51µs | Test::MockModule::new |
| 4 | 3 | 1 | 28µs | 28µs | Test::MockModule::CORE:match (opcode) |
| 1 | 1 | 1 | 24µs | 1.34ms | Test::MockModule::unmock_all |
| 2 | 2 | 1 | 19µs | 19µs | Test::MockModule::_full_name |
| 1 | 1 | 1 | 17µs | 1.36ms | Test::MockModule::DESTROY |
| 2 | 2 | 1 | 16µs | 25µs | Test::MockModule::_valid_subname |
| 1 | 1 | 1 | 14µs | 30µs | Test::MockModule::BEGIN@3 |
| 6 | 6 | 1 | 10µs | 10µs | Test::MockModule::TRACE |
| 1 | 1 | 1 | 9µs | 37µs | Test::MockModule::BEGIN@4 |
| 1 | 1 | 1 | 9µs | 18µs | Test::MockModule::_valid_package |
| 1 | 1 | 1 | 7µs | 36µs | Test::MockModule::BEGIN@5 |
| 1 | 1 | 1 | 7µs | 39µs | Test::MockModule::BEGIN@6 |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::DUMP |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::__ANON__[:131] |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::__ANON__[:53] |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::__ANON__[:57] |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::get_package |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::is_mocked |
| 0 | 0 | 0 | 0s | 0s | Test::MockModule::original |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | # $Id: MockModule.pm,v 1.7 2005/03/24 22:23:38 simonflack Exp $ | ||||
| 2 | package Test::MockModule; | ||||
| 3 | 3 | 22µs | 2 | 45µs | # spent 30µs (14+16) within Test::MockModule::BEGIN@3 which was called:
# once (14µs+16µs) by main::BEGIN@23 at line 3 # spent 30µs making 1 call to Test::MockModule::BEGIN@3
# spent 16µs making 1 call to strict::import |
| 4 | 3 | 23µs | 2 | 64µs | # spent 37µs (9+27) within Test::MockModule::BEGIN@4 which was called:
# once (9µs+27µs) by main::BEGIN@23 at line 4 # spent 37µs making 1 call to Test::MockModule::BEGIN@4
# spent 27µs making 1 call to vars::import |
| 5 | 3 | 18µs | 2 | 65µs | # spent 36µs (7+29) within Test::MockModule::BEGIN@5 which was called:
# once (7µs+29µs) by main::BEGIN@23 at line 5 # spent 36µs making 1 call to Test::MockModule::BEGIN@5
# spent 29µs making 1 call to Exporter::import |
| 6 | 3 | 854µs | 2 | 72µs | # spent 39µs (7+32) within Test::MockModule::BEGIN@6 which was called:
# once (7µs+32µs) by main::BEGIN@23 at line 6 # spent 39µs making 1 call to Test::MockModule::BEGIN@6
# spent 32µs making 1 call to Exporter::import |
| 7 | 1 | 500ns | $VERSION = '0.05';#sprintf'%d.%02d', q$Revision: 1.7 $ =~ /: (\d+)\.(\d+)/; | ||
| 8 | |||||
| 9 | 1 | 100ns | my %mocked; | ||
| 10 | # spent 51µs (30+21) within Test::MockModule::new which was called:
# once (30µs+21µs) by main::RUNTIME at line 50 of xt/tapper-mcp-scheduler-with-db-longrun.t | ||||
| 11 | 1 | 1µs | my $class = shift; | ||
| 12 | 1 | 2µs | my ($package, %args) = @_; | ||
| 13 | 1 | 1µs | if ($package && (my $existing = $mocked{$package})) { | ||
| 14 | return $existing; | ||||
| 15 | } | ||||
| 16 | |||||
| 17 | 1 | 700ns | croak "Cannot mock $package" if $package && $package eq $class; | ||
| 18 | 1 | 3µs | 1 | 18µs | unless (_valid_package($package)) { # spent 18µs making 1 call to Test::MockModule::_valid_package |
| 19 | $package = 'undef' unless defined $package; | ||||
| 20 | croak "Invalid package name $package"; | ||||
| 21 | } | ||||
| 22 | |||||
| 23 | 1 | 6µs | unless ($args{no_auto} || ${"$package\::VERSION"}) { | ||
| 24 | (my $load_package = "$package.pm") =~ s{::}{/}g; | ||||
| 25 | TRACE("$package is empty, loading $load_package"); | ||||
| 26 | require $load_package; | ||||
| 27 | } | ||||
| 28 | |||||
| 29 | 1 | 3µs | 1 | 2µs | TRACE("Creating MockModule object for $package"); # spent 2µs making 1 call to Test::MockModule::TRACE |
| 30 | 1 | 5µs | my $self = bless { | ||
| 31 | _package => $package, | ||||
| 32 | _mocked => {}, | ||||
| 33 | }, $class; | ||||
| 34 | 1 | 1µs | $mocked{$package} = $self; | ||
| 35 | 1 | 4µs | 1 | 1µs | weaken $mocked{$package}; # spent 1µs making 1 call to Scalar::Util::weaken |
| 36 | 1 | 8µs | return $self; | ||
| 37 | } | ||||
| 38 | |||||
| 39 | # spent 1.36ms (17µs+1.34) within Test::MockModule::DESTROY which was called:
# once (17µs+1.34ms) by main::NULL at line 0 of xt/tapper-mcp-scheduler-with-db-longrun.t | ||||
| 40 | 1 | 1µs | my $self = shift; | ||
| 41 | 1 | 13µs | 1 | 1.34ms | $self->unmock_all; # spent 1.34ms making 1 call to Test::MockModule::unmock_all |
| 42 | } | ||||
| 43 | |||||
| 44 | sub get_package { | ||||
| 45 | my $self = shift; | ||||
| 46 | return $self->{_package}; | ||||
| 47 | } | ||||
| 48 | |||||
| 49 | # spent 126µs (51+75) within Test::MockModule::mock which was called:
# once (51µs+75µs) by main::RUNTIME at line 51 of xt/tapper-mcp-scheduler-with-db-longrun.t | ||||
| 50 | 1 | 500ns | my $self = shift; | ||
| 51 | |||||
| 52 | 1 | 8µs | while (my ($name, $value) = splice @_, 0, 2) { | ||
| 53 | 1 | 2µs | my $code = sub { }; | ||
| 54 | 1 | 9µs | 1 | 1µs | if (ref $value && reftype $value eq 'CODE') { # spent 1µs making 1 call to Scalar::Util::reftype |
| 55 | $code = $value; | ||||
| 56 | } elsif (defined $value) { | ||||
| 57 | $code = sub {$value}; | ||||
| 58 | } | ||||
| 59 | |||||
| 60 | 1 | 2µs | 1 | 500ns | TRACE("$name: $code"); # spent 500ns making 1 call to Test::MockModule::TRACE |
| 61 | 1 | 2µs | 1 | 5µs | croak "Invalid subroutine name: $name" unless _valid_subname($name); # spent 5µs making 1 call to Test::MockModule::_valid_subname |
| 62 | 1 | 2µs | 1 | 5µs | my $sub_name = _full_name($self, $name); # spent 5µs making 1 call to Test::MockModule::_full_name |
| 63 | 1 | 1µs | if (!$self->{_mocked}{$name}) { | ||
| 64 | 1 | 2µs | 1 | 600ns | TRACE("Storing existing $sub_name"); # spent 600ns making 1 call to Test::MockModule::TRACE |
| 65 | 1 | 1µs | $self->{_mocked}{$name} = 1; | ||
| 66 | 1 | 56µs | 1 | 47µs | $self->{_orig}{$name} = defined &{$sub_name} ? \&$sub_name # spent 47µs making 1 call to UNIVERSAL::can |
| 67 | : $self->{_package}->can($name); | ||||
| 68 | } | ||||
| 69 | 1 | 2µs | 1 | 600ns | TRACE("Installing mocked $sub_name"); # spent 600ns making 1 call to Test::MockModule::TRACE |
| 70 | 1 | 2µs | 1 | 15µs | _replace_sub($sub_name, $code); # spent 15µs making 1 call to Test::MockModule::_replace_sub |
| 71 | } | ||||
| 72 | } | ||||
| 73 | |||||
| 74 | sub original { | ||||
| 75 | my $self = shift; | ||||
| 76 | my ($name) = @_; | ||||
| 77 | return carp _full_name($self, $name) . " is not mocked" | ||||
| 78 | unless $self->{_mocked}{$name}; | ||||
| 79 | return $self->{_orig}{$name}; | ||||
| 80 | } | ||||
| 81 | |||||
| 82 | # spent 1.32ms (62µs+1.26) within Test::MockModule::unmock which was called:
# once (62µs+1.26ms) by Test::MockModule::unmock_all at line 105 | ||||
| 83 | 1 | 1µs | my $self = shift; | ||
| 84 | |||||
| 85 | 1 | 2µs | for my $name (@_) { | ||
| 86 | 1 | 5µs | 1 | 20µs | croak "Invalid subroutine name: $name" unless _valid_subname($name); # spent 20µs making 1 call to Test::MockModule::_valid_subname |
| 87 | |||||
| 88 | 1 | 5µs | 1 | 13µs | my $sub_name = _full_name($self, $name); # spent 13µs making 1 call to Test::MockModule::_full_name |
| 89 | 1 | 2µs | unless ($self->{_mocked}{$name}) { | ||
| 90 | carp $sub_name . " was not mocked"; | ||||
| 91 | next; | ||||
| 92 | } | ||||
| 93 | |||||
| 94 | 1 | 7µs | 1 | 4µs | TRACE("Restoring original $sub_name"); # spent 4µs making 1 call to Test::MockModule::TRACE |
| 95 | 1 | 7µs | 1 | 1.22ms | _replace_sub($sub_name, $self->{_orig}{$name}); # spent 1.22ms making 1 call to Test::MockModule::_replace_sub |
| 96 | 1 | 4µs | delete $self->{_mocked}{$name}; | ||
| 97 | 1 | 5µs | delete $self->{_orig}{$name}; | ||
| 98 | } | ||||
| 99 | 1 | 9µs | return $self; | ||
| 100 | } | ||||
| 101 | |||||
| 102 | # spent 1.34ms (24µs+1.32) within Test::MockModule::unmock_all which was called:
# once (24µs+1.32ms) by Test::MockModule::DESTROY at line 41 | ||||
| 103 | 1 | 1µs | my $self = shift; | ||
| 104 | 1 | 17µs | foreach (keys %{$self->{_mocked}}) { | ||
| 105 | 1 | 7µs | 1 | 1.32ms | $self->unmock($_); # spent 1.32ms making 1 call to Test::MockModule::unmock |
| 106 | } | ||||
| 107 | } | ||||
| 108 | |||||
| 109 | sub is_mocked { | ||||
| 110 | my $self = shift; | ||||
| 111 | my ($name) = shift; | ||||
| 112 | return $self->{_mocked}{$name}; | ||||
| 113 | } | ||||
| 114 | |||||
| 115 | sub _full_name { | ||||
| 116 | 2 | 3µs | my ($self, $sub_name) = @_; | ||
| 117 | 2 | 22µs | sprintf "%s::%s", $self->{_package}, $sub_name; | ||
| 118 | } | ||||
| 119 | |||||
| 120 | # spent 18µs (9+8) within Test::MockModule::_valid_package which was called:
# once (9µs+8µs) by Test::MockModule::new at line 18 | ||||
| 121 | 1 | 19µs | 1 | 8µs | defined($_[0]) && $_[0] =~ /^[a-z_]\w*(?:::\w+)*$/i; # spent 8µs making 1 call to Test::MockModule::CORE:match |
| 122 | } | ||||
| 123 | |||||
| 124 | sub _valid_subname { | ||||
| 125 | 2 | 31µs | 2 | 10µs | $_[0] =~ /^[a-z_]\w*$/i; # spent 10µs making 2 calls to Test::MockModule::CORE:match, avg 5µs/call |
| 126 | } | ||||
| 127 | |||||
| 128 | sub _replace_sub { | ||||
| 129 | 2 | 3µs | my ($sub_name, $coderef) = @_; | ||
| 130 | # from Test::MockObject | ||||
| 131 | 2 | 16µs | local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /redefined/ }; | ||
| 132 | 2 | 29µs | if (defined $coderef) { | ||
| 133 | *{$sub_name} = $coderef; | ||||
| 134 | } else { | ||||
| 135 | 1 | 5µs | 1 | 2µs | TRACE("removing subroutine: $sub_name"); # spent 2µs making 1 call to Test::MockModule::TRACE |
| 136 | 1 | 20µs | 1 | 10µs | my ($package, $sub) = $sub_name =~ /(.*::)(.*)/; # spent 10µs making 1 call to Test::MockModule::CORE:match |
| 137 | 1 | 971µs | my %symbols = %{$package}; | ||
| 138 | |||||
| 139 | # save a copy of all non-code slots | ||||
| 140 | 1 | 900ns | my %slot; | ||
| 141 | 1 | 6µs | foreach (qw(ARRAY FORMAT HASH IO SCALAR)) { | ||
| 142 | 5 | 13µs | next unless defined(my $elem = *{$symbols{$sub}}{$_}); | ||
| 143 | 1 | 5µs | $slot{$_} = $elem; | ||
| 144 | } | ||||
| 145 | |||||
| 146 | # clear the symbol table entry for the subroutine | ||||
| 147 | 1 | 9µs | undef *$sub_name; | ||
| 148 | |||||
| 149 | # restore everything except the code slot | ||||
| 150 | 1 | 2µs | return unless keys %slot; | ||
| 151 | 1 | 148µs | foreach (keys %slot) { | ||
| 152 | 1 | 7µs | *$sub_name = $slot{$_}; | ||
| 153 | } | ||||
| 154 | } | ||||
| 155 | } | ||||
| 156 | |||||
| 157 | # Log::Trace stubs | ||||
| 158 | 6 | 25µs | # spent 10µs within Test::MockModule::TRACE which was called 6 times, avg 2µs/call:
# once (4µs+0s) by Test::MockModule::unmock at line 94
# once (2µs+0s) by Test::MockModule::new at line 29
# once (2µs+0s) by Test::MockModule::_replace_sub at line 135
# once (600ns+0s) by Test::MockModule::mock at line 69
# once (600ns+0s) by Test::MockModule::mock at line 64
# once (500ns+0s) by Test::MockModule::mock at line 60 | ||
| 159 | sub DUMP {} | ||||
| 160 | |||||
| 161 | 1 | 3µs | 1; | ||
| 162 | |||||
| 163 | =pod | ||||
| 164 | |||||
| 165 | =head1 NAME | ||||
| 166 | |||||
| 167 | Test::MockModule - Override subroutines in a module for unit testing | ||||
| 168 | |||||
| 169 | =head1 SYNOPSIS | ||||
| 170 | |||||
| 171 | use Module::Name; | ||||
| 172 | use Test::MockModule; | ||||
| 173 | |||||
| 174 | { | ||||
| 175 | my $module = new Test::MockModule('Module::Name'); | ||||
| 176 | $module->mock('subroutine', sub { ... }); | ||||
| 177 | Module::Name::subroutine(@args); # mocked | ||||
| 178 | } | ||||
| 179 | |||||
| 180 | Module::Name::subroutine(@args); # original subroutine | ||||
| 181 | |||||
| 182 | =head1 DESCRIPTION | ||||
| 183 | |||||
| 184 | C<Test::MockModule> lets you temporarily redefine subroutines in other packages | ||||
| 185 | for the purposes of unit testing. | ||||
| 186 | |||||
| 187 | A C<Test::MockModule> object is set up to mock subroutines for a given | ||||
| 188 | module. The object remembers the original subroutine so it can be easily | ||||
| 189 | restored. This happens automatically when all MockModule objects for the given | ||||
| 190 | module go out of scope, or when you C<unmock()> the subroutine. | ||||
| 191 | |||||
| 192 | =head1 METHODS | ||||
| 193 | |||||
| 194 | =over 4 | ||||
| 195 | |||||
| 196 | =item new($package[, %options]) | ||||
| 197 | |||||
| 198 | Returns an object that will mock subroutines in the specified C<$package>. | ||||
| 199 | |||||
| 200 | If there is no C<$VERSION> defined in C<$package>, the module will be | ||||
| 201 | automatically loaded. You can override this behaviour by setting the C<no_auto> | ||||
| 202 | option: | ||||
| 203 | |||||
| 204 | my $mock = new Test::MockModule('Module::Name', no_auto => 1); | ||||
| 205 | |||||
| 206 | =item get_package() | ||||
| 207 | |||||
| 208 | Returns the target package name for the mocked subroutines | ||||
| 209 | |||||
| 210 | =item is_mocked($subroutine) | ||||
| 211 | |||||
| 212 | Returns a boolean value indicating whether or not the subroutine is currently | ||||
| 213 | mocked | ||||
| 214 | |||||
| 215 | =item mock($subroutine =E<gt> \E<amp>coderef) | ||||
| 216 | |||||
| 217 | Temporarily replaces one or more subroutines in the mocked module. A subroutine | ||||
| 218 | can be mocked with a code reference or a scalar. A scalar will be recast as a | ||||
| 219 | subroutine that returns the scalar. | ||||
| 220 | |||||
| 221 | The following statements are equivalent: | ||||
| 222 | |||||
| 223 | $module->mock(purge => 'purged'); | ||||
| 224 | $module->mock(purge => sub { return 'purged'}); | ||||
| 225 | |||||
| 226 | $module->mock(updated => [localtime()]); | ||||
| 227 | $module->mock(updated => sub { return [localtime()]}); | ||||
| 228 | |||||
| 229 | However, C<undef> is a special case. If you mock a subroutine with C<undef> it | ||||
| 230 | will install an empty subroutine | ||||
| 231 | |||||
| 232 | $module->mock(purge => undef); | ||||
| 233 | $module->mock(purge => sub { }); | ||||
| 234 | |||||
| 235 | rather than a subroutine that returns C<undef>: | ||||
| 236 | |||||
| 237 | $module->mock(purge => sub { undef }); | ||||
| 238 | |||||
| 239 | You can call C<mock()> for the same subroutine many times, but when you call | ||||
| 240 | C<unmock()>, the original subroutine is restored (not the last mocked | ||||
| 241 | instance). | ||||
| 242 | |||||
| 243 | =item original($subroutine) | ||||
| 244 | |||||
| 245 | Returns the original (unmocked) subroutine | ||||
| 246 | |||||
| 247 | =item unmock($subroutine [, ...]) | ||||
| 248 | |||||
| 249 | Restores the original C<$subroutine>. You can specify a list of subroutines to | ||||
| 250 | C<unmock()> in one go. | ||||
| 251 | |||||
| 252 | =item unmock_all() | ||||
| 253 | |||||
| 254 | Restores all the subroutines in the package that were mocked. This is | ||||
| 255 | automatically called when all C<Test::MockObject> objects for the given package | ||||
| 256 | go out of scope. | ||||
| 257 | |||||
| 258 | =back | ||||
| 259 | |||||
| 260 | =head1 SEE ALSO | ||||
| 261 | |||||
| 262 | L<Test::MockObject::Extends> | ||||
| 263 | |||||
| 264 | L<Sub::Override> | ||||
| 265 | |||||
| 266 | =head1 AUTHOR | ||||
| 267 | |||||
| 268 | Simon Flack E<lt>simonflk _AT_ cpan.orgE<gt> | ||||
| 269 | |||||
| 270 | =head1 COPYRIGHT | ||||
| 271 | |||||
| 272 | Copyright 2004 Simon Flack E<lt>simonflk _AT_ cpan.orgE<gt>. | ||||
| 273 | All rights reserved | ||||
| 274 | |||||
| 275 | You may distribute under the terms of either the GNU General Public License or | ||||
| 276 | the Artistic License, as specified in the Perl README file. | ||||
| 277 | |||||
| 278 | =cut | ||||
sub Test::MockModule::CORE:match; # opcode |