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