File Coverage

blib/lib/Module/AnyEvent/Helper.pm

Criterion	Covered	Total	%
statement	65	75	86.6
branch	17	24	70.8
condition	12	20	60.0
subroutine	14	15	93.3
pod	4	4	100.0
total	112	138	81.1

package Module::AnyEvent::Helper;

use strict;
use warnings;

use Try::Tiny;
use AnyEvent;
use Carp;

# ABSTRACT: Helper module to make other modules AnyEvent-friendly
our $VERSION = 'v0.0.5'; # VERSION

require Exporter;
our (@ISA) = qw(Exporter);
our (@EXPORT_OK) = qw(strip_async strip_async_all bind_scalar bind_array);

sub _strip_async
{
	my ($pkg, @func) = @_;
	foreach my $func (@func) {
		croak "$func does not end with _async" unless $func =~ /_async$/;
		my $new_func = $func;
		$new_func =~ s/_async$//;

		no strict 'refs'; ## no critic (ProhibitNoStrict)
		*{$pkg.'::'.$new_func} = sub {
			shift->$func(@_)->recv;
		};
	}
}

sub strip_async
{
	shift if eval { $_[0]->isa(__PACKAGE__); };
	my $pkg = caller;
	_strip_async($pkg, @_);
}

sub strip_async_all
{
	shift if eval { $_[0]->isa(__PACKAGE__); };
	my $pkg = caller;
	my %arg = @_;
	$arg{-exclude} ||= [];
	my %exclude = map { $_.'_async', 1 } @{$arg{-exclude}};
	no strict 'refs'; ## no critic (ProhibitNoStrict)
	_strip_async($pkg, grep { /_async$/ && defined *{$pkg.'::'.$_}{CODE} && ! exists $exclude{$_}  } keys %{$pkg.'::'});
}

my $guard = sub {};

sub bind_scalar
{
	shift if eval { $_[0]->isa(__PACKAGE__); };
	my ($gcv, $lcv, $succ) = @_;

	if(!defined $lcv || ref($lcv) ne 'AnyEvent::CondVar') {
		my $ret = $lcv;
		$lcv = AE::cv;
		$lcv->send($ret);
	}
	confess 'unexpected undef code reference' unless ref($succ) eq 'CODE';

	$lcv->cb(sub {
		my $arg = shift;
		try {
			my $ret = $succ->($arg);
			$gcv->send($ret) if ref($ret) ne 'CODE' || $ret != $guard;
		} catch {
			$gcv->croak($_);
		}
	});
	$guard;
}

sub bind_array
{
	shift if eval { $_[0]->isa(__PACKAGE__); };
	my ($gcv, $lcv, $succ) = @_;

	if(!defined $lcv || ref($lcv) ne 'AnyEvent::CondVar') {
		my $ret = $lcv;
		$lcv = AE::cv;
		$lcv->send($ret);
	}
	confess 'unexpected undef code reference' unless ref($succ) eq 'CODE';

	$lcv->cb(sub {
		my $arg = shift;
		try {
			my @ret = $succ->($arg);
			$gcv->send(@ret) if @ret != 1 || ref($ret[0]) ne 'CODE' || $ret[0] != $guard;
		} catch {
			$gcv->croak($_);
		}
	});
	$guard;
}

1;

__END__