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 | _replace_sub | Test::MockModule::
1 | 1 | 1 | 62µs | 1.32ms | unmock | Test::MockModule::
1 | 1 | 1 | 51µs | 126µs | mock | Test::MockModule::
1 | 1 | 1 | 30µs | 51µs | new | Test::MockModule::
4 | 3 | 1 | 28µs | 28µs | CORE:match (opcode) | Test::MockModule::
1 | 1 | 1 | 24µs | 1.34ms | unmock_all | Test::MockModule::
2 | 2 | 1 | 19µs | 19µs | _full_name | Test::MockModule::
1 | 1 | 1 | 17µs | 1.36ms | DESTROY | Test::MockModule::
2 | 2 | 1 | 16µs | 25µs | _valid_subname | Test::MockModule::
1 | 1 | 1 | 14µs | 30µs | BEGIN@3 | Test::MockModule::
6 | 6 | 1 | 10µs | 10µs | TRACE | Test::MockModule::
1 | 1 | 1 | 9µs | 37µs | BEGIN@4 | Test::MockModule::
1 | 1 | 1 | 9µs | 18µs | _valid_package | Test::MockModule::
1 | 1 | 1 | 7µs | 36µs | BEGIN@5 | Test::MockModule::
1 | 1 | 1 | 7µs | 39µs | BEGIN@6 | Test::MockModule::
0 | 0 | 0 | 0s | 0s | DUMP | Test::MockModule::
0 | 0 | 0 | 0s | 0s | __ANON__[:131] | Test::MockModule::
0 | 0 | 0 | 0s | 0s | __ANON__[:53] | Test::MockModule::
0 | 0 | 0 | 0s | 0s | __ANON__[:57] | Test::MockModule::
0 | 0 | 0 | 0s | 0s | get_package | Test::MockModule::
0 | 0 | 0 | 0s | 0s | is_mocked | Test::MockModule::
0 | 0 | 0 | 0s | 0s | original | Test::MockModule::
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 | 11 | 35µs | my $class = shift; | ||
12 | my ($package, %args) = @_; | ||||
13 | if ($package && (my $existing = $mocked{$package})) { | ||||
14 | return $existing; | ||||
15 | } | ||||
16 | |||||
17 | croak "Cannot mock $package" if $package && $package eq $class; | ||||
18 | 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 | 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 | 2µs | TRACE("Creating MockModule object for $package"); # spent 2µs making 1 call to Test::MockModule::TRACE | ||
30 | my $self = bless { | ||||
31 | _package => $package, | ||||
32 | _mocked => {}, | ||||
33 | }, $class; | ||||
34 | $mocked{$package} = $self; | ||||
35 | 1 | 1µs | weaken $mocked{$package}; # spent 1µs making 1 call to Scalar::Util::weaken | ||
36 | 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 | 2 | 14µs | my $self = shift; | ||
41 | 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 | 2 | 9µs | my $self = shift; | ||
51 | |||||
52 | 8 | 23µs | while (my ($name, $value) = splice @_, 0, 2) { | ||
53 | my $code = sub { }; | ||||
54 | 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 | 500ns | TRACE("$name: $code"); # spent 500ns making 1 call to Test::MockModule::TRACE | ||
61 | 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 | 5µs | my $sub_name = _full_name($self, $name); # spent 5µs making 1 call to Test::MockModule::_full_name | ||
63 | 3 | 59µs | if (!$self->{_mocked}{$name}) { | ||
64 | 1 | 600ns | TRACE("Storing existing $sub_name"); # spent 600ns making 1 call to Test::MockModule::TRACE | ||
65 | $self->{_mocked}{$name} = 1; | ||||
66 | 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 | 600ns | TRACE("Installing mocked $sub_name"); # spent 600ns making 1 call to Test::MockModule::TRACE | ||
70 | 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 | 3 | 12µs | my $self = shift; | ||
84 | |||||
85 | for my $name (@_) { | ||||
86 | 7 | 34µ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 | 13µs | my $sub_name = _full_name($self, $name); # spent 13µs making 1 call to Test::MockModule::_full_name | ||
89 | unless ($self->{_mocked}{$name}) { | ||||
90 | carp $sub_name . " was not mocked"; | ||||
91 | next; | ||||
92 | } | ||||
93 | |||||
94 | 1 | 4µs | TRACE("Restoring original $sub_name"); # spent 4µs making 1 call to Test::MockModule::TRACE | ||
95 | 1 | 1.22ms | _replace_sub($sub_name, $self->{_orig}{$name}); # spent 1.22ms making 1 call to Test::MockModule::_replace_sub | ||
96 | delete $self->{_mocked}{$name}; | ||||
97 | delete $self->{_orig}{$name}; | ||||
98 | } | ||||
99 | 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 | 2 | 18µs | my $self = shift; | ||
104 | 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 | 4 | 25µs | my ($self, $sub_name) = @_; | ||
117 | 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 | 6 | 48µs | my ($sub_name, $coderef) = @_; | ||
130 | # from Test::MockObject | ||||
131 | local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /redefined/ }; | ||||
132 | 8 | 1.16ms | if (defined $coderef) { | ||
133 | *{$sub_name} = $coderef; | ||||
134 | } else { | ||||
135 | 1 | 2µs | TRACE("removing subroutine: $sub_name"); # spent 2µs making 1 call to Test::MockModule::TRACE | ||
136 | 1 | 10µs | my ($package, $sub) = $sub_name =~ /(.*::)(.*)/; # spent 10µs making 1 call to Test::MockModule::CORE:match | ||
137 | my %symbols = %{$package}; | ||||
138 | |||||
139 | # save a copy of all non-code slots | ||||
140 | my %slot; | ||||
141 | foreach (qw(ARRAY FORMAT HASH IO SCALAR)) { | ||||
142 | 6 | 20µs | next unless defined(my $elem = *{$symbols{$sub}}{$_}); | ||
143 | $slot{$_} = $elem; | ||||
144 | } | ||||
145 | |||||
146 | # clear the symbol table entry for the subroutine | ||||
147 | undef *$sub_name; | ||||
148 | |||||
149 | # restore everything except the code slot | ||||
150 | return unless keys %slot; | ||||
151 | 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 |