1package Sub::Defer;
2use strict;
3use warnings;
4use Exporter qw(import);
5use Scalar::Util qw(weaken);
6use Carp qw(croak);
7
8our $VERSION = '2.006006';
9$VERSION = eval $VERSION;
10
11our @EXPORT = qw(defer_sub undefer_sub undefer_all);
12our @EXPORT_OK = qw(undefer_package defer_info);
13
14sub _getglob { no strict 'refs'; \*{$_[0]} }
15
16BEGIN {
17  my $no_subname;
18  *_subname
19    = defined &Sub::Util::set_subname ? \&Sub::Util::set_subname
20    : defined &Sub::Name::subname     ? \&Sub::Name::subname
21    : (eval { require Sub::Util } && defined &Sub::Util::set_subname) ? \&Sub::Util::set_subname
22    : (eval { require Sub::Name } && defined &Sub::Name::subname    ) ? \&Sub::Name::subname
23    : ($no_subname = 1, sub { $_[1] });
24  *_CAN_SUBNAME = $no_subname ? sub(){0} : sub(){1};
25}
26
27sub _name_coderef {
28  shift if @_ > 2; # three args is (target, name, sub)
29  _CAN_SUBNAME ? _subname(@_) : $_[1];
30}
31
32sub _install_coderef {
33  my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
34  no warnings 'redefine';
35  if (*{$glob}{CODE}) {
36    *{$glob} = $code;
37  }
38  # perl will sometimes warn about mismatched prototypes coming from the
39  # inheritance cache, so disable them if we aren't redefining a sub
40  else {
41    no warnings 'prototype';
42    *{$glob} = $code;
43  }
44}
45
46# We are dealing with three subs.  The first is the generator sub.  It is
47# provided by the user, so we cannot modify it.  When called, it generates the
48# undeferred sub.  This is also created, so it also cannot be modified.  These
49# are wrapped in a third sub.  The deferred sub is generated by us, and when
50# called it uses the generator sub to create the undeferred sub.  If it is a
51# named sub, it is installed in the symbol table, usually overwriting the
52# deferred sub.  From then on, the deferred sub will goto the undeferred sub
53# if it is called.
54#
55# In %DEFERRED we store array refs with information about these subs.  The key
56# is the stringified subref.  We have a CLONE method to fix this up in the
57# case of threading to deal with changing refaddrs.  The arrayrefs contain:
58#
59# 0. fully qualified sub name (or undef)
60# 1. generator sub
61# 2. options (attributes)
62# 3. scalar ref to undeferred sub (inner reference weakened)
63# 4. deferred sub (deferred only)
64# 5. info arrayref for undeferred sub (deferred only, after undefer)
65#
66# The deferred sub contains a strong reference to its info arrayref, and the
67# undeferred.
68
69our %DEFERRED;
70
71sub undefer_sub {
72  my ($deferred) = @_;
73  my $info = $DEFERRED{$deferred} or return $deferred;
74  my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
75
76  if (!(
77    $deferred_sub && $deferred eq $deferred_sub
78    || ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
79  )) {
80    return $deferred;
81  }
82
83  return ${$undeferred_ref}
84    if ${$undeferred_ref};
85  ${$undeferred_ref} = my $made = $maker->();
86
87  # make sure the method slot has not changed since deferral time
88  if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
89    no warnings 'redefine';
90
91    # I believe $maker already evals with the right package/name, so that
92    # _install_coderef calls are not necessary --ribasushi
93    *{_getglob($target)} = $made;
94  }
95  my $undefer_info = [ $target, $maker, $options, $undeferred_ref ];
96  $info->[5] = $DEFERRED{$made} = $undefer_info;
97  weaken ${$undefer_info->[3]};
98
99  return $made;
100}
101
102sub undefer_all {
103  undefer_sub($_) for keys %DEFERRED;
104  return;
105}
106
107sub undefer_package {
108  my $package = shift;
109  undefer_sub($_)
110    for grep {
111      my $name = $DEFERRED{$_} && $DEFERRED{$_}[0];
112      $name && $name =~ /^${package}::[^:]+$/
113    } keys %DEFERRED;
114  return;
115}
116
117sub defer_info {
118  my ($deferred) = @_;
119  my $info = $DEFERRED{$deferred||''} or return undef;
120
121  my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
122  if (!(
123    $deferred_sub && $deferred eq $deferred_sub
124    || ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
125  )) {
126    delete $DEFERRED{$deferred};
127    return undef;
128  }
129  [
130    $target, $maker, $options,
131    ( $undeferred_ref && $$undeferred_ref ? $$undeferred_ref : ()),
132  ];
133}
134
135sub defer_sub {
136  my ($target, $maker, $options) = @_;
137  my $package;
138  my $subname;
139  ($package, $subname) = $target =~ /^(.*)::([^:]+)$/
140    or croak "$target is not a fully qualified sub name!"
141    if $target;
142  $package ||= $options && $options->{package} || caller;
143  my @attributes = @{$options && $options->{attributes} || []};
144  if (@attributes) {
145    /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
146      for @attributes;
147  }
148  my $deferred;
149  my $undeferred;
150  my $deferred_info = [ $target, $maker, $options, \$undeferred ];
151  if (@attributes || $target && !_CAN_SUBNAME) {
152    my $code
153      =  q[#line ].(__LINE__+2).q[ "].__FILE__.qq["\n]
154      . qq[package $package;\n]
155      . ($target ? "sub $subname" : '+sub') . join('', map " :$_", @attributes)
156      . q[ {
157        package Sub::Defer;
158        # uncoverable subroutine
159        # uncoverable statement
160        $undeferred ||= undefer_sub($deferred_info->[4]);
161        goto &$undeferred; # uncoverable statement
162        $undeferred; # fake lvalue return
163      }]."\n"
164      . ($target ? "\\&$subname" : '');
165    my $e;
166    $deferred = do {
167      no warnings qw(redefine closure);
168      local $@;
169      eval $code or $e = $@; # uncoverable branch true
170    };
171    die $e if defined $e; # uncoverable branch true
172  }
173  else {
174    # duplicated from above
175    $deferred = sub {
176      $undeferred ||= undefer_sub($deferred_info->[4]);
177      goto &$undeferred;
178    };
179    _install_coderef($target, $deferred)
180      if $target;
181  }
182  weaken($deferred_info->[4] = $deferred);
183  weaken($DEFERRED{$deferred} = $deferred_info);
184  return $deferred;
185}
186
187sub CLONE {
188  %DEFERRED = map {
189    defined $_ ? (
190        $_->[4] ? ($_->[4] => $_)
191      : ($_->[3] && ${$_->[3]}) ? (${$_->[3]} => $_)
192      : ()
193    ) : ()
194  } values %DEFERRED;
195}
196
1971;
198__END__
199
200=head1 NAME
201
202Sub::Defer - Defer generation of subroutines until they are first called
203
204=head1 SYNOPSIS
205
206 use Sub::Defer;
207
208 my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
209    my $t = time;
210    sub { time - $t };
211 };
212
213  Logger->time_since_first_log; # returns 0 and replaces itself
214  Logger->time_since_first_log; # returns time - $t
215
216=head1 DESCRIPTION
217
218These subroutines provide the user with a convenient way to defer creation of
219subroutines and methods until they are first called.
220
221=head1 SUBROUTINES
222
223=head2 defer_sub
224
225 my $coderef = defer_sub $name => sub { ... }, \%options;
226
227This subroutine returns a coderef that encapsulates the provided sub - when
228it is first called, the provided sub is called and is -itself- expected to
229return a subroutine which will be goto'ed to on subsequent calls.
230
231If a name is provided, this also installs the sub as that name - and when
232the subroutine is undeferred will re-install the final version for speed.
233
234Exported by default.
235
236=head3 Options
237
238A hashref of options can optionally be specified.
239
240=over 4
241
242=item package
243
244The package to generate the sub in.  Will be overridden by a fully qualified
245C<$name> option.  If not specified, will default to the caller's package.
246
247=item attributes
248
249The L<perlsub/Subroutine Attributes> to apply to the sub generated.  Should be
250specified as an array reference.
251
252=back
253
254=head2 undefer_sub
255
256 my $coderef = undefer_sub \&Foo::name;
257
258If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
259If the passed coderef has not been deferred, this will just return it.
260
261If this is confusing, take a look at the example in the L</SYNOPSIS>.
262
263Exported by default.
264
265=head2 defer_info
266
267 my $data = defer_info $sub;
268 my ($name, $generator, $options, $undeferred_sub) = @$data;
269
270Returns original arguments to defer_sub, plus the undeferred version if this
271sub has already been undeferred.
272
273Note that $sub can be either the original deferred version or the undeferred
274version for convenience.
275
276Not exported by default.
277
278=head2 undefer_all
279
280 undefer_all();
281
282This will undefer all deferred subs in one go.  This can be very useful in a
283forking environment where child processes would each have to undefer the same
284subs.  By calling this just before you start forking children you can undefer
285all currently deferred subs in the parent so that the children do not have to
286do it.  Note this may bake the behavior of some subs that were intended to
287calculate their behavior later, so it shouldn't be used midway through a
288module load or class definition.
289
290Exported by default.
291
292=head2 undefer_package
293
294  undefer_package($package);
295
296This undefers all deferred subs in a package.
297
298Not exported by default.
299
300=head1 SUPPORT
301
302See L<Sub::Quote> for support and contact information.
303
304=head1 AUTHORS
305
306See L<Sub::Quote> for authors.
307
308=head1 COPYRIGHT AND LICENSE
309
310See L<Sub::Quote> for the copyright and license.
311
312=cut
313