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