AnyEvent
view release on metacpan or search on metacpan
constants.pl.PL view on Meta::CPAN
use Config;
print "# generated for perl $] built for $Config{archname}\n";
# when built as part of perl, these are not available
BEGIN { eval "use Socket ()" }
BEGIN { eval "use Fcntl ()" }
BEGIN { eval "use POSIX ()" }
sub i($$) {
print "sub $_[0](){", $_[1]*1, "}\n";
}
sub n($$) {
print "sub $_[0](){", (defined $_[1] ? $_[1]*1 : "undef"), "}\n";
}
print "package AnyEvent;\n";
our $WIN32 = $^O =~ /mswin32/i;
# used a lot
i CYGWIN => $^O =~ /cygwin/i;
i WIN32 => $WIN32;
lib/AnyEvent.pm view on Meta::CPAN
$VERBOSE = length $ENV{PERL_ANYEVENT_VERBOSE} ? $ENV{PERL_ANYEVENT_VERBOSE}*1 : 4;
my $idx;
$PROTOCOL{$_} = ++$idx
for reverse split /\s*,\s*/,
$ENV{PERL_ANYEVENT_PROTOCOLS} || "ipv4,ipv6";
}
our @post_detect;
sub post_detect(&) {
my ($cb) = @_;
push @post_detect, $cb;
defined wantarray
? bless \$cb, "AnyEvent::Util::postdetect"
: ()
}
sub AnyEvent::Util::postdetect::DESTROY {
lib/AnyEvent.pm view on Meta::CPAN
our $POSTPONE_W;
our @POSTPONE;
sub _postpone_exec {
undef $POSTPONE_W;
&{ shift @POSTPONE }
while @POSTPONE;
}
sub postpone(&) {
push @POSTPONE, shift;
$POSTPONE_W ||= AE::timer (0, 0, \&_postpone_exec);
()
}
sub log($$;@) {
# only load the big bloated module when we actually are about to log something
if ($_[0] <= ($VERBOSE || 1)) { # also catches non-numeric levels(!) and fatal
local ($!, $@);
require AnyEvent::Log; # among other things, sets $VERBOSE to 9
# AnyEvent::Log overwrites this function
goto &log;
}
0 # not logged
}
sub _logger($;$) {
my ($level, $renabled) = @_;
$$renabled = $level <= $VERBOSE;
my $logger = [(caller)[0], $level, $renabled];
$AnyEvent::Log::LOGGER{$logger+0} = $logger;
# return unless defined wantarray;
#
lib/AnyEvent.pm view on Meta::CPAN
*_fh_nonblocking = AnyEvent::WIN32
? sub($$) {
ioctl $_[0], 0x8004667e, pack "L", $_[1]; # FIONBIO
}
: sub($$) {
fcntl $_[0], AnyEvent::F_SETFL, $_[1] ? AnyEvent::O_NONBLOCK : 0;
}
;
}
sub fh_block($) {
_fh_nonblocking shift, 0
}
sub fh_unblock($) {
_fh_nonblocking shift, 1
}
our @models = (
[EV:: => AnyEvent::Impl::EV::],
[AnyEvent::Loop:: => AnyEvent::Impl::Perl::],
# everything below here will not (normally) be autoprobed
# as the pure perl backend should work everywhere
# and is usually faster
[Irssi:: => AnyEvent::Impl::Irssi::], # Irssi has a bogus "Event" package, so msut be near the top
lib/AnyEvent.pm view on Meta::CPAN
my @pkg = ("AnyEvent", (map $_->[0], grep defined, @isa_hook), $MODEL);
@{"$pkg[$_-1]::ISA"} = $pkg[$_]
for 1 .. $#pkg;
grep $_ && $_->[1], @isa_hook
and AE::_reset ();
}
# used for hooking AnyEvent::Strict and AnyEvent::Debug::Wrap into the class hierarchy
sub _isa_hook($$;$) {
my ($i, $pkg, $reset_ae) = @_;
$isa_hook[$i] = $pkg ? [$pkg, $reset_ae] : undef;
_isa_set;
}
# all autoloaded methods reserve the complete glob, not just the method slot.
# due to bugs in perls method cache implementation.
our @methods = qw(io timer time now now_update signal child idle condvar);
sub detect() {
return $MODEL if $MODEL; # some programs keep references to detect
# IO::Async::Loop::AnyEvent is extremely evil, refuse to work with it
# the author knows about the problems and what it does to AnyEvent as a whole
# (and the ability of others to use AnyEvent), but simply wants to abuse AnyEvent
# anyway.
AnyEvent::log fatal => "IO::Async::Loop::AnyEvent detected - that module is broken by\n"
. "design, abuses internals and breaks AnyEvent - will not continue."
if exists $INC{"IO/Async/Loop/AnyEvent.pm"};
lib/AnyEvent.pm view on Meta::CPAN
# we use goto because
# a) it makes the thunk more transparent
# b) it allows us to delete the thunk later
goto &{ UNIVERSAL::can AnyEvent => "SUPER::$name" }
};
}
# utility function to dup a filehandle. this is used by many backends
# to support binding more than one watcher per filehandle (they usually
# allow only one watcher per fd, so we dup it to get a different one).
sub _dupfh($$;$$) {
my ($poll, $fh, $r, $w) = @_;
# cygwin requires the fh mode to be matching, unix doesn't
my ($rw, $mode) = $poll eq "r" ? ($r, "<&") : ($w, ">&");
open my $fh2, $mode, $fh
or die "AnyEvent->io: cannot dup() filehandle in mode '$poll': $!,";
# we assume CLOEXEC is already set by perl in all important cases
lib/AnyEvent.pm view on Meta::CPAN
overhead by using function call syntax and a fixed number of parameters.
See the L<AE> manpage for details.
=cut
package AE;
our $VERSION = $AnyEvent::VERSION;
sub _reset() {
eval q{
# fall back to the main API by default - backends and AnyEvent::Base
# implementations can overwrite these.
sub io($$$) {
AnyEvent->io (fh => $_[0], poll => $_[1] ? "w" : "r", cb => $_[2])
}
sub timer($$$) {
AnyEvent->timer (after => $_[0], interval => $_[1], cb => $_[2])
lib/AnyEvent.pm view on Meta::CPAN
};
die if $@;
&condvar
}
# default implementation for ->signal
our $HAVE_ASYNC_INTERRUPT;
sub _have_async_interrupt() {
$HAVE_ASYNC_INTERRUPT = 1*(!$ENV{PERL_ANYEVENT_AVOID_ASYNC_INTERRUPT}
&& eval "use Async::Interrupt 1.02 (); 1")
unless defined $HAVE_ASYNC_INTERRUPT;
$HAVE_ASYNC_INTERRUPT
}
our ($SIGPIPE_R, $SIGPIPE_W, %SIG_CB, %SIG_EV, $SIG_IO);
our (%SIG_ASY, %SIG_ASY_W);
our ($SIG_COUNT, $SIG_TW);
# install a dummy wakeup watcher to reduce signal catching latency
# used by Impls
sub _sig_add() {
unless ($SIG_COUNT++) {
# try to align timer on a full-second boundary, if possible
my $NOW = AE::now;
$SIG_TW = AE::timer
$MAX_SIGNAL_LATENCY - ($NOW - int $NOW),
$MAX_SIGNAL_LATENCY,
sub { } # just for the PERL_ASYNC_CHECK
;
}
lib/AnyEvent.pm view on Meta::CPAN
};
*sig2name = sub ($) {
$_[0] > 0 ? $signum2name[+shift] : shift
};
}
};
die if $@;
};
sub sig2num ($) { &$_sig_name_init; &sig2num }
sub sig2name($) { &$_sig_name_init; &sig2name }
sub signal {
eval q{ # poor man's autoloading {}
# probe for availability of Async::Interrupt
if (_have_async_interrupt) {
AnyEvent::log 8 => "Using Async::Interrupt for race-free signal handling.";
$SIGPIPE_R = new Async::Interrupt::EventPipe;
$SIG_IO = AE::io $SIGPIPE_R->fileno, 0, \&_signal_exec;
lib/AnyEvent.pm view on Meta::CPAN
&signal
}
# default implementation for ->child
our %PID_CB;
our $CHLD_W;
our $CHLD_DELAY_W;
# used by many Impl's
sub _emit_childstatus($$) {
my (undef, $rpid, $rstatus) = @_;
$_->($rpid, $rstatus)
for values %{ $PID_CB{$rpid} || {} },
values %{ $PID_CB{0} || {} };
}
sub child {
eval q{ # poor man's autoloading {}
*_sigchld = sub {
lib/AnyEvent/DNS.pm view on Meta::CPAN
verified that the hostname, at one point in the past, pointed at the IP
address you originally resolved.
Example:
AnyEvent::DNS::reverse_verify "2001:500:2f::f", sub { print shift };
# => f.root-servers.net
=cut
sub MAX_PKT() { 4096 } # max packet size we advertise and accept
sub DOMAIN_PORT() { 53 } # if this changes drop me a note
sub resolver ();
sub a($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "a", sub {
$cb->(map $_->[4], @_);
});
}
sub aaaa($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "aaaa", sub {
$cb->(map $_->[4], @_);
});
}
sub mx($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "mx", sub {
$cb->(map $_->[5], sort { $a->[4] <=> $b->[4] } @_);
});
}
sub ns($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "ns", sub {
$cb->(map $_->[4], @_);
});
}
sub txt($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "txt", sub {
$cb->(map $_->[4], @_);
});
}
sub srv($$$$) {
my ($service, $proto, $domain, $cb) = @_;
# todo, ask for any and check glue records
resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
my @res;
# classify by priority
my %pri;
push @{ $pri{$_->[4]} }, [ @$_[4,5,6,7] ]
for @_;
lib/AnyEvent/DNS.pm view on Meta::CPAN
last;
}
}
}
}
$cb->(@res);
});
}
sub ptr($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "ptr", sub {
$cb->(map $_->[4], @_);
});
}
sub any($$) {
my ($domain, $cb) = @_;
resolver->resolve ($domain => "*", $cb);
}
# convert textual ip address into reverse lookup form
sub _munge_ptr($) {
my $ipn = $_[0]
or return;
my $ptr;
my $af = AnyEvent::Socket::address_family ($ipn);
if ($af == AF_INET6) {
$ipn = substr $ipn, 0, 16; # anticipate future expansion
lib/AnyEvent/DNS.pm view on Meta::CPAN
}
}
if ($af == AF_INET) {
$ptr = join ".", (reverse unpack "C4", $ipn), "in-addr.arpa.";
}
$ptr
}
sub reverse_lookup($$) {
my ($ip, $cb) = @_;
$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
or return $cb->();
resolver->resolve ($ip => "ptr", sub {
$cb->(map $_->[4], @_);
});
}
sub reverse_verify($$) {
my ($ip, $cb) = @_;
my $ipn = AnyEvent::Socket::parse_address ($ip)
or return $cb->();
my $af = AnyEvent::Socket::address_family ($ipn);
my @res;
my $cnt;
lib/AnyEvent/DNS.pm view on Meta::CPAN
our %class_id = (
in => 1,
ch => 3,
hs => 4,
none => 254,
"*" => 255,
);
our %class_str = reverse %class_id;
sub _enc_name($) {
pack "(C/a*)*", (split /\./, shift), ""
}
if ($] < 5.008) {
# special slower 5.6 version
*_enc_name = sub ($) {
join "", map +(pack "C/a*", $_), (split /\./, shift), ""
};
}
sub _enc_qd() {
(_enc_name $_->[0]) . pack "nn",
($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
($_->[3] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
}
sub _enc_rr() {
die "encoding of resource records is not supported";
}
=item $pkt = AnyEvent::DNS::dns_pack $dns
Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
recommended, then everything will be totally clear. Or maybe not.
Resource records are not yet encodable.
lib/AnyEvent/DNS.pm view on Meta::CPAN
cd => 0,
qd => [@rr], # query section
an => [@rr], # answer section
ns => [@rr], # authority section
ar => [@rr], # additional records section
}
=cut
sub dns_pack($) {
my ($req) = @_;
pack "nn nnnn a* a* a* a* a*",
$req->{id},
! !$req->{qr} * 0x8000
+ $opcode_id{$req->{op}} * 0x0800
+ ! !$req->{aa} * 0x0400
+ ! !$req->{tc} * 0x0200
+ ! !$req->{rd} * 0x0100
lib/AnyEvent/DNS.pm view on Meta::CPAN
[ 'www.l.google.com', 'a', 'in', 3600, '66.249.93.104' ],
[ 'www.l.google.com', 'a', 'in', 3600, '66.249.93.147' ],
],
'rd' => 1,
'op' => 0,
'__' => '<original dns packet>',
}
=cut
sub dns_unpack($) {
local $pkt = shift;
my ($id, $flags, $qd, $an, $ns, $ar)
= unpack "nn nnnn A*", $pkt;
local $ofs = 6 * 2;
{
__ => $pkt,
id => $id,
qr => ! ! ($flags & 0x8000),
lib/AnyEvent/DNS.pm view on Meta::CPAN
been instantiated yet.
One can provide a custom resolver (e.g. one with caching functionality)
by storing it in this variable, causing all subsequent resolves done via
C<AnyEvent::DNS::resolver> to be done via the custom one.
=cut
our $RESOLVER;
sub resolver() {
$RESOLVER || do {
$RESOLVER = new AnyEvent::DNS
untaint => 1,
max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 10,
;
$ENV{PERL_ANYEVENT_RESOLV_CONF}
? $RESOLVER->_load_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF})
: $RESOLVER->os_config;
lib/AnyEvent/DNS.pm view on Meta::CPAN
response. It handles timeouts, retries and automatically falls back to
virtual circuit mode (TCP) when it receives a truncated reply. It does not
handle anything else, such as the domain searchlist or relative names -
use C<< ->resolve >> for that.
Calls the callback with the decoded response packet if a reply was
received, or no arguments in case none of the servers answered.
=cut
sub request($$) {
my ($self, $req, $cb) = @_;
# _enc_name barfs on names that are too long, which is often outside
# program control, so check for too long names here.
for (@{ $req->{qd} }) {
return AE::postpone sub { $cb->(undef) }
if 255 < length $_->[0];
}
push @{ $self->{queue} }, [dns_pack $req, $cb];
lib/AnyEvent/DNS.pm view on Meta::CPAN
);
# result:
# [
# [ 'test1.laendle', 'a', 'in', 86400, '10.0.0.255' ],
# [ 'test1.laendle', 'aaaa', 'in', 60, '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
# ]
=cut
sub resolve($%) {
my $cb = pop;
my ($self, $qname, $qtype, %opt) = @_;
$self->wait_for_slot (sub {
my $self = shift;
my @search = $qname =~ s/\.$//
? ""
: $opt{search}
? @{ $opt{search} }
lib/AnyEvent/Debug.pm view on Meta::CPAN
other tools, such as telnet:
our $SHELL = AnyEvent::Debug::shell "127.1", "1357";
And then:
telnet localhost 1357
=cut
sub shell($$) {
local $TRACE = 0;
AnyEvent::Socket::tcp_server $_[0], $_[1], sub {
my ($fh, $host, $port) = @_;
syswrite $fh, "Welcome, $host:$port, use 'help' for more info!\015\012> ";
my $rbuf;
my $logger = new AnyEvent::Log::Ctx
log_cb => sub {
lib/AnyEvent/Debug.pm view on Meta::CPAN
If you are developing your program, also consider using AnyEvent::Strict
to check for common mistakes.
=cut
our $WRAP_LEVEL;
our $TRACE_CUR;
our $POST_DETECT;
sub wrap(;$) {
my $PREV_LEVEL = $WRAP_LEVEL;
$WRAP_LEVEL = @_ ? 0+shift : $WRAP_LEVEL ? 0 : 1;
if ($AnyEvent::MODEL) {
if ($WRAP_LEVEL && !$PREV_LEVEL) {
$TRACE_LOGGER = AnyEvent::Log::logger trace => \$TRACE_ENABLED;
AnyEvent::_isa_hook 0 => "AnyEvent::Debug::Wrap", 1;
AnyEvent::Debug::Wrap::_reset ();
} elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
AnyEvent::_isa_hook 0 => undef;
lib/AnyEvent/Debug.pm view on Meta::CPAN
Tries to replace a path (e.g. the file name returned by caller)
by a module name. Returns the path unchanged if it fails.
Example:
print AnyEvent::Debug::path2mod "/usr/lib/perl5/AnyEvent/Debug.pm";
# might print "AnyEvent::Debug"
=cut
sub path2mod($) {
keys %INC; # reset iterator
while (my ($k, $v) = each %INC) {
if ($_[0] eq $v) {
$k =~ s%/%::%g if $k =~ s/\.pm$//;
return $k;
}
}
my $path = shift;
lib/AnyEvent/Debug.pm view on Meta::CPAN
=item AnyEvent::Debug::cb2str $cb
Using various gambits, tries to convert a callback (e.g. a code reference)
into a more useful string.
Very useful if you debug a program and have some callback, but you want to
know where in the program the callback is actually defined.
=cut
sub cb2str($) {
my $cb = shift;
"CODE" eq ref $cb
or return "$cb";
eval {
my $cv = B::svref_2object ($cb);
my $gv = $cv->GV
or return "$cb";
my $name = $gv->NAME;
return (AnyEvent::Debug::path2mod $gv->FILE) . ":" . $gv->LINE
if $name eq "__ANON__";
$gv->STASH->NAME . "::" . $name;
} || "$cb"
}
sub sv2str($) {
if (ref $_[0]) {
if (ref $_[0] eq "CODE") {
return "$_[0]=" . cb2str $_[0];
} else {
return "$_[0]";
}
} else {
for ("\'$_[0]\'") { # make copy
substr $_, $Carp::MaxArgLen, length, "'..."
if length > $Carp::MaxArgLen;
lib/AnyEvent/Debug.pm view on Meta::CPAN
Carp module it resolves some references (such as callbacks) to more
user-friendly strings, has a more succinct output format and most
importantly: doesn't leak memory like hell.
The reason it creates an object is to save time, as formatting can be
done at a later time. Still, creating a backtrace is a relatively slow
operation.
=cut
sub backtrace(;$) {
my $w = shift;
my (@bt, @c);
my ($modlen, $sub);
for (;;) {
# 0 1 2 3 4 5 6 7 8 9 10
# ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
package DB;
@c = caller $w++
lib/AnyEvent/Handle.pm view on Meta::CPAN
use Scalar::Util ();
use List::Util ();
use Carp ();
use Errno qw(EAGAIN EWOULDBLOCK EINTR);
use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util qw(WSAEWOULDBLOCK);
our $VERSION = $AnyEvent::VERSION;
sub _load_func($) {
my $func = $_[0];
unless (defined &$func) {
my $pkg = $func;
do {
$pkg =~ s/::[^:]+$//
or return;
eval "require $pkg";
} until defined &$func;
}
\&$func
}
sub MAX_READ_SIZE() { 131072 }
=head1 METHODS
=over 4
=item $handle = B<new> AnyEvent::Handle fh => $filehandle, key => value...
The constructor supports these arguments (all as C<< key => value >> pairs).
=over 4
lib/AnyEvent/Handle.pm view on Meta::CPAN
&& $self->{wbuf_max} < length $self->{wbuf}
) {
$self->_error (Errno::ENOSPC, 1), return;
}
};
}
our %WH;
# deprecated
sub register_write_type($$) {
$WH{$_[0]} = $_[1];
}
sub push_write {
my $self = shift;
if (@_ > 1) {
my $type = shift;
@_ = ($WH{$type} ||= _load_func "$type\::anyevent_write_type"
lib/AnyEvent/Handle.pm view on Meta::CPAN
recommended):
$handle->push_write (cbor => ["method", "arg1", "arg2"]); # whatever
An AnyEvent::Handle receiver would simply use the C<cbor> read type:
$handle->push_read (cbor => sub { my $array = $_[1]; ... });
=cut
sub json_coder() {
eval { require JSON::XS; JSON::XS->new->utf8 }
|| do { require JSON::PP; JSON::PP->new->utf8 }
}
register_write_type json => sub {
my ($self, $ref) = @_;
($self->{json} ||= json_coder)
->encode ($ref)
};
sub cbor_coder() {
require CBOR::XS;
CBOR::XS->new
}
register_write_type cbor => sub {
my ($self, $scalar) = @_;
($self->{cbor} ||= cbor_coder)
->encode ($scalar)
};
lib/AnyEvent/Handle.pm view on Meta::CPAN
interested in (which can be none at all) and return a true value. After returning
true, it will be removed from the queue.
These methods may invoke callbacks (and therefore the handle might be
destroyed after it returns).
=cut
our %RH;
sub register_read_type($$) {
$RH{$_[0]} = $_[1];
}
sub push_read {
my $self = shift;
my $cb = pop;
if (@_) {
my $type = shift;
lib/AnyEvent/Handle.pm view on Meta::CPAN
This function creates and returns the AnyEvent::TLS object used by default
for TLS mode.
The context is created by calling L<AnyEvent::TLS> without any arguments.
=cut
our $TLS_CTX;
sub TLS_CTX() {
$TLS_CTX ||= do {
require AnyEvent::TLS;
new AnyEvent::TLS
}
}
=back
lib/AnyEvent/IO/IOAIO.pm view on Meta::CPAN
use AnyEvent (); BEGIN { AnyEvent::common_sense }
our $VERSION = $AnyEvent::VERSION;
package AnyEvent::IO;
use IO::AIO 4.13 ();
use AnyEvent::AIO ();
our $MODEL = "AnyEvent::IO::IOAIO";
sub aio_load($$) {
my ($cb, $data) = $_[1];
IO::AIO::aio_load $_[0], $data, sub { $cb->($_[0] >= 0 ? $data : ()) };
}
sub aio_open($$$$) {
my $cb = $_[3];
IO::AIO::aio_open $_[0], $_[1], $_[2], sub { $cb->($_[0] or ()) };
}
sub aio_close($$) {
my $cb = $_[1];
IO::AIO::aio_close $_[0], sub { $cb->($_[0] >= 0 ? 1 : ()) };
}
sub aio_seek($$$$) {
my ($cb) = $_[3];
IO::AIO::aio_seek $_[0], $_[1], $_[2], sub { $cb->($_[0] >= 0 ? $_[0] : ()) };
}
sub aio_read($$$) {
my ($cb, $data) = $_[2];
IO::AIO::aio_read $_[0], undef, $_[1], $data, 0, sub { $cb->($_[0] >= 0 ? $data : ()) };
}
sub aio_write($$$) {
my $cb = $_[2];
IO::AIO::aio_write $_[0], undef, (length $_[1]), $_[1], 0,
sub { $cb->($_[0] >= 0 ? $_[0] : ()) };
}
sub aio_truncate($$$) {
my $cb = $_[2];
IO::AIO::aio_truncate $_[0], $_[1], sub { $cb->($_[0] ? () : 1) };
}
sub aio_utime($$$$) {
my $cb = $_[3];
IO::AIO::aio_utime $_[0], $_[1], $_[2], sub { $cb->($_[0] ? () : 1) };
}
sub aio_chown($$$$) {
my $cb = $_[3];
IO::AIO::aio_chown $_[0], $_[1], $_[2], sub { $cb->($_[0] ? () : 1) };
}
sub aio_chmod($$$) {
my $cb = $_[2];
IO::AIO::aio_chmod $_[0], $_[1], sub { $cb->($_[0] ? () : 1) };
}
sub aio_stat($$) {
my $cb = $_[1];
IO::AIO::aio_stat $_[0], sub { $cb->($_[0] ? () : 1) };
}
sub aio_lstat($$) {
my $cb = $_[1];
IO::AIO::aio_lstat $_[0], sub { $cb->($_[0] ? () : 1) }
}
sub aio_link($$$) {
my $cb = $_[2];
IO::AIO::aio_link $_[0], $_[1], sub { $cb->($_[0] ? () : 1) };
}
sub aio_symlink($$$) {
my $cb = $_[2];
IO::AIO::aio_symlink $_[0], $_[1], sub { $cb->($_[0] ? () : 1) };
}
sub aio_readlink($$) {
my $cb = $_[1];
IO::AIO::aio_readlink $_[0], sub { $cb->(defined $_[0] ? $_[0] : ()) };
}
sub aio_rename($$$) {
my $cb = $_[2];
IO::AIO::aio_rename $_[0], $_[1], sub { $cb->($_[0] ? () : 1) };
}
sub aio_unlink($$) {
my $cb = $_[1];
IO::AIO::aio_unlink $_[0], sub { $cb->($_[0] ? () : 1) };
}
sub aio_mkdir($$$) {
my $cb = $_[2];
IO::AIO::aio_mkdir $_[0], $_[1], sub { $cb->($_[0] ? () : 1) };
}
sub aio_rmdir($$) {
my $cb = $_[1];
IO::AIO::aio_rmdir $_[0], sub { $cb->($_[0] ? () : 1) };
}
sub aio_readdir($$) {
my $cb = $_[1];
IO::AIO::aio_readdirx $_[0], IO::AIO::READDIR_DIRS_FIRST | IO::AIO::READDIR_STAT_ORDER,
sub { $cb->($_[0] or ()); };
}
=back
=head1 SEE ALSO
lib/AnyEvent/IO/Perl.pm view on Meta::CPAN
package AnyEvent::IO::Perl;
use AnyEvent (); BEGIN { AnyEvent::common_sense }
our $VERSION = $AnyEvent::VERSION;
package AnyEvent::IO;
our $MODEL = "AnyEvent::IO::Perl";
sub aio_load($$) {
my ($path, $cb, $fh, $data) = @_;
$cb->(
(open $fh, "<:raw:perlio", $path
and stat $fh
and (-s _) == sysread $fh, $data, -s _)
? $data : ()
);
}
sub aio_open($$$$) {
sysopen my $fh, $_[0], $_[1], $_[2]
or return $_[3]();
$_[3]($fh)
}
sub aio_close($$) {
$_[1](close $_[0]);
}
sub aio_seek($$$$) {
my $data;
$_[3](sysseek $_[0], $_[1], $_[2] or ());
}
sub aio_read($$$) {
my $data;
$_[2]( (defined sysread $_[0], $data, $_[1]) ? $data : () );
}
sub aio_write($$$) {
my $res = syswrite $_[0], $_[1];
$_[2](defined $res ? $res : ());
}
sub aio_truncate($$$) {
#TODO: raises an exception on !truncate|ftruncate systems, maybe eval + set errno?
$_[2](truncate $_[0], $_[1] or ());
}
sub aio_utime($$$$) {
$_[3](utime $_[1], $_[2], $_[0] or ());
}
sub aio_chown($$$$) {
$_[3](chown defined $_[1] ? $_[1] : -1, defined $_[2] ? $_[2] : -1, $_[0] or ());
}
sub aio_chmod($$$) {
$_[2](chmod $_[1], $_[0] or ());
}
sub aio_stat($$) {
$_[1](stat $_[0]);
}
sub aio_lstat($$) {
$_[1](lstat $_[0]);
}
sub aio_link($$$) {
$_[2](link $_[0], $_[1] or ());
}
sub aio_symlink($$$) {
#TODO: raises an exception on !symlink systems, maybe eval + set errno?
$_[2](symlink $_[0], $_[1] or ());
}
sub aio_readlink($$) {
#TODO: raises an exception on !symlink systems, maybe eval + set errno?
my $res = readlink $_[0];
$_[1](defined $res ? $res : ());
}
sub aio_rename($$$) {
$_[2](rename $_[0], $_[1] or ());
}
sub aio_unlink($$) {
$_[1](unlink $_[0] or ());
}
sub aio_mkdir($$$) {
$_[2](mkdir $_[0], $_[1] or ());
}
sub aio_rmdir($$) {
$_[1](rmdir $_[0] or ());
}
sub aio_readdir($$) {
my ($fh, @res);
opendir $fh, $_[0]
or return $_[1]();
@res = grep !/^\.\.?$/, readdir $fh;
$_[1]((closedir $fh) ? \@res : ());
}
lib/AnyEvent/Impl/IOAsync.pm view on Meta::CPAN
use AnyEvent (); BEGIN { AnyEvent::common_sense }
use Time::HiRes ();
use Scalar::Util ();
use IO::Async::Loop 0.33;
our $LOOP = new IO::Async::Loop;
sub set_loop($) {
$LOOP = $_[0];
}
sub timer {
my ($class, %arg) = @_;
my $cb = $arg{cb};
my $id;
lib/AnyEvent/Log.pm view on Meta::CPAN
use AnyEvent (); BEGIN { AnyEvent::common_sense }
#use AnyEvent::Util (); need to load this in a delayed fashion, as it uses AE::log
our $VERSION = $AnyEvent::VERSION;
our ($COLLECT, $FILTER, $LOG);
our ($now_int, $now_str1, $now_str2);
# Format Time, not public - yet?
sub format_time($) {
my $i = int $_[0];
my $f = sprintf "%06d", 1e6 * ($_[0] - $i);
($now_int, $now_str1, $now_str2) = ($i, split /\x01/, POSIX::strftime "%Y-%m-%d %H:%M:%S.\x01 %z", localtime $i)
if $now_int != $i;
"$now_str1$f$now_str2"
}
our %CTX; # all package contexts
# creates a default package context object for the given package
sub _pkg_ctx($) {
my $ctx = bless [$_[0], (1 << 10) - 1 - 1, {}], "AnyEvent::Log::Ctx";
# link "parent" package
my $parent = $_[0] =~ /^(.+)::/
? $CTX{$1} ||= &_pkg_ctx ("$1")
: $COLLECT;
$ctx->[2]{$parent+0} = $parent;
$ctx
lib/AnyEvent/Log.pm view on Meta::CPAN
error => 4, err => 4, die => 4,
warn => 5, warning => 5,
note => 6, notice => 6,
info => 7,
debug => 8,
trace => 9,
);
our $TIME_EXACT;
sub exact_time($) {
$TIME_EXACT = shift;
*_ts = $AnyEvent::MODEL
? $TIME_EXACT ? \&AE::now : \&AE::time
: sub () { $TIME_EXACT ? do { require Time::HiRes; Time::HiRes::time () } : time };
}
BEGIN {
exact_time 0;
}
AnyEvent::post_detect {
exact_time $TIME_EXACT;
};
our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);
# time, ctx, level, msg
sub default_format($$$$) {
my $ts = format_time $_[0];
my $ct = " ";
my @res;
for (split /\n/, sprintf "%-5s %s: %s", $LEVEL2STR[$_[2]], $_[1][0], $_[3]) {
push @res, "$ts$ct$_\n";
$ct = " + ";
}
join "", @res
}
sub fatal_exit() {
exit 1;
}
sub _log {
my ($ctx, $level, $format, @args) = @_;
$level = $level > 0 && $level <= 9
? $level+0
: $STR2LEVEL{$level} || Carp::croak "$level: not a valid logging level, caught";
lib/AnyEvent/Log.pm view on Meta::CPAN
}
}
}
while $ctx = pop @ctx;
fatal_exit if $level <= 1;
$success
}
sub log($$;@) {
_log
$CTX{ (caller)[0] } ||= _pkg_ctx +(caller)[0],
@_;
}
=item $logger = AnyEvent::Log::logger $level[, \$enabled]
Creates a code reference that, when called, acts as if the
C<AnyEvent::Log::log> function was called at this point with the given
level. C<$logger> is passed a C<$msg> and optional C<@args>, just as with
lib/AnyEvent/Log.pm view on Meta::CPAN
});
sub {
$guard if 0; # keep guard alive, but don't cause runtime overhead
_log $ctx, $level, @_
if $$renabled;
}
}
sub logger($;$) {
_logger
$CTX{ (caller)[0] } ||= _pkg_ctx +(caller)[0],
@_
}
=item AnyEvent::Log::exact_time $on
By default, C<AnyEvent::Log> will use C<AE::now>, i.e. the cached
eventloop time, for the log timestamps. After calling this function with a
true value it will instead resort to C<AE::time>, i.e. fetch the current
lib/AnyEvent/Log.pm view on Meta::CPAN
If a package name is given, then the context for that package is
returned. If it is called without any arguments, then the context for the
callers package is returned (i.e. the same context as a C<AE::log> call
would use).
If C<undef> is given, then it creates a new anonymous context that is not
tied to any package and is destroyed when no longer referenced.
=cut
sub ctx(;$) {
my $pkg = @_ ? shift : (caller)[0];
ref $pkg
? $pkg
: defined $pkg
? $CTX{$pkg} ||= AnyEvent::Log::_pkg_ctx $pkg
: bless [undef, (1 << 10) - 1 - 1], "AnyEvent::Log::Ctx"
}
=item AnyEvent::Log::reset
lib/AnyEvent/Loop.pm view on Meta::CPAN
use Scalar::Util qw(weaken);
use List::Util ();
use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util ();
our $VERSION = $AnyEvent::VERSION;
our ($NOW, $MNOW);
sub MAXWAIT() { 3600 } # never sleep for longer than this many seconds
BEGIN {
local $SIG{__DIE__}; # protect us against the many broken __DIE__ handlers out there
my $time_hires = eval "use Time::HiRes (); 1";
my $clk_tck = eval "use POSIX (); POSIX::sysconf (POSIX::_SC_CLK_TCK ())";
my $round; # actual granularity
if ($time_hires && eval "&Time::HiRes::clock_gettime (Time::HiRes::CLOCK_MONOTONIC ())") {
AE::log 8 => "Using CLOCK_MONOTONIC as timebase.";
*_update_clock = sub {
lib/AnyEvent/Loop.pm view on Meta::CPAN
$round = 0.001 if $round < 0.001; # 1ms is enough for us
$round -= $round * 1e-2; # 0.1 => 0.099
eval "sub ROUNDUP() { $round }";
}
_update_clock;
# rely on AnyEvent:Base::time to provide time
sub now () { $NOW }
sub now_update() { _update_clock }
# fds[0] is for read, fds[1] is for write watchers
# fds[poll][V] is the bitmask for select
# fds[poll][W][fd] contains a list of i/o watchers
# an I/O watcher is a blessed arrayref containing [fh, poll(0/1), callback, queue-index]
# the queue-index is simply the index in the [W] array, which is only used to improve
# benchmark results in the synthetic "many watchers on one fd" benchmark.
my @fds = ([], []);
sub V() { 0 }
sub W() { 1 }
my $need_sort = 1e300; # when to re-sort timer list
my @timer; # list of [ abs-timeout, Timer::[callback] ]
my @idle; # list of idle callbacks
# the pure perl mainloop
sub one_event {
_update_clock;
# first sort timers if required (slow)
lib/AnyEvent/Loop.pm view on Meta::CPAN
} elsif (!@timer || $timer[0][0] > $MNOW && !$fds) {
$$$_ && $$$_->() for @idle = grep $$$_, @idle;
}
}
}
sub run {
one_event while 1;
}
sub io($$$) {
my ($fd, $write, $cb) = @_;
defined ($fd = fileno $fd)
or $fd = $_[0];
my $self = bless [
$fd,
$write,
$cb,
# q-idx
lib/AnyEvent/Loop.pm view on Meta::CPAN
my $q = $fds->[W][$fd];
my $last = pop @$q;
if ($last != $self) {
weaken ($q->[$self->[3]] = $last);
$last->[3] = $self->[3];
}
}
}
sub timer($$$) {
my ($after, $interval, $cb) = @_;
my $self;
if ($interval) {
$self = [$MNOW + $after , sub {
$_[0][0] = List::Util::max $_[0][0] + $interval, $MNOW;
push @timer, $_[0];
weaken $timer[-1];
$need_sort = $_[0][0] if $_[0][0] < $need_sort;
lib/AnyEvent/Loop.pm view on Meta::CPAN
$self = [$MNOW + $after, $cb];
}
push @timer, $self;
weaken $timer[-1];
$need_sort = $self->[0] if $self->[0] < $need_sort;
$self
}
sub idle($) {
my $cb = shift;
push @idle, \\$cb;
weaken ${$idle[-1]};
${$idle[-1]}
}
=head1 SEE ALSO
lib/AnyEvent/Socket.pm view on Meta::CPAN
=item $ipn = parse_ipv4 $dotted_quad
Tries to parse the given dotted quad IPv4 address and return it in
octet form (or undef when it isn't in a parsable format). Supports all
forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>,
C<0x12345678> or C<0377.0377.0377.0377>).
=cut
sub parse_ipv4($) {
$_[0] =~ /^ (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* )
(?:\. (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) ){0,3}$/x
or return undef;
@_ = map /^0/ ? oct : $_, split /\./, $_[0];
# check leading parts against range
return undef if grep $_ >= 256, @_[0 .. @_ - 2];
# check trailing part against range
lib/AnyEvent/Socket.pm view on Meta::CPAN
Example:
print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
# => 2002534500000000000000000a000001
print unpack "H*", parse_ipv6 "192.89.98.1";
# => 00000000000000000000ffffc0596201
=cut
sub parse_ipv6($) {
# quick test to avoid longer processing
my $n = $_[0] =~ y/://;
if ($n < 2 || $n > 8) {
if (!$n && (my $ipn = parse_ipv4 $_[0])) {
return "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff$ipn";
}
return undef;
}
lib/AnyEvent/Socket.pm view on Meta::CPAN
This function exists mainly for symmetry to the other C<parse_protocol>
functions - it takes a hostname and, if it is C<unix/>, it returns a
special address token, otherwise C<undef>.
The only use for this function is probably to detect whether a hostname
matches whatever AnyEvent uses for unix domain sockets.
=cut
sub parse_unix($) {
$_[0] eq "unix/"
? pack "S", AF_UNIX
: undef
}
=item $ipn = parse_address $ip
Combines C<parse_ipv4>, C<parse_ipv6> and C<parse_unix> in one
function. The address here refers to the host address (not socket address)
lib/AnyEvent/Socket.pm view on Meta::CPAN
print unpack "H*", parse_address "10.1.2.3";
# => 0a010203
=item $ipn = AnyEvent::Socket::aton $ip
Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
I<without> name resolution).
=cut
sub parse_address($) {
for (&parse_ipv6) {
if ($_) {
s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
return $_
} else {
return &parse_unix
}
}
}
lib/AnyEvent/Socket.pm view on Meta::CPAN
# microsoft can't even get getprotobyname working (the etc/protocols file
# gets lost fairly often on windows), so we have to hardcode some common
# protocol numbers ourselves.
our %PROTO_BYNAME;
$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
sub getprotobyname($) {
my $name = lc shift;
defined (my $proton = $PROTO_BYNAME{$name} || (getprotobyname $name)[2])
or return;
($name, uc $name, $proton)
}
=item ($host, $service) = parse_hostport $string[, $default_service]
lib/AnyEvent/Socket.pm view on Meta::CPAN
# => "localhost,https"
print join ",", parse_hostport "[::1]";
# => "," (empty list)
print join ",", parse_hostport "/tmp/debug.sock";
# => "unix/", "/tmp/debug.sock"
=cut
sub parse_hostport($;$) {
my ($host, $port);
for ("$_[0]") { # work on a copy, just in case, and also reset pos
# shortcut for /path
return ("unix/", $_)
if m%^/%;
# parse host, special cases: "ipv6" or "ipv6[#p ]port"
unless (
lib/AnyEvent/Socket.pm view on Meta::CPAN
($host, $port)
}
=item $string = format_hostport $host, $port
Takes a host (in textual form) and a port and formats in unambigiously in
a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
=cut
sub format_hostport($;$) {
my ($host, $port) = @_;
$port = ":$port" if length $port;
$host = "[$host]" if $host =~ /:/;
"$host$port"
}
=item $sa_family = address_family $ipn
Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
of the given host address in network format.
=cut
sub address_family($) {
4 == length $_[0]
? AF_INET
: 16 == length $_[0]
? AF_INET6
: unpack "S", $_[0]
}
=item $text = format_ipv4 $ipn
Expects a four octet string representing a binary IPv4 address and returns
lib/AnyEvent/Socket.pm view on Meta::CPAN
print format_address "\x01\x02\x03\x05";
=> 1.2.3.5
=item $text = AnyEvent::Socket::ntoa $ipn
Same as format_address, but not exported (think C<inet_ntoa>).
=cut
sub format_ipv4($) {
join ".", unpack "C4", $_[0]
}
sub format_ipv6($) {
if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
return "::";
} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
return "::1";
} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
# v4compatible
return "::" . format_ipv4 substr $_[0], 12;
} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
# v4mapped
lib/AnyEvent/Socket.pm view on Meta::CPAN
$ip =~ s/(?:^|:) 0:0:0:0:0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0:0:0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0:0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0 (?:$|:)/::/x;
$ip
}
sub format_address($) {
if (4 == length $_[0]) {
return &format_ipv4;
} elsif (16 == length $_[0]) {
return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s
? format_ipv4 $1
: &format_ipv6;
} elsif (AF_UNIX == address_family $_[0]) {
return "unix/"
} else {
return undef
lib/AnyEvent/Socket.pm view on Meta::CPAN
pathname).
Example:
my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120;
bind $socket, $bind
or die "bind: $!";
=cut
sub pack_sockaddr($$) {
my $af = address_family $_[1];
if ($af == AF_INET) {
Socket::pack_sockaddr_in $_[0], $_[1]
} elsif ($af == AF_INET6) {
pack "$pack_family nL a16 L",
AF_INET6,
$_[0], # port
0, # flowinfo
$_[1], # addr
lib/AnyEvent/Socket.pm view on Meta::CPAN
# by any standard). try to 0-pad structures for the benefit of those platforms.
# unfortunately, the IO::Async author chose to break Socket again in version
# 2.011 - it now contains a bogus length check, so we disable the workaround.
my $sa_un_zero = $Socket::VERSION >= 2.011
? ""
: eval { Socket::pack_sockaddr_un "" };
$sa_un_zero ^= $sa_un_zero;
sub unpack_sockaddr($) {
my $af = sockaddr_family $_[0];
if ($af == AF_INET) {
Socket::unpack_sockaddr_in $_[0]
} elsif ($af == AF_INET6) {
unpack "x2 n x4 a16", $_[0]
} elsif ($af == AF_UNIX) {
((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
} else {
Carp::croak "unpack_sockaddr: unsupported protocol family $af";
lib/AnyEvent/Socket.pm view on Meta::CPAN
Example:
resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
=cut
our %HOSTS; # $HOSTS{$nodename}[$ipv6] = [@aliases...]
our @HOSTS_CHECKING; # callbacks to call when hosts have been loaded
our $HOSTS_MTIME;
sub _parse_hosts($) {
%HOSTS = ();
for (split /\n/, $_[0]) {
s/#.*$//;
s/^[ \t]+//;
y/A-Z/a-z/;
my ($addr, @aliases) = split /[ \t]+/;
next unless @aliases;
lib/AnyEvent/Socket.pm view on Meta::CPAN
for @aliases;
} elsif (my $ip = parse_ipv6 $addr) {
($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT;
push @{ $HOSTS{$_}[1] }, $ip
for @aliases;
}
}
}
# helper function - unless dns delivered results, check and parse hosts, then call continuation code
sub _load_hosts_unless(&$@) {
my ($cont, $cv, @dns) = @_;
if (@dns) {
$cv->end;
} else {
my $etc_hosts = length $ENV{PERL_ANYEVENT_HOSTS} ? $ENV{PERL_ANYEVENT_HOSTS}
: AnyEvent::WIN32 ? "$ENV{SystemRoot}/system32/drivers/etc/hosts"
: "/etc/hosts";
push @HOSTS_CHECKING, sub {
lib/AnyEvent/Socket.pm view on Meta::CPAN
(shift @HOSTS_CHECKING)->() while @HOSTS_CHECKING;
});
} else {
(shift @HOSTS_CHECKING)->() while @HOSTS_CHECKING;
}
});
}
}
}
sub resolve_sockaddr($$$$$$) {
my ($node, $service, $proto, $family, $type, $cb) = @_;
if ($node eq "unix/") {
return $cb->() if $family || $service !~ /^\//; # no can do
return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
}
unless (AF_INET6) {
$family != 6
lib/AnyEvent/Socket.pm view on Meta::CPAN
};
Example: connect to a UNIX domain socket.
tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
...
}
=cut
sub tcp_connect($$$;$) {
my ($host, $port, $connect, $prepare) = @_;
# see http://cr.yp.to/docs/connect.html for some tricky aspects
# also http://advogato.org/article/672.html
my %state = ( fh => undef );
# name/service to type/sockaddr resolution
resolve_sockaddr $host, $port, 0, 0, undef, sub {
my @target = @_;
lib/AnyEvent/Socket.pm view on Meta::CPAN
In case of an error, C<tcp_bind> either croaks, or passes C<undef> to the
C<$done_cb>.
In non-void context, a guard will be returned. It will clean up/unlink the
listening socket when destroyed. In void context, no automatic clean up
might be performed.
=cut
sub _tcp_bind($$$;$) {
my ($host, $service, $done, $prepare) = @_;
$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
? "::" : "0"
unless defined $host;
my $ipn = parse_address $host
or Carp::croak "tcp_bind: cannot parse '$host' as host address";
my $af = address_family $ipn;
lib/AnyEvent/Socket.pm view on Meta::CPAN
listen $fh, $len
or Carp::croak "tcp_bind: $!";
$done->(\%state);
defined wantarray
? guard { %state = () } # clear fh, unlink
: ()
}
sub tcp_bind($$$;$) {
my ($host, $service, $done, $prepare) = @_;
_tcp_bind $host, $service, sub {
$done->(delete shift->{fh});
}, $prepare
}
sub tcp_server($$$;$) {
my ($host, $service, $accept, $prepare) = @_;
_tcp_bind $host, $service, sub {
my $rstate = shift;
$rstate->{aw} = AE::io $rstate->{fh}, 0, sub {
# this closure keeps $state alive
while ($rstate->{fh} && (my $peer = accept my $fh, $rstate->{fh})) {
AnyEvent::fh_unblock $fh; # POSIX requires inheritance, the outside world does not
lib/AnyEvent/Socket.pm view on Meta::CPAN
}, $prepare
}
=item tcp_nodelay $fh, $enable
Enables (or disables) the C<TCP_NODELAY> socket option (also known as
Nagle's algorithm). Returns false on error, true otherwise.
=cut
sub tcp_nodelay($$) {
my $onoff = int ! ! $_[1];
setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
}
=item tcp_congestion $fh, $algorithm
Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION>
socket option). The default is OS-specific, but is usually
C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
C<veno>, C<westwood> and C<yeah>.
=cut
sub tcp_congestion($$) {
defined TCP_CONGESTION
? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
: undef
}
=back
=head1 SECURITY CONSIDERATIONS
This module is quite powerful, with with power comes the ability to abuse
lib/AnyEvent/TLS.pm view on Meta::CPAN
=head1 PUBLIC METHODS AND FUNCTIONS
=over 4
=cut
our $REF_IDX; # our session ex_data id
# create temp file, populate it, and return a guard and filename
sub _tmpfile($) {
require File::Temp unless $File::Temp::VERSION;
# File::Temp opens the file with mode 0600
my ($fh, $path) = File::Temp::tempfile ("aetlsXXXXXXXXX", TMPDIR => 1, EXLOCK => 0);
my $guard = AnyEvent::Util::guard { unlink $path };
syswrite $fh, $_[0];
close $fh;
($path, $guard)
lib/AnyEvent/TLS.pm view on Meta::CPAN
=item $ctx = $tls->ctx
Returns the actual L<Net::SSLeay::CTX> object (just an integer).
=cut
sub ctx {
$_[0]{ctx}
}
sub verify_hostname($$$);
sub _verify_hostname {
my ($self, $cn, $cert) = @_;
return 1
unless defined $cn;
return 1
unless exists $self->{verify_peername} && "none" ne lc $self->{verify_peername};
lib/AnyEvent/TLS.pm view on Meta::CPAN
#Creates a new Net::SSLeay::SSL session object, puts it into C<$mode>
#(C<accept> or C<connect>) and optionally associates it with the given
#C<$ref>. If C<$mode> is already a C<Net::SSLeay::SSL> object, then just
#associate data with it.
#
#=cut
#our %REF_MAP;
our $TLS_SNI_WARNED;
sub _get_session($$;$$) {
my ($self, $mode, $ref, $cn) = @_;
my $session;
if ($mode eq "accept") {
$session = Net::SSLeay::new ($self->{ctx});
Net::SSLeay::set_accept_state ($session);
Net::SSLeay::set_options ($session, eval { Net::SSLeay::OP_NO_TICKET () })
unless $self->{session_ticket} || !exists $self->{session_ticket};
lib/AnyEvent/TLS.pm view on Meta::CPAN
# try to call it even if specified as 0 or undef.
Net::SSLeay::set_verify
$session,
$self->{verify_mode},
sub { $self->verify ($session, $ref, $cn, @_) };
}
$session
}
sub _put_session($$) {
my ($self, $session) = @_;
# clear callback, if any
# this leaks memoryin Net::SSLeay up to at least 1.35, but there
# apparently is no other way.
Net::SSLeay::set_verify $session, 0, undef;
# # disassociate data
# delete $REF_MAP{Net::SSLeay::get_ex_data ($session, $REF_IDX)};
lib/AnyEvent/TLS.pm view on Meta::CPAN
AnyEvent::TLS does on-demand initialisation, and normally there is no need to call an initialise
function.
As initialisation might take some time (to read e.g. C</dev/urandom>), this
could be annoying in some highly interactive programs. In that case, you can
call C<AnyEvent::TLS::init> to make sure there will be no costly initialisation
later. It is harmless to call C<AnyEvent::TLS::init> multiple times.
=cut
sub init() {
return if $REF_IDX;
AE::log 5 => "Net::SSLeay versions older than 1.33 might malfunction."
if $Net::SSLeay::VERSION < 1.33;
Net::SSLeay::load_error_strings ();
Net::SSLeay::SSLeay_add_ssl_algorithms ();
Net::SSLeay::randomize ();
$REF_IDX = Net::SSLeay::get_ex_new_index (0, 0, 0, 0, 0)
lib/AnyEvent/TLS.pm view on Meta::CPAN
smtp => "rfc3207", smtps => "smtp",
xmpp => "rfc3920", rfc3920 => "http",
pop3 => "rfc2595", rfc2595 => "ldap", pop3s => "pop3",
imap => "rfc2595", rfc2595 => "ldap", imaps => "imap",
acap => "rfc2595", rfc2595 => "ldap",
nntp => "rfc4642", rfc4642 => "ldap", nntps => "nntp",
ftp => "rfc4217", rfc4217 => "http", ftps => "ftp" ,
);
sub match_cn($$$) {
my ($name, $cn, $type) = @_;
# remove leading and trailing garbage
for ($name, $cn) {
s/[\x00-\x1f]+$//;
s/^[\x00-\x1f]+//;
}
my $pattern;
lib/AnyEvent/TLS.pm view on Meta::CPAN
$pattern = qr{^[^.]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
$cn =~ $pattern
}
# taken verbatim from IO::Socket::SSL, then changed to take advantage of
# AnyEvent utilities.
sub verify_hostname($$$) {
my ($cn, $cert, $scheme) = @_;
while (!ref $scheme) {
$scheme = $CN_SCHEME{$scheme}
or return 1;
}
my $cert_cn =
Net::SSLeay::X509_NAME_get_text_by_NID (
Net::SSLeay::X509_get_subject_name ($cert), Net::SSLeay::NID_commonName ());
lib/AnyEvent/Util.pm view on Meta::CPAN
exit 1;
} elsif (($! != &Errno::EAGAIN && $! != &Errno::EWOULDBLOCK && $! != &Errno::ENOMEM) || !$forks) {
# we ignore some errors as long as we can run at least one job
# maybe we should wait a few seconds and retry instead
die "fork_call: $!";
}
}
}
sub fork_call(&@) {
push @fork_queue, [@_];
_fork_schedule;
}
END {
if (AnyEvent::WIN32) {
while ($forks) {
@fork_queue = ();
AnyEvent->one_event;
}
}
}
# to be removed
sub dotted_quad($) {
$_[0] =~ /^(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
\.(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
\.(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
\.(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)$/x
}
# just a forwarder
sub inet_aton {
require AnyEvent::Socket;
*inet_aton = \&AnyEvent::Socket::inet_aton;
lib/AnyEvent/Util.pm view on Meta::CPAN
=item AnyEvent::Util::punycode_decode $string
Tries to punycode-decode the given C<$string> and return its unicode
form. Again, uppercase letters are not casefoled, you have to do that
yourself.
Croaks when it cannot decode the string.
=cut
sub punycode_encode($) {
require "AnyEvent/Util/idna.pl";
goto &punycode_encode;
}
sub punycode_decode($) {
require "AnyEvent/Util/idna.pl";
goto &punycode_decode;
}
=item AnyEvent::Util::idn_nameprep $idn[, $display]
Implements the IDNA nameprep normalisation algorithm. Or actually the
UTS#46 algorithm. Or maybe something similar - reality is complicated
between IDNA2003, UTS#46 and IDNA2008. If C<$display> is true then the name
is prepared for display, otherwise it is prepared for lookup (default).
lib/AnyEvent/Util.pm view on Meta::CPAN
This function is designed to avoid using a lot of resources - it uses
about 1MB of RAM (most of this due to Unicode::Normalize). Also, names
that are already "simple" will only be checked for basic validity, without
the overhead of full nameprep processing.
=cut
our ($uts46_valid, $uts46_imap);
sub idn_nameprep($;$) {
local $_ = $_[0];
# lowercasing these should always be valid, and is required for xn-- detection
y/A-Z/a-z/;
if (/[^0-9a-z\-.]/) {
# load the mapping data
unless (defined $uts46_imap) {
require Unicode::Normalize;
require "AnyEvent/Util/uts46data.pl";
lib/AnyEvent/Util.pm view on Meta::CPAN
names and should never fail - if it cannot convert the name, then it will
return it unchanged.
This function is an amalgam of IDNA2003, UTS#46 and IDNA2008 - it tries to
be reasonably compatible to other implementations, reasonably secure, as
much as IDNs can be secure, and reasonably efficient when confronted with
IDNs that are already valid DNS names.
=cut
sub idn_to_ascii($) {
return $_[0]
unless $_[0] =~ /[^\x00-\x7f]/;
my @output;
eval {
# punycode by label
for (split /\./, (idn_nameprep $_[0]), -1) {
if (/[^\x00-\x7f]/) {
eval {
lib/AnyEvent/Util.pm view on Meta::CPAN
This function is an amalgam of IDNA2003, UTS#46 and IDNA2008 - it tries to
be reasonably compatible to other implementations, reasonably secure, as
much as IDNs can be secure, and reasonably efficient when confronted with
IDNs that are already valid DNS names.
At the moment, this function simply calls C<idn_nameprep $idn, 1>,
returning its argument when that function fails.
=cut
sub idn_to_unicode($) {
my $res = eval { idn_nameprep $_[0], 1 };
defined $res ? $res : $_[0]
}
=back
=head1 AUTHOR
Marc Lehmann <schmorp@schmorp.de>
http://anyevent.schmorp.de
lib/AnyEvent/Util/idna.pl view on Meta::CPAN
use integer;
sub pyc_base () { 36 }
sub pyc_tmin () { 1 }
sub pyc_tmax () { 26 }
sub pyc_initial_bias () { 72 }
sub pyc_initial_n () { 128 }
sub pyc_digits () { "abcdefghijklmnopqrstuvwxyz0123456789" }
sub pyc_adapt($$$) {
my ($delta, $numpoints, $firsttime) = @_;
$delta = $firsttime ? $delta / 700 : $delta >> 1;
$delta += $delta / $numpoints;
my $k;
while ($delta > (pyc_base - pyc_tmin) * pyc_tmax / 2) {
$delta /= pyc_base - pyc_tmin;
$k += pyc_base;
}
$k + $delta * (pyc_base - pyc_tmin + 1) / ($delta + 38)
}
sub punycode_encode($) {
my ($input) = @_;
my ($n, $bias, $delta) = (pyc_initial_n, pyc_initial_bias);
(my $output = $input) =~ y/\x00-\x7f//cd;
my $h = my $b = length $output;
my @input = split '', $input;
$output .= "-" if $b && $h < @input;
lib/AnyEvent/Util/idna.pl view on Meta::CPAN
}
}
++$delta;
++$n;
}
$output
}
sub punycode_decode($) {
my ($input) = @_;
my ($n, $bias, $i) = (pyc_initial_n, pyc_initial_bias);
my $output;
if ($input =~ /^(.*?)-([^-]*)$/x) {
$output = $1;
$input = $2;
$output =~ /[^\x00-\x7f]/
t/81_hosts.t view on Meta::CPAN
my ($hosts_fh, $hosts_file) = tempfile UNLINK => 1;
print $hosts_fh "$test_addr $test_host\n";
close $hosts_fh;
$ENV{PERL_ANYEVENT_HOSTS} = $hosts_file;
require AnyEvent;
require AnyEvent::Socket;
sub resolved($) {
my $cv = AnyEvent->condvar;
AnyEvent::Socket::resolve_sockaddr (shift, 80, undef, undef, undef, sub {
return $cv->send unless @_;
my $sockaddr = $_[0][-1];
my $address = (AnyEvent::Socket::unpack_sockaddr ($sockaddr))[1];
return $cv->send (AnyEvent::Socket::format_address ($address));
});
return $cv->recv;
( run in 0.925 second using v1.01-cache-2.11-cpan-65fba6d93b7 )