AE-AdHoc

 view release on metacpan or  search on metacpan

examples/port-probe-multi.pl  view on Meta::CPAN

	ref $results->{$_}->[0]
		? push @alive, $_
		: push @reject, $_;
};

print "Connected: @alive\n" if @alive;
print "Rejected: @reject\n" if @reject;
print "Timed out: @offline\n" if @offline;
# /Real work

sub usage {
	print <<"USAGE";
Probe tcp connection to several hosts at once
Usage: $0 [ options ] host:port host:port ...
Options may include:
	--timeout <seconds> - may be fractional as well
	--help - this message
USAGE
	exit 1;
};

examples/port-probe.pl  view on Meta::CPAN

} @ARGV;
usage() unless @probe;

# Real work
my $alive = ae_recv {
	tcp_connect $_->[0], $_->[1], ae_send("$_->[0]:$_->[1]") for @probe;
} $timeout;
print "Connect to $alive succeeded!\n";
# /Real work

sub usage {
	print <<"USAGE";
Probe tcp connection to several hosts at once
Usage: $0 [ options ] host:port host:port ...
Options may include:
	--timeout <seconds> - may be fractional as well
	--help - this message
USAGE
	exit 1;
};

lib/AE/AdHoc.pm  view on Meta::CPAN

Instead, it will call C<$subref-E<gt>( $results )> when stuff is done.

Now we need to test do_stuff, so we set up an event loop. We also need a timer,
because a test that runs forever is annoying. So the script goes like this:

    use AnyEvent;

    # set up event loop
    my $cv = AnyEvent->condvar;
    my $timer = AnyEvent->timer(
        after => 10, cb => sub { $cv->croak("Timeout"); }
    );

    do_stuff( @args, sub{ $cv->send(shift); } );

    # run event loop, get rid of timer
    my $result = $cv->recv();
    undef $timer;

    # finally
    analyze_results( $result );

lib/AE/AdHoc.pm  view on Meta::CPAN

=cut

# $cv is our so that it can be localized and act as a lock
our $cv;

# These are for error pretty-printing.
my $iter; # ++ every time
our $where; # "$file:$line[$iter]"

sub ae_recv (&@) { ## no critic
	my $code = shift;
	my $timeout = @_ % 2 && shift; # load bare timeout if present
	my %opt = @_;

	$timeout = $opt{timeout} || $opt{soft_timeout} || $timeout;

	# check we're not in event loop before dying
	$cv and _croak("Nested calls to ae_recv are not allowed");
	local $cv = AnyEvent->condvar;

	croak "Parameter timeout must be a nonzero real number"
		if (!$timeout or !looks_like_number($timeout));

	# find out where we are
	$iter++;
	my @caller = caller(0);
	local $where = "ae_recv[$iter] at $caller[1]:$caller[2]";

	my $on_timeout = $opt{soft_timeout}
		? sub { $cv->send }
		: sub { $cv->croak("Timeout after $timeout seconds"); };
	my $timer;
	$timeout > 0 and $timer = AnyEvent->timer( after => $timeout,
		cb => $on_timeout,
	);
	_clear_goals();
	$code->();
	return $cv->recv;
	# on exit, $timer is autodestroyed
	# on exit, $cv is restored => destroyed
};

=head2 ae_send ( [@fixed_args] )

Create callback for normal event loop ending.

Returns a sub that feeds its arguments to C<$cv-E<gt>send()>. Arguments given to
the function itself are prepended, as in
C<$cv-E<gt>send(@fixed_args, @callback_args)>.

B<NOTE> that ae_recv will return all sent data "as is" in list context, and
only first argument in scalar context.

May be called as ae_send->( ... ) if you want to stop event loop immediately
(i.e. in a handcrafted callback).

=head2 ae_croak ( [$fixed_error] )

Create callback for event loop termination.

Returns a sub that feeds its first argument to $cv->croak(). If argument is
given, it will be used instead.

=head2 ae_begin ( [ sub { ... } ] )

=head2 ae_end

These subroutines provide ability to wait for several events to complete.

The AnyEvent's condition variable has a counter that is incremented by
C<begin()> and decreased by C<end()>. Optionally, the C<begin()> function
may also set a callback.

Whenever the counter reaches zero, either that callback or just C<send()> is

lib/AE/AdHoc.pm  view on Meta::CPAN

consider putting C<ae_send-E<gt>( ... )> somewhere inside the callback.

B<Note>: C<ae_begin()> acts at once, and does NOT return a closure. ae_end,
however, returns a subroutine reference just like C<ae_send>/C<ae_croak> do.

See begin/end section in L<AnyEvent>.

=cut

# set prototypes
sub ae_send (@); ## no critic
sub ae_croak (;$); ## no critic
sub ae_end (); ## no critic

# define ae_send, ae_croak and ae_end at once
foreach my $action (qw(send croak end)) {
	my $name = "ae_$action";
	my $code = sub {
		my @args = @_;

		croak("$name called outside ae_recv") unless $cv;
		my $myiter = $iter; # remember where cb was created

		my @caller = caller(0);
		my $exact = "$name at $caller[1]:$caller[2] from $where";

		return sub {
			return _error( "Leftover $exact called outside ae_recv" )
				unless $cv;
			return _error( "Leftover $exact called in $where")
				unless $iter == $myiter;
			$cv->$action(@args, @_);
		}; # end closure
	}; # end generated sub
	no strict 'refs'; ## no critic
	no warnings 'prototype'; ## no critic
	*{$name} = $code;
};

sub ae_begin(@) { ## no critic
	croak("ae_begin called outside ae_recv") unless $cv;

	$cv->begin(@_);
};


=head1 ADVANCED MULTIPLE GOAL INTERFACE

=head2 ae_goal( "name", @fixed_args )

lib/AE/AdHoc.pm  view on Meta::CPAN

If ae_send is called at some point, the list of incomplete and complete goals
is still available via C<goals> and C<results> calls.

The goals and results are reset every time upon entering ae_recv.

=cut

my %goals;
my %results;
sub _clear_goals { %goals = (); %results = (); };

sub ae_goal {
	my ($name, @fixed_args) = @_;

	croak "ae_goal called outside ae_recv" unless $cv;
	my $myiter = $iter;

	my @caller = caller(0);
	my $exact = "ae_goal('$name') at $caller[1]:$caller[2] from $where";

	$goals{$name}++ unless $results{$name};
	return sub {
		return _error( "Leftover $exact called outside ae_recv" )
			unless $cv;
		return _error( "Leftover $exact called in $where")
			unless $iter == $myiter;
		$results{$name} ||= [ @fixed_args, @_ ];
		delete $goals{$name};
		$cv->send(\%results) unless %goals;
	};
};

=head2 AE::AdHoc->goals

Return goals not yet achieved as hash ref.

=head2 AE::AdHoc->results

Return results of completed goals as hash ref.

=cut

sub goals { return \%goals; };
sub results { return \%results; };

=head1 ADDITIONAL ROUTINES

=head2 ae_action { CODE } %options

Perform CODE after entering the event loop via ae_recv
(a timer is used internally).

CODE will NOT run after current event loop is terminated (see ae_recv).

lib/AE/AdHoc.pm  view on Meta::CPAN

=item * interval - delay between code executions (in seconds, may be fractional)

=item * count - how many times to execute. If zero or omitted, means unlimited
execution when interval is given, and just one otherwise.

=back

=cut

sub ae_action (&@) { ## no critic
	my $code = shift;
	my %opt = @_;

	# TODO copypaste from ae_goal, make a sub
	croak "ae_action called outside ae_recv" unless $cv;
	my $myiter = $iter;
	my @caller = caller(0);
	my $exact = "ae_action at $caller[1]:$caller[2] from $where";

	$opt{after} ||= 0;

	my $count = $opt{count};
	my $inf = !$count;
	my $n = 0;

	my $timer;
	my $cb = sub {
		if (!$cv) {
			undef $timer;
			return _error( "Leftover $exact called outside ae_recv" );
		};
		$myiter == $iter or undef $timer;
		$inf or $count-->0 or undef $timer;
		$timer and $code->($n++);
	};
	$timer = AnyEvent->timer(
		after=>$opt{after}, interval=>$opt{interval}, cb=>$cb);

lib/AE/AdHoc.pm  view on Meta::CPAN

=item * C<$AE::AdHoc::warnings> - set this to false to suppress warnings.

=back

=cut

our @errors;
our $errstr;
our $warnings = 1; # by default, complain loudly

sub _error {
	$errstr = shift;
	push @errors, $errstr;
	carp __PACKAGE__.": ERROR: $errstr" if $warnings;
	return;
};
sub _croak {
	_error(@_);
	croak shift;
};

=head1 CAVEATS

This module is still under heavy development, and is subject to change.
Feature/change requests are accepted.

=head2 Callback confinement

lib/AE/AdHoc.pm  view on Meta::CPAN

Error message will be like C<ae_send at file:13 from ae_recv[1] at file:12
called in ae_recv[2] at file:117>

This is done so to isolate invocations as much as possible.

However, detection of "this invocation" will go wrong if callback maker is
called in a callback itself. For instance, this will always work the same:

	# ...
        callback => sub { ae_send->(@_); },
	# ...

=cut

=head1 AUTHOR

Konstantin S. Uvarin, C<< <khedin at gmail.com> >>

=head1 BUGS

t/10-basic.t  view on Meta::CPAN

throws_ok {
	ae_recv {
		$timer = AnyEvent->timer( after => 0.1, cb => ae_send );
		note "timer ref = $timer";
	} 0.01;
} qr(Timeout), "Start rotten timer test";

# check that later-on callback generates a warning
{
	my @warn;
	local $SIG{__WARN__} = sub { push @warn, @_ };
	throws_ok {
		ae_recv { ; } 0.2;
	} qr(Timeout), "Rotten timer didn't spoil later tests:";
	is (scalar @warn, 1, " - 1 warning issued");
	like ($warn[0], qr(Leftover), " - It was about 'Leftover': $warn[0]");
	ok (ref $timer, " - Rotten timer still alive at this point (but harmless): $timer");

};

t/11-begin-end.t  view on Meta::CPAN

} qr(Timeout), "A simple example with extra begin dies";

my @trace;
my $val;

lives_ok {
	ae_recv {
		my $tm;
		my $iter;
		my $attimer;
		$attimer = sub {
			push @trace, ++$iter;
			ae_end->();
			$tm = AE::timer 0.01, 0, $attimer;
		};
		$tm = AE::timer 0.01, 0, $attimer;
		ae_begin( sub { ae_send->(++$val) } ) for (1,2);
	} 1;
} "More complex example lives";

is ($val, 1, "Begin's callback executed once");
is_deeply(\@trace, [1, 2], "end->() executed twice");

t/13-null-timeout.t  view on Meta::CPAN

#!/usr/bin/perl -w

use strict;
use Test::More;
use Test::Exception;

use AE::AdHoc;

my @warn;
$SIG{__WARN__} = sub { push @warn, shift };

plan tests => 4;

throws_ok {
	ae_recv{ };
} qr(timeout.*non-?zero), "No timeout = no go";

throws_ok {
	ae_recv{ } "foo";
} qr(timeout.*non-?zero), "Non-numeric timeout = no go";

t/15-goals.t  view on Meta::CPAN

use AE::AdHoc;

my $result;

throws_ok {
	ae_goal("foo");
} qr(outside), "no ae_recv = no go";
note $@;

# We use sub {} in timers here because timer passes random args to its
# callback. See L<::AnyEvent> timer section.

lives_ok {
	my ($t1, $t2);
	$result = ae_recv {
		$t1 = AnyEvent->timer( after => 0,
			cb => sub { ae_goal("task1")->() }
		);
		$t2 = AnyEvent->timer( after => 0,
			cb => sub { ae_goal("task2", "fixed")->() }
		);
	} 1;
} "No timeout - goals complete";

note "Got: ".Dumper($result);

is_deeply ($result,
	{ task1 => [], task2 => [ "fixed" ]},
	"Results as expected (sans timer callback args)"
);

t/18-all-leftover.t  view on Meta::CPAN

use strict;
use Test::More tests => 5;
use Test::Exception;

use AE::AdHoc;
$AE::AdHoc::warnings = 0;

my $sub;

ae_recv { $sub = ae_send; ae_send->("stop now"); } 0.01;
lives_ok { $sub->() } "Don't die if event loop MAY exist";
like ($AE::AdHoc::errstr, qr(Leftover.*outside), "Error was catched");
note $AE::AdHoc::errstr;

ae_recv { $sub = ae_goal("foo"); ae_send->("stop now"); } 0.01;
lives_ok { $sub->() } "Don't die if event loop MAY exist";
like ($AE::AdHoc::errstr, qr(Leftover.*outside), "Error was catched");
note $AE::AdHoc::errstr;

is (scalar @AE::AdHoc::errors, 2, "Exactly two errors");

t/boilerplate.t  view on Meta::CPAN

#!perl -T

use strict;
use warnings;
use Test::More tests => 3;

sub not_in_file_ok {
    my ($filename, %regex) = @_;
    open( my $fh, '<', $filename )
        or die "couldn't open $filename for reading: $!";

    my %violated;

    while (my $line = <$fh>) {
        while (my ($desc, $regex) = each %regex) {
            if ($line =~ $regex) {
                push @{$violated{$desc}||=[]}, $.;

t/boilerplate.t  view on Meta::CPAN

    }

    if (%violated) {
        fail("$filename contains boilerplate text");
        diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
    } else {
        pass("$filename contains no boilerplate text");
    }
}

sub module_boilerplate_ok {
    my ($module) = @_;
    not_in_file_ok($module =>
        'the great new $MODULENAME'   => qr/ - The great new /,
        'boilerplate description'     => qr/Quick summary of what the module/,
        'stub function definition'    => qr/function[12]/,
    );
}

TODO: {
#  local $TODO = "Need to replace the boilerplate text";