From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 6 Nov 2010 21:03:23 +0000 (+0000)
Subject: first cut at Sub::Defer
X-Git-Tag: 0.009001~77
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eae82931c70bed45915ee6785db2a11cb4b16f0e;p=gitmo%2FRole-Tiny.git

first cut at Sub::Defer
---

diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm
new file mode 100644
index 0000000..11430fa
--- /dev/null
+++ b/lib/Sub/Defer.pm
@@ -0,0 +1,35 @@
+package Sub::Defer;
+
+use strictures 1;
+use base qw(Exporter);
+
+our @EXPORT = qw(defer undefer);
+
+our %DEFERRED;
+
+sub _getglob { no strict 'refs'; \*{$_[0]} }
+
+sub undefer {
+  my ($deferred) = @_;
+  my ($target, $maker, $undeferred_ref) = @{
+    $DEFERRED{$deferred}||return $deferred
+  };
+  ${$undeferred_ref} = my $made = $maker->();
+  { no warnings 'redefine'; *{_getglob($target)} = $made }
+  return $made;
+}
+
+sub defer {
+  my ($target, $maker) = @_;
+  my $undeferred;
+  my $deferred_string;
+  my $deferred = bless(sub {
+    goto &{$undeferred ||= undefer($deferred_string)};
+  }, 'Sub::Defer::Deferred');
+  $deferred_string = "$deferred";
+  $DEFERRED{$deferred} = [ $target, $maker, \$undeferred ];
+  *{_getglob $target} = $deferred;
+  return $deferred;
+}
+
+1;
diff --git a/t/sub-defer.t b/t/sub-defer.t
new file mode 100644
index 0000000..7675560
--- /dev/null
+++ b/t/sub-defer.t
@@ -0,0 +1,42 @@
+use strictures 1;
+use Test::More;
+use Sub::Defer;
+
+my %made;
+
+my $one_defer = defer 'Foo::one' => sub {
+  die "remade - wtf" if $made{'Foo::one'};
+  $made{'Foo::one'} = sub { 'one' }
+};
+
+my $two_defer = defer 'Foo::two' => sub {
+  die "remade - wtf" if $made{'Foo::two'};
+  $made{'Foo::two'} = sub { 'two' }
+};
+
+is($one_defer, \&Foo::one, 'one defer installed');
+is($two_defer, \&Foo::two, 'two defer installed');
+
+is($one_defer->(), 'one', 'one defer runs');
+
+is($made{'Foo::one'}, \&Foo::one, 'one made');
+
+is($made{'Foo::two'}, undef, 'two not made');
+
+is($one_defer->(), 'one', 'one (deferred) still runs');
+
+is(Foo->one, 'one', 'one (undeferred) runs');
+
+is(my $two_made = undefer($two_defer), $made{'Foo::two'}, 'make two');
+
+is($two_made, \&Foo::two, 'two installed');
+
+is($two_defer->(), 'two', 'two (deferred) still runs');
+
+is($two_made->(), 'two', 'two (undeferred) runs');
+
+my $three = sub { 'three' };
+
+is(undefer($three), $three, 'undefer non-deferred is a no-op');
+
+done_testing;