1 | package Sub::Override;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use warnings;
|
---|
5 |
|
---|
6 | our $VERSION = '0.08';
|
---|
7 |
|
---|
8 | my $_croak = sub {
|
---|
9 | local *__ANON__ = '__ANON__croak';
|
---|
10 | my ( $proto, $message ) = @_;
|
---|
11 | require Carp;
|
---|
12 | Carp::croak($message);
|
---|
13 | };
|
---|
14 |
|
---|
15 | my $_validate_code_slot = sub {
|
---|
16 | local *__ANON__ = '__ANON__validate_code_slot';
|
---|
17 | my ( $self, $code_slot ) = @_;
|
---|
18 | no strict 'refs';
|
---|
19 | unless ( defined *{$code_slot}{CODE} ) {
|
---|
20 | $self->$_croak("Cannot replace non-existent sub ($code_slot)");
|
---|
21 | }
|
---|
22 | return $self;
|
---|
23 | };
|
---|
24 |
|
---|
25 | my $_validate_sub_ref = sub {
|
---|
26 | local *__ANON__ = '__ANON__validate_sub_ref';
|
---|
27 | my ( $self, $sub_ref ) = @_;
|
---|
28 | unless ( 'CODE' eq ref $sub_ref ) {
|
---|
29 | $self->$_croak("($sub_ref) must be a code reference");
|
---|
30 | }
|
---|
31 | return $self;
|
---|
32 | };
|
---|
33 |
|
---|
34 | my $_normalize_sub_name = sub {
|
---|
35 | local *__ANON__ = '__ANON__normalize_sub_name';
|
---|
36 | my ( $self, $subname ) = @_;
|
---|
37 | if ( ( $subname || '' ) =~ /^\w+$/ ) { # || "" for suppressing test warnings
|
---|
38 | my $package = do {
|
---|
39 | my $call_level = 0;
|
---|
40 | my $this_package;
|
---|
41 | while ( !$this_package || __PACKAGE__ eq $this_package ) {
|
---|
42 | ($this_package) = caller($call_level);
|
---|
43 | $call_level++;
|
---|
44 | }
|
---|
45 | $this_package;
|
---|
46 | };
|
---|
47 | $subname = "${package}::$subname";
|
---|
48 | }
|
---|
49 | return $subname;
|
---|
50 | };
|
---|
51 |
|
---|
52 | sub new {
|
---|
53 | my $class = shift;
|
---|
54 | my $self = bless {}, $class;
|
---|
55 | $self->replace(@_) if @_;
|
---|
56 | return $self;
|
---|
57 | }
|
---|
58 |
|
---|
59 | # because override() was a better name and this is what it should have been
|
---|
60 | # called.
|
---|
61 | *override = *replace{CODE};
|
---|
62 |
|
---|
63 | sub replace {
|
---|
64 | my ( $self, $sub_to_replace, $new_sub ) = @_;
|
---|
65 | $sub_to_replace = $self->$_normalize_sub_name($sub_to_replace);
|
---|
66 | $self->$_validate_code_slot($sub_to_replace)->$_validate_sub_ref($new_sub);
|
---|
67 | {
|
---|
68 | no strict 'refs';
|
---|
69 | $self->{$sub_to_replace} ||= *$sub_to_replace{CODE};
|
---|
70 | no warnings 'redefine';
|
---|
71 | *$sub_to_replace = $new_sub;
|
---|
72 | }
|
---|
73 | return $self;
|
---|
74 | }
|
---|
75 |
|
---|
76 | sub restore {
|
---|
77 | my ( $self, $name_of_sub ) = @_;
|
---|
78 | $name_of_sub = $self->$_normalize_sub_name($name_of_sub);
|
---|
79 | if ( !$name_of_sub && 1 == keys %$self ) {
|
---|
80 | ($name_of_sub) = keys %$self;
|
---|
81 | }
|
---|
82 | $self->$_croak(
|
---|
83 | sprintf 'You must provide the name of a sub to restore: (%s)' => join
|
---|
84 | ', ' => sort keys %$self )
|
---|
85 | unless $name_of_sub;
|
---|
86 | $self->$_croak("Cannot restore a sub that was not replaced ($name_of_sub)")
|
---|
87 | unless exists $self->{$name_of_sub};
|
---|
88 | no strict 'refs';
|
---|
89 | no warnings 'redefine';
|
---|
90 | *$name_of_sub = delete $self->{$name_of_sub};
|
---|
91 | return $self;
|
---|
92 | }
|
---|
93 |
|
---|
94 | sub DESTROY {
|
---|
95 | my $self = shift;
|
---|
96 | no strict 'refs';
|
---|
97 | no warnings 'redefine';
|
---|
98 | while ( my ( $sub_name, $sub_ref ) = each %$self ) {
|
---|
99 | *$sub_name = $sub_ref;
|
---|
100 | }
|
---|
101 | }
|
---|
102 |
|
---|
103 | 1;
|
---|
104 |
|
---|
105 | __END__
|
---|
106 |
|
---|
107 | =head1 NAME
|
---|
108 |
|
---|
109 | Sub::Override - Perl extension for easily overriding subroutines
|
---|
110 |
|
---|
111 | =head1 SYNOPSIS
|
---|
112 |
|
---|
113 | use Sub::Override;
|
---|
114 |
|
---|
115 | sub foo { 'original sub' };
|
---|
116 | print foo(); # prints 'original sub'
|
---|
117 |
|
---|
118 | my $override = Sub::Override->new( foo => sub { 'overridden sub' } );
|
---|
119 | print foo(); # prints 'overridden sub'
|
---|
120 | $override->restore;
|
---|
121 | print foo(); # prints 'original sub'
|
---|
122 |
|
---|
123 | =head1 DESCRIPTION
|
---|
124 |
|
---|
125 | =head2 The Problem
|
---|
126 |
|
---|
127 | Sometimes subroutines need to be overridden. In fact, your author does this
|
---|
128 | constantly for tests. Particularly when testing, using a Mock Object can be
|
---|
129 | overkill when all you want to do is override one tiny, little function.
|
---|
130 |
|
---|
131 | Overriding a subroutine is often done with syntax similar to the following.
|
---|
132 |
|
---|
133 | {
|
---|
134 | local *Some::sub = sub {'some behavior'};
|
---|
135 | # do something
|
---|
136 | }
|
---|
137 | # original subroutine behavior restored
|
---|
138 |
|
---|
139 | This has a few problems.
|
---|
140 |
|
---|
141 | {
|
---|
142 | local *Get::some_feild = { 'some behavior' };
|
---|
143 | # do something
|
---|
144 | }
|
---|
145 |
|
---|
146 | In the above example, not only have we probably mispelled the subroutine name,
|
---|
147 | but even if their had been a subroutine with that name, we haven't overridden
|
---|
148 | it. These two bugs can be subtle to detect.
|
---|
149 |
|
---|
150 | Further, if we're attempting to localize the effect by placing this code in a
|
---|
151 | block, the entire construct is cumbersome.
|
---|
152 |
|
---|
153 | Hook::LexWrap also allows us to override sub behavior, but I can never remember
|
---|
154 | the exact syntax.
|
---|
155 |
|
---|
156 | =head2 An easier way to replace subroutines
|
---|
157 |
|
---|
158 | Instead, C<Sub::Override> allows the programmer to simply name the sub to
|
---|
159 | replace and to supply a sub to replace it with.
|
---|
160 |
|
---|
161 | my $override = Sub::Override->new('Some::sub', sub {'new data'});
|
---|
162 |
|
---|
163 | # which is equivalent to:
|
---|
164 | my $override = Sub::Override->new;
|
---|
165 | $override->replace('Some::sub', sub { 'new data' });
|
---|
166 |
|
---|
167 | You can replace multiple subroutines, if needed:
|
---|
168 |
|
---|
169 | $override->replace('Some::sub1', sub { 'new data1' });
|
---|
170 | $override->replace('Some::sub2', sub { 'new data2' });
|
---|
171 | $override->replace('Some::sub3', sub { 'new data3' });
|
---|
172 |
|
---|
173 | If replacing the subroutine succeeds, the object is returned. This allows the
|
---|
174 | programmer to chain the calls, if this style of programming is preferred:
|
---|
175 |
|
---|
176 | $override->replace('Some::sub1', sub { 'new data1' })
|
---|
177 | ->replace('Some::sub2', sub { 'new data2' })
|
---|
178 | ->replace('Some::sub3', sub { 'new data3' });
|
---|
179 |
|
---|
180 | A subroutine may be replaced as many times as desired. This is most useful
|
---|
181 | when testing how code behaves with multiple conditions.
|
---|
182 |
|
---|
183 | $override->replace('Some::thing', sub { 0 });
|
---|
184 | is($object->foo, 'wibble', 'wibble is returned if Some::thing is false');
|
---|
185 |
|
---|
186 | $override->replace('Some::thing', sub { 1 });
|
---|
187 | is($object->foo, 'puppies', 'puppies are returned if Some::thing is true');
|
---|
188 |
|
---|
189 | =head2 Restoring subroutines
|
---|
190 |
|
---|
191 | If the object falls out of scope, the original subs are restored. However, if
|
---|
192 | you need to restore a subroutine early, just use the restore method:
|
---|
193 |
|
---|
194 | my $override = Sub::Override->new('Some::sub', sub {'new data'});
|
---|
195 | # do stuff
|
---|
196 | $override->restore;
|
---|
197 |
|
---|
198 | Which is somewhat equivalent to:
|
---|
199 |
|
---|
200 | {
|
---|
201 | my $override = Sub::Override->new('Some::sub', sub {'new data'});
|
---|
202 | # do stuff
|
---|
203 | }
|
---|
204 |
|
---|
205 | If you have override more than one subroutine with an override object, you
|
---|
206 | will have to explicitly name the subroutine you wish to restore:
|
---|
207 |
|
---|
208 | $override->restore('This::sub');
|
---|
209 |
|
---|
210 | Note C<restore()> will always restore the original behavior of the subroutine
|
---|
211 | no matter how many times you have overridden it.
|
---|
212 |
|
---|
213 | =head2 Which package is the subroutine in?
|
---|
214 |
|
---|
215 | Ordinarily, you want to fully qualify the subroutine by including the package
|
---|
216 | name. However, failure to fully qualify the subroutine name will assume the
|
---|
217 | current package.
|
---|
218 |
|
---|
219 | package Foo;
|
---|
220 | use Sub::Override;
|
---|
221 | sub foo { 23 };
|
---|
222 | my $override = Sub::Override->new( foo => sub { 42 } ); # assumes Foo::foo
|
---|
223 | print foo(); # prints 42
|
---|
224 | $override->restore;
|
---|
225 | print foo(); # prints 23
|
---|
226 |
|
---|
227 | =head1 METHODS
|
---|
228 |
|
---|
229 | =head2 new
|
---|
230 |
|
---|
231 | my $sub = Sub::Override->new;
|
---|
232 | my $sub = Sub::Override->new($sub_name, $sub_ref);
|
---|
233 |
|
---|
234 | Creates a new C<Sub::Override> instance. Optionally, you may override a
|
---|
235 | subroutine while creating a new object.
|
---|
236 |
|
---|
237 | =head2 replace
|
---|
238 |
|
---|
239 | $sub->replace($sub_name, $sub_body);
|
---|
240 |
|
---|
241 | Temporarily replaces a subroutine with another subroutine. Returns the
|
---|
242 | instance, so chaining the method is allowed:
|
---|
243 |
|
---|
244 | $sub->replace($sub_name, $sub_body)
|
---|
245 | ->replace($another_sub, $another_body);
|
---|
246 |
|
---|
247 | This method will C<croak> is the subroutine to be replaced does not exist.
|
---|
248 |
|
---|
249 | =head2 override
|
---|
250 |
|
---|
251 | my $sub = Sub::Override->new;
|
---|
252 | $sub->override($sub_name, $sub_body);
|
---|
253 |
|
---|
254 | C<override> is an alternate name for C<replace>. They are the same method.
|
---|
255 |
|
---|
256 | =cut
|
---|
257 |
|
---|
258 | =head2 restore
|
---|
259 |
|
---|
260 | $sub->restore($sub_name);
|
---|
261 |
|
---|
262 | Restores the previous behavior of the subroutine. This will happen
|
---|
263 | automatically if the C<Sub::Override> object falls out of scope.
|
---|
264 |
|
---|
265 | =cut
|
---|
266 |
|
---|
267 | =head1 EXPORT
|
---|
268 |
|
---|
269 | None by default.
|
---|
270 |
|
---|
271 | =head1 BUGS
|
---|
272 |
|
---|
273 | Probably. Tell me about 'em.
|
---|
274 |
|
---|
275 | =head1 SEE ALSO
|
---|
276 |
|
---|
277 | =over 4
|
---|
278 |
|
---|
279 | =item *
|
---|
280 | Hook::LexWrap -- can also override subs, but with different capabilities
|
---|
281 |
|
---|
282 | =item *
|
---|
283 | Test::MockObject -- use this if you need to alter an entire class
|
---|
284 |
|
---|
285 | =back
|
---|
286 |
|
---|
287 | =head1 AUTHOR
|
---|
288 |
|
---|
289 | Curtis "Ovid" Poe, C<< <ovid [at] cpan [dot] org> >>
|
---|
290 |
|
---|
291 | Reverse the name to email me.
|
---|
292 |
|
---|
293 | =head1 COPYRIGHT AND LICENSE
|
---|
294 |
|
---|
295 | Copyright (C) 2004-2005 by Curtis "Ovid" Poe
|
---|
296 |
|
---|
297 | This library is free software; you can redistribute it and/or modify
|
---|
298 | it under the same terms as Perl itself, either Perl version 5.8.2 or,
|
---|
299 | at your option, any later version of Perl 5 you may have available.
|
---|
300 |
|
---|
301 |
|
---|
302 | =cut
|
---|