Permalink
Browse files

deferred for perl

  • Loading branch information...
0 parents commit c3fc10678342bd35051e6286b5a25208347ea25a @kentaro committed Jul 23, 2011
Showing with 478 additions and 0 deletions.
  1. +11 −0 .gitignore
  2. +2 −0 .shipit
  3. +4 −0 Changes
  4. +27 −0 MANIFEST.SKIP
  5. +19 −0 Makefile.PL
  6. +24 −0 README.mkdn
  7. +123 −0 lib/Deferred.pm
  8. +16 −0 lib/Deferred/Function.pm
  9. +27 −0 lib/Deferred/Promise.pm
  10. +85 −0 lib/Deferred/Queue.pm
  11. +9 −0 t/compile.t
  12. +26 −0 t/deferred.t
  13. +54 −0 t/queue.t
  14. +36 −0 xt/01_podspell.t
  15. +5 −0 xt/02_perlcritic.t
  16. +4 −0 xt/03_pod.t
  17. +6 −0 xt/perlcriticrc
@@ -0,0 +1,11 @@
+Makefile
+inc/
+.c
+ppport.h
+*.sw[po]
+*.bak
+*.old
+Build
+_build/
+xshelper.h
+tags
@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+git.push_to=origin
@@ -0,0 +1,4 @@
+Revision history for Perl extension Deferred
+
+0.01 Fri Jul 22 17:40:50 2011
+ - original version
@@ -0,0 +1,27 @@
+^\.git/
+\bRCS\b
+\bCVS\b
+^MANIFEST\.
+^Makefile$
+~$
+^#
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+^t/perlcritic
+^tools/
+\.svn/
+^[^/]+\.yaml$
+^[^/]+\.pl$
+^\.shipit$
+\.sw[po]$
+^Build$
+^ppport.h$
+^xshelper.h$
+cover_db
+nytprof
+perltidy.ERR$
+^tags$
@@ -0,0 +1,19 @@
+use inc::Module::Install;
+use Module::Install::AuthorTests;
+use Module::Install::ReadmeMarkdownFromPod;
+
+name 'Deferred';
+all_from 'lib/Deferred.pm';
+readme_markdown_from 'lib/Deferred.pm';
+
+requires 'Coro';
+requires 'parent';
+requires 'Try::Tiny';
+requires 'Class::Accessor::Lite';
+
+tests 't/*.t t/*/*.t t/*/*/*.t t/*/*/*/*.t';
+test_requires 'Test::More' => 0.96;
+test_requires 'Test::Name::FromLine';
+author_tests('xt');
+
+WriteAll;
@@ -0,0 +1,24 @@
+# NAME
+
+Deferred -
+
+# SYNOPSIS
+
+ use Deferred;
+
+# DESCRIPTION
+
+Deferred is
+
+# AUTHOR
+
+Kentaro Kuribayashi <kentarok@gmail.com>
+
+# SEE ALSO
+
+# LICENSE
+
+Copyright (C) Kentaro Kuribayashi
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
@@ -0,0 +1,123 @@
+package Deferred;
+use 5.008001;
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Coro;
+
+use parent 'Exporter';
+our @EXPORT = qw(deferred);
+
+use Class::Accessor::Lite (
+ rw => [qw(
+ done_queue
+ fail_queue
+ )],
+);
+
+use Deferred::Queue;
+use Deferred::Promise;
+use Deferred::Function;
+
+sub deferred (;@) { __PACKAGE__->new(@_) }
+
+sub new {
+ my ($class, $callback) = @_;
+ my $self = bless {
+ done_queue => Deferred::Queue->new,
+ fail_queue => Deferred::Queue->new,
+ }, $class;
+
+ if ($callback) {
+ async { $callback->(@_) } $self;
+ }
+
+ $self;
+}
+
+sub done {
+ my ($self, @callbacks) = @_;
+ $self->done_queue->done(@callbacks);
+ $self;
+}
+
+sub fail {
+ my ($self, @callbacks) = @_;
+ $self->fail_queue->done(@callbacks);
+ $self;
+}
+
+sub resolve {
+ my ($self, @args) = @_;
+ $self->done_queue->resolve(@args);
+ $self;
+}
+
+sub is_resolved { shift->done_queue->is_resolved }
+
+sub reject {
+ my ($self, @args) = @_;
+ $self->fail_queue->resolve(@args);
+ $self;
+}
+
+sub is_rejected { shift->fail_queue->is_resolved }
+
+sub then {
+ my ($self, $done_callbacks, $fail_callbacks) = @_;
+ $done_callbacks = ref $done_callbacks eq 'ARRAY' ? $done_callbacks : [$done_callbacks];
+ $fail_callbacks = ref $fail_callbacks eq 'ARRAY' ? $fail_callbacks : [$fail_callbacks];
+
+ $self->done(@$done_callbacks)
+ ->fail(@$fail_callbacks);
+}
+
+sub always {
+ my ($self, @callbacks) = @_;
+ $self->done(@callbacks)
+ ->fail(@callbacks);
+}
+
+sub pipe {
+
+}
+
+sub promise {
+ my $self = shift;
+ Deferred::Promise->new($self);
+}
+
+!!1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Deferred -
+
+=head1 SYNOPSIS
+
+ use Deferred;
+
+=head1 DESCRIPTION
+
+Deferred is
+
+=head1 AUTHOR
+
+Kentaro Kuribayashi E<lt>kentarok@gmail.comE<gt>
+
+=head1 SEE ALSO
+
+=head1 LICENSE
+
+Copyright (C) Kentaro Kuribayashi
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,16 @@
+package Deferred::Function;
+use strict;
+use warnings;
+use Coro;
+
+sub new {
+ my ($class, $function) = @_;
+ bless { function => $function }, $class;
+}
+
+sub to_coro {
+ my ($self, @args) = @_;
+ async { $self->{function}->(@_) } @args;
+}
+
+!!1;
@@ -0,0 +1,27 @@
+package Deferred::Promise;
+use strict;
+use warnings;
+
+sub new {
+ my ($class, $deferred) = @_;
+ bless { deferred => $deferred }, $class;
+}
+
+for my $method (qw(
+ done
+ fail
+ is_resolved
+ is_rejected
+ promise
+ then
+ always
+ pipe
+)) {
+ no strict 'refs';
+
+ *{__PACKAGE__."\::$method"} = sub {
+ shift->{deferred}->$method(@_)
+ }
+}
+
+!!1;
@@ -0,0 +1,85 @@
+package Deferred::Queue;
+use strict;
+use warnings;
+use Try::Tiny;
+
+use Deferred::Function;
+
+use Class::Accessor::Lite (
+ rw => [qw(
+ callbacks
+ fired
+ firing
+ cancelled
+ )],
+);
+
+sub new {
+ my $class = shift;
+ bless {
+ callbacks => [],
+ fired => 0,
+ firing => 0,
+ cancelled => 0,
+ }, $class
+}
+
+sub done {
+ my ($self, @callbacks) = @_;
+ my $fired;
+
+ if ($self->fired) {
+ $fired = $self->fired;
+ $self->fired(0);
+ }
+
+ push @{$self->callbacks}, (map {
+ Deferred::Function->new($_)
+ } @callbacks);
+
+ if ($self->fired) {
+ $self->resolve(@{$fired || []});
+ }
+
+ $self;
+}
+
+sub resolve {
+ my ($self, @args) = @_;
+ $self->firing(1);
+
+ try {
+ my @coros;
+
+ while (my $callback = shift @{$self->callbacks}) {
+ push @coros, $callback->to_coro(@args);
+ }
+
+ $_->join for @coros;
+ }
+ finally {
+ $self->fired([@args]);
+ $self->firing(0);
+ };
+
+ $self;
+}
+
+sub is_resolved {
+ my $self = shift;
+ !!($self->firing || $self->fired);
+}
+
+sub cancel {
+ my $self = shift;
+ $self->cancelled(1);
+ $self->callbacks([]);
+ $self;
+}
+
+sub is_cancelled {
+ my $self = shift;
+ !!$self->cancelled;
+}
+
+!!1;
@@ -0,0 +1,9 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok $_ for qw(
+ Deferred
+ Deferred::Queue
+ );
+}
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Name::FromLine;
+
+use Coro;
+use Coro::AnyEvent;
+use Deferred;
+
+subtest 'passing a callback into constructor' => sub {
+ my $deferred = deferred(
+ sub {
+ my $deferred = shift;
+ Coro::AnyEvent::sleep 1;
+ $deferred->resolve('-');
+ }
+ );
+
+ $deferred->done(
+ sub { my $arg = shift; warn "$arg foo"; },
+ sub { my $arg = shift; warn "$arg bar"; },
+ );
+};
+
+done_testing;
Oops, something went wrong.

0 comments on commit c3fc106

Please sign in to comment.