lib/Sub/Defer.pm

   1 package Sub::Defer;
   2
   3 use strictures 1;
   4 use base qw(Exporter);
   5 use Moo::_Utils;
   6
   7 our $VERSION = '1.003000';
   8 $VERSION = eval $VERSION;
   9
  10 our @EXPORT = qw(defer_sub undefer_sub);
  11
  12 our %DEFERRED;
  13
  14 sub undefer_sub {
  15   my ($deferred) = @_;
  16   my ($target, $maker, $undeferred_ref) = @{
  17     $DEFERRED{$deferred}||return $deferred
  18   };
  19   return ${$undeferred_ref}
  20     if ${$undeferred_ref};
  21   ${$undeferred_ref} = my $made = $maker->();
  22
  23   # make sure the method slot has not changed since deferral time
  24   if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
  25     no warnings 'redefine';
  26
  27     # I believe $maker already evals with the right package/name, so that
  28     # _install_coderef calls are not necessary --ribasushi
  29     *{_getglob($target)} = $made;
  30   }
  31   $DEFERRED{$made} = $DEFERRED{$deferred};
  32
  33   return $made;
  34 }
  35
  36 sub defer_info {
  37   my ($deferred) = @_;
  38   $DEFERRED{$deferred||''};
  39 }
  40
  41 sub defer_sub {
  42   my ($target, $maker) = @_;
  43   my $undeferred;
  44   my $deferred;
  45   $deferred = sub {
  46     $undeferred ||= undefer_sub($deferred);
  47     goto &$undeferred;
  48   };
  49   $DEFERRED{$deferred} = [ $target, $maker, \$undeferred, $deferred ];
  50   _install_coderef($target => $deferred) if defined $target;
  51   return $deferred;
  52 }
  53
  54 sub CLONE {
  55   %DEFERRED = map { $_->[3] => $_ } values %DEFERRED;
  56 }
  57
  58 1;
  59
  60 =head1 NAME
  61
  62 Sub::Defer - defer generation of subroutines until they are first called
  63
  64 =head1 SYNOPSIS
  65
  66  use Sub::Defer;
  67
  68  my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
  69     my $t = time;
  70     sub { time - $t };
  71  };
  72
  73   Logger->time_since_first_log; # returns 0 and replaces itself
  74   Logger->time_since_first_log; # returns time - $t
  75
  76 =head1 DESCRIPTION
  77
  78 These subroutines provide the user with a convenient way to defer creation of
  79 subroutines and methods until they are first called.
  80
  81 =head1 SUBROUTINES
  82
  83 =head2 defer_sub
  84
  85  my $coderef = defer_sub $name => sub { ... };
  86
  87 This subroutine returns a coderef that encapsulates the provided sub - when
  88 it is first called, the provided sub is called and is -itself- expected to
  89 return a subroutine which will be goto'ed to on subsequent calls.
  90
  91 If a name is provided, this also installs the sub as that name - and when
  92 the subroutine is undeferred will re-install the final version for speed.
  93
  94 =head2 undefer_sub
  95
  96  my $coderef = undefer_sub \&Foo::name;
  97
  98 If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
  99 If the passed coderef has not been deferred, this will just return it.
 100
 101 If this is confusing, take a look at the example in the L</SYNOPSIS>.
 102
 103 =head1 SUPPORT
 104
 105 See L<Moo> for support and contact information.
 106
 107 =head1 AUTHORS
 108
 109 See L<Moo> for authors.
 110
 111 =head1 COPYRIGHT AND LICENSE
 112
 113 See L<Moo> for the copyright and license.