AnyEvent-Impl-Prima
view release on metacpan or search on metacpan
Changes
lib/AnyEvent/Impl/Prima.pm
Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
META.json
META.yml
README
README.mkdn
t/02-prima-http.t
t/02-prima-timer-repeat.t
t/02-prima-timer.t
t/71_prima_01_basic.t
t/71_prima_02_signals.t
t/71_prima_03_child.t
t/71_prima_04_condvar.t
t/71_prima_05_dns.t
t/71_prima_07_io.t
t/71_prima_09_multi.t
xt/99-changes.t
xt/99-compile.t
xt/99-manifest.t
README.mkdn view on Meta::CPAN
AnyEvent::Impl::Prima - Prima event loop adapter for AnyEvent
# SYNOPSIS
use Prima;
use AnyEvent::Impl::Prima;
my $mw = Prima::MainWindow->new();
my $timer = AnyEvent->timer(
after => 10,
cb => sub { $mw->close; },
);
Prima->run;
# AUTHORS
Zsban Ambrus
lib/AnyEvent/Impl/Prima.pm view on Meta::CPAN
AnyEvent::Impl::Prima - Prima event loop adapter for AnyEvent
=head1 SYNOPSIS
use Prima;
use AnyEvent::Impl::Prima;
my $mw = Prima::MainWindow->new();
my $timer = AnyEvent->timer(
after => 10,
cb => sub { $mw->close; },
);
Prima->run;
=cut
{
lib/AnyEvent/Impl/Prima.pm view on Meta::CPAN
if( ! ref $r{fh}) {
$f->fd( $r{fh} )
} else {
$f->file( $r{fh} )
};
$f
}
sub AnyEvent::Impl::Prima::Timer::DESTROY { ${$_[0]}->destroy if $_[0] and ${$_[0]} }
sub timer { my ( $s, %r ) = @_;
my($c,$g) = $r{cb};
my $next = $r{ after } || $r{ interval };
my $repeat = delete $r{ interval };
# Convert to miliseconds for Prima
$next *= 1000;
$repeat *= 1000 if $repeat;
my %timer_params = (
timeout => $next,
);
my $timer = Prima::Timer->new(
timeout => $next,
onTick => sub {
#warn "Timer $_[0] fired";
if( $repeat ) {
$_[0]->timeout( $repeat );
} else {
$_[0]->stop;
};
&$c()
},
onDestroy => sub { my ( $self ) = @_;
#warn "Discarding $self";
$self->stop;
},
);
#warn "Starting new timer $res";
$timer->start;
return bless \ $timer, "AnyEvent::Impl::Prima::Timer";
}
sub poll {
require Prima::Application;
$::application->yield;
}
{
no warnings 'redefine';
sub AnyEvent::CondVar::Base::_wait {
t/02-prima-http.t view on Meta::CPAN
use Test::HTTP::LocalServer;
my $server = Test::HTTP::LocalServer->spawn();
my $mw = Prima::MainWindow->new();
use Data::Dumper;
my $res;
my $timer;
my $web_request;
my $answer;
my $start_request; $start_request = AnyEvent->timer(
after => 2,
cb => sub {
$timer++;
$web_request = http_get $server->url,
sub {
$answer = $_[1];
$mw->close
},
;
},
);
my $timeout;
my $t = AnyEvent->timer(
cb => sub { $timeout++; $mw->close },
after => 10,
);
Prima->run;
pass "We finished our main loop";
isn't $answer, undef, "We got an HTTP answer";
is $timer, 1, "Our timer got called";
is $timeout, undef, "No timeout";
done_testing;
t/02-prima-timer-repeat.t view on Meta::CPAN
}
use Prima;
use AnyEvent;
use Prima::Application;
use AnyEvent::Impl::Prima;
my $mw = Prima::MainWindow->new();
my $called;
my $t = AnyEvent->timer(
cb => sub { $called++; $mw->close if $called > 1 },
after => 4,
interval => 1,
);
Prima->run;
is $called, 2, "We catch repeating timers";
done_testing;
t/02-prima-timer.t view on Meta::CPAN
}
use Prima;
use AnyEvent;
use Prima::Application;
use AnyEvent::Impl::Prima;
my $mw = Prima::MainWindow->new();
my $done;
my $t = AnyEvent->timer(
cb => sub { $done++; $mw->close },
after => 1,
);
Prima->run;
ok $done, "A timer catches us and we exit";
done_testing;
t/71_prima_01_basic.t view on Meta::CPAN
$| = 1; print "1..6\n";
print "ok 1\n";
my $cv = AnyEvent->condvar;
print "ok 2\n";
my $timer1 = AnyEvent->timer (after => 0.1, cb => sub { print "ok 5\n"; $cv->broadcast });
print "ok 3\n";
AnyEvent->timer (after => 0.01, cb => sub { print "not ok 5\n" });
print "ok 4\n";
$cv->wait;
print "ok 6\n";
t/71_prima_02_signals.t view on Meta::CPAN
BEGIN { eval q{use AnyEvent::Impl::Prima;1} or ((print qq{1..0 # SKIP AnyEvent::Impl::Prima not loadable\n}), exit 0) }
$| = 1; print "1..5\n";
print "ok 1\n";
my $cv = AnyEvent->condvar;
my $error = AnyEvent->timer (after => 5, cb => sub {
print <<EOF;
Bail out! No signal caught.
EOF
exit 0;
});
my $sw = AnyEvent->signal (signal => 'INT', cb => sub {
print "ok 3\n";
$cv->broadcast;
});
t/71_prima_03_child.t view on Meta::CPAN
for my $it ("", 1, 2, 3, 4) {
print "ok ${it}1\n";
AnyEvent::detect; # force-load event model
my $pid = fork;
defined $pid or die "unable to fork";
# work around Tk bug until it has been fixed.
#my $timer = AnyEvent->timer (after => 2, cb => sub { });
my $cv = AnyEvent->condvar;
unless ($pid) {
print "ok ${it}2 # child $$\n";
# POE hits a race condition when the child dies too quickly
# because it checks for child exit before installing the signal handler.
# seen in version 1.352 - earlier versions had the same bug, but
# polled for child exits regularly, so only caused a delay.
t/71_prima_03_child.t view on Meta::CPAN
# Glib is the only model that doesn't support pid == 0
my $pid0 = $AnyEvent::MODEL eq "AnyEvent::Impl::Glib" ? $pid2 : 0;
my $w2 = AnyEvent->child (pid => $pid0, cb => sub {
print $pid2 == $_[0] ? "" : "not ", "ok ${it}5 # $pid2 == $_[0]\n";
print 7 == ($_[1] >> 8) ? "" : "not ", "ok ${it}6 # 7 == $_[1] >> 8 ($_[1])\n";
$cv2->broadcast;
});
my $error = AnyEvent->timer (after => 5, cb => sub {
print <<EOF;
Bail out! No child exit detected. This is either a bug in AnyEvent or a bug in your Perl (mostly some windows distributions suffer from that): child watchers might not work properly on this platform. You can force installation of this module if you d...
EOF
exit 0;
});
$cv2->recv;
print "ok ${it}7\n";
print "ok ${it}8\n";
t/71_prima_04_condvar.t view on Meta::CPAN
my $x = $_[0]->recv;
print $x == 7 ? "" : "not ", "ok 5 # $x == 7\n";
my @x = $_[0]->recv;
print $x[1] == 5 ? "" : "not ", "ok 6 # $x[1] == 5\n";
my $y = $cv->recv;
print $y == 7 ? "" : "not ", "ok 7 # $x == 7\n";
});
my $t = AnyEvent->timer (after => 0, cb => sub {
print "ok 3\n";
$cv->send (7, 5);
});
print "ok 2\n";
$cv->recv;
print "ok 8\n";
my @x = $cv->recv;
print $x[1] == 5 ? "" : "not ", "ok 9 # $x[1] == 5\n";
t/71_prima_04_condvar.t view on Meta::CPAN
my $cv = AnyEvent->condvar;
$cv->cb (sub {
print $_[0]->ready ? "" : "not ", "ok 12\n";
my $x = eval { $_[0]->recv };
print !defined $x ? "" : "not ", "ok 13\n";
print $@ =~ /^kill/ ? "" : "not ", "ok 14 # $@\n";
});
my $t = AnyEvent->timer (after => 0, cb => sub {
print "ok 11\n";
$cv->croak ("kill");
print "ok 15\n";
$cv->send (8, 6, 4);
print "ok 16\n";
});
print "ok 10\n";
my @x = eval { $cv->recv };
print !@x ? "" : "not ", "ok 17 # @x\n";
print $@ =~ /^kill / ? "" : "not ", "ok 18 # $@\n";
}
{
my $cv = AnyEvent->condvar;
print "ok 19\n";
my $t = AnyEvent->timer (after => 0, cb => $cv);
print "ok 20\n";
$cv->recv;
print "ok 21\n";
}
{
my $cv = AE::cv {
print +($_[0]->recv)[0] == 6 ? "" : "not ", "ok 27\n";
};
t/71_prima_07_io.t view on Meta::CPAN
print "ok 7\n";
$wb = AnyEvent->io (fh => $b, poll => "w", cb => sub {
print "ok 8\n";
undef $wb;
syswrite $b, "1";
});
});
print "ok 3\n";
{ my $cv = AnyEvent->condvar; $t = AnyEvent->timer (after => 0.05, cb => sub { $cv->send }); $cv->recv }
print "ok 4\n";
$wa = AnyEvent->io (fh => $a, poll => "w", cb => sub {
syswrite $a, "0";
undef $wa;
print "ok 5\n";
});
$ra = AnyEvent->io (fh => $a, poll => "r", cb => sub {
t/71_prima_07_io.t view on Meta::CPAN
print "ok 15\n";
$wb = AnyEvent->io (fh => fileno $b, poll => "w", cb => sub {
print "ok 16\n";
undef $wb;
syswrite $b, "1";
});
});
print "ok 11\n";
{ my $cv = AnyEvent->condvar; $t = AnyEvent->timer (after => 0.05, cb => sub { $cv->send }); $cv->recv }
print "ok 12\n";
$wa = AnyEvent->io (fh => fileno $a, poll => "w", cb => sub {
syswrite $a, "0";
undef $wa;
print "ok 13\n";
});
$ra = AnyEvent->io (fh => $a, poll => "r", cb => sub {
t/71_prima_09_multi.t view on Meta::CPAN
print "ok 1\n";
$AnyEvent::MAX_SIGNAL_LATENCY = 0.05;
my ($a, $b) = AnyEvent::Util::portable_socketpair;
# I/O write
{
my $cv = AE::cv;
my $wt = AE::timer 1, 0, $cv;
my $s = 0;
$cv->begin; my $wa = AE::io $a, 1, sub { $cv->end; $s |= 1 };
$cv->begin; my $wb = AE::io $a, 1, sub { $cv->end; $s |= 2 };
$cv->recv;
print $s == 3 ? "" : "not ", "ok 2 # $s\n";
}
# I/O read
{
my $cv = AE::cv;
my $wt = AE::timer 0.01, 0, $cv;
my $s = 0;
my $wa = AE::io $a, 0, sub { $cv->end; $s |= 1 };
my $wb = AE::io $a, 0, sub { $cv->end; $s |= 2 };
$cv->recv;
print $s == 0 ? "" : "not ", "ok 3 # $s\n";
syswrite $b, "x";
$cv = AE::cv;
$wt = AE::timer 1, 0, $cv;
$s = 0;
$cv->begin;
$cv->begin;
$cv->recv;
print $s == 3 ? "" : "not ", "ok 4 # $s\n";
sysread $a, my $dummy, 1;
$cv = AE::cv;
$wt = AE::timer 0.01, 0, $cv;
$s = 0;
$cv->recv;
print $s == 0 ? "" : "not ", "ok 5 # $s\n";
}
# signal
{
my $cv = AE::cv;
my $wt = AE::timer 0.01, 0, $cv;
my $s = 0;
$cv->begin; my $wa = AE::signal INT => sub { $cv->end; $s |= 1 };
$cv->begin; my $wb = AE::signal INT => sub { $cv->end; $s |= 2 };
$cv->recv;
print $s == 0 ? "" : "not ", "ok 6 # $s\n";
kill INT => $$;
$cv = AE::cv;
$wt = AE::timer 0.2, 0, $cv; # maybe OS X needs more time here? or maybe some buggy arm kernel?
$s = 0;
$cv->recv;
print $s == 3 ? "" : "not ", "ok 7 # $s\n";
$cv = AE::cv;
$wt = AE::timer 0.01, 0, $cv;
$s = 0;
$cv->recv;
print $s == 0 ? "" : "not ", "ok 8 # $s\n";
}
# child
{
my $cv = AE::cv;
my $wt = AE::timer 0.01, 0, $cv;
my $s = 0;
my $pid = fork;
unless ($pid) {
sleep 2;
exit 1;
}
my ($apid, $bpid, $astatus, $bstatus);
t/71_prima_09_multi.t view on Meta::CPAN
$cv->begin; my $wa = AE::child $pid, sub { ($apid, $astatus) = @_; $cv->end; $s |= 1 };
$cv->begin; my $wb = AE::child $pid, sub { ($bpid, $bstatus) = @_; $cv->end; $s |= 2 };
$cv->recv;
print $s == 0 ? "" : "not ", "ok 9 # $s\n";
kill 9, $pid;
$cv = AE::cv;
$wt = AE::timer 0.2, 0, $cv; # cygwin needs ages for this
$s = 0;
$cv->recv;
print $s == 3 ? "" : "not ", "ok 10 # $s\n";
print $apid == $pid && $bpid == $pid ? "" : "not ", "ok 11 # $apid == $bpid == $pid\n";
print $astatus == 9 && $bstatus == 9 ? "" : "not ", "ok 12 # $astatus == $bstatus == 9\n";
$cv = AE::cv;
$wt = AE::timer 0.01, 0, $cv;
$s = 0;
$cv->recv;
print $s == 0 ? "" : "not ", "ok 13 # $s\n";
}
# timers (don't laugh, some event loops are more broken...)
{
my $cv = AE::cv;
my $wt = AE::timer 1, 0, $cv;
my $s = 0;
$cv->begin; my $wa = AE::timer 0 , 0, sub { $cv->end; $s |= 1 };
$cv->begin; my $wb = AE::timer 0 , 0, sub { $cv->end; $s |= 2 };
$cv->begin; my $wc = AE::timer 0.01, 0, sub { $cv->end; $s |= 4 };
$cv->recv;
print $s == 7 ? "" : "not ", "ok 14 # $s\n";
}
print "ok 15\n";
exit 0;
( run in 0.315 second using v1.01-cache-2.11-cpan-a9ef4e587e4 )