File Coverage

blib/lib/AnyEvent/Util.pm
Criterion Covered Total %
statement 70 263 26.6
branch 21 136 15.4
condition 6 77 7.7
subroutine 15 33 45.4
pod 8 10 80.0
total 120 519 23.1


line stmt bran cond sub pod time code
1             =encoding utf-8
2              
3             =head1 NAME
4              
5             AnyEvent::Util - various utility functions.
6              
7             =head1 SYNOPSIS
8              
9             use AnyEvent::Util;
10              
11             =head1 DESCRIPTION
12              
13             This module implements various utility functions, mostly replacing
14             well-known functions by event-ised counterparts.
15              
16             All functions documented without C<AnyEvent::Util::> prefix are exported
17             by default.
18              
19             =over 4
20              
21             =cut
22              
23             package AnyEvent::Util;
24              
25 36     36   10946 use Carp ();
  36         315  
  36         720  
26 36     36   11803 use Errno ();
  36         83214  
  36         681  
27 36     36   24648 use Socket ();
  36         128939  
  36         950  
28              
29 36     36   222 use AnyEvent (); BEGIN { AnyEvent::common_sense }
  36     36   100  
  36         610  
  36         150  
30              
31 36     36   157 use base 'Exporter';
  36         59  
  36         10909  
32              
33             our @EXPORT = qw(fh_nonblocking guard fork_call portable_pipe portable_socketpair run_cmd);
34             our @EXPORT_OK = qw(
35             AF_INET6 WSAEWOULDBLOCK WSAEINPROGRESS WSAEINVAL
36             close_all_fds_except
37             punycode_encode punycode_decode idn_nameprep idn_to_ascii idn_to_unicode
38             );
39              
40             our $VERSION = $AnyEvent::VERSION;
41              
42             BEGIN {
43             # provide us with AF_INET6, but only if allowed
44 36 50 50 36   2810 if (
      33        
45             $AnyEvent::PROTOCOL{ipv6}
46             && _AF_INET6
47             && socket my $ipv6_socket, _AF_INET6, Socket::SOCK_DGRAM(), 0 # check if they can be created
48             ) {
49 36         140 *AF_INET6 = \&_AF_INET6;
50             } else {
51             # disable ipv6
52 0         0 *AF_INET6 = sub () { 0 };
53 0         0 delete $AnyEvent::PROTOCOL{ipv6};
54             }
55              
56             # fix buggy Errno on some non-POSIX platforms
57             # such as openbsd and windows.
58 36         128 my %ERR = (
59             EBADMSG => Errno::EDOM (),
60             EPROTO => Errno::ESPIPE (),
61             );
62              
63 36         179 while (my ($k, $v) = each %ERR) {
64 72 50       2859 next if eval "Errno::$k ()";
65 0         0 AE::log 8 => "Broken Errno module, adding Errno::$k.";
66              
67 0         0 eval "sub Errno::$k () { $v }";
68 0         0 push @Errno::EXPORT_OK, $k;
69 0         0 push @{ $Errno::EXPORT_TAGS{POSIX} }, $k;
  0         0  
70             }
71             }
72              
73             =item ($r, $w) = portable_pipe
74              
75             Calling C<pipe> in Perl is portable - except it doesn't really work on
76             sucky windows platforms (at least not with most perls - cygwin's perl
77             notably works fine): On windows, you actually get two file handles you
78             cannot use select on.
79              
80             This function gives you a pipe that actually works even on the broken
81             windows platform (by creating a pair of TCP sockets on windows, so do not
82             expect any speed from that) and using C<pipe> everywhere else.
83              
84             See C<portable_socketpair>, below, for a bidirectional "pipe".
85              
86             Returns the empty list on any errors.
87              
88             =item ($fh1, $fh2) = portable_socketpair
89              
90             Just like C<portable_pipe>, above, but returns a bidirectional pipe
91             (usually by calling C<socketpair> to create a local loopback socket pair,
92             except on windows, where it again returns two interconnected TCP sockets).
93              
94             Returns the empty list on any errors.
95              
96             =cut
97              
98             BEGIN {
99 36     36   201 if (AnyEvent::WIN32) {
100             *_win32_socketpair = sub () {
101             # perl's socketpair emulation fails on many vista machines, because
102             # vista returns fantasy port numbers.
103              
104             for (1..10) {
105             socket my $l, Socket::AF_INET(), Socket::SOCK_STREAM(), 0
106             or next;
107              
108             bind $l, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01"
109             or next;
110              
111             my $sa = getsockname $l
112             or next;
113              
114             listen $l, 1
115             or next;
116              
117             socket my $r, Socket::AF_INET(), Socket::SOCK_STREAM(), 0
118             or next;
119              
120             bind $r, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01"
121             or next;
122              
123             connect $r, $sa
124             or next;
125              
126             accept my $w, $l
127             or next;
128              
129             # vista has completely broken peername/sockname that return
130             # fantasy ports. this combo seems to work, though.
131             (Socket::unpack_sockaddr_in getpeername $r)[0]
132             == (Socket::unpack_sockaddr_in getsockname $w)[0]
133             or (($! = WSAEINVAL), next);
134              
135             # vista example (you can't make this shit up...):
136             #(Socket::unpack_sockaddr_in getsockname $r)[0] == 53364
137             #(Socket::unpack_sockaddr_in getpeername $r)[0] == 53363
138             #(Socket::unpack_sockaddr_in getsockname $w)[0] == 53363
139             #(Socket::unpack_sockaddr_in getpeername $w)[0] == 53365
140              
141             return ($r, $w);
142             }
143              
144             ()
145             };
146              
147             *portable_socketpair = \&_win32_socketpair;
148             *portable_pipe = \&_win32_socketpair;
149             } else {
150             *portable_pipe = sub () {
151 0     0   0 my ($r, $w);
152              
153 0 0       0 pipe $r, $w
154             or return;
155              
156 0         0 ($r, $w);
157 36         162 };
158              
159             *portable_socketpair = sub () {
160 5 50   5   1951 socketpair my $fh1, my $fh2, Socket::AF_UNIX(), Socket::SOCK_STREAM(), 0
161             or return;
162              
163 5         93 ($fh1, $fh2)
164 36         25662 };
165             }
166             }
167              
168             =item fork_call { CODE } @args, $cb->(@res)
169              
170             Executes the given code block asynchronously, by forking. Everything the
171             block returns will be transferred to the calling process (by serialising and
172             deserialising via L<Storable>).
173              
174             If there are any errors, then the C<$cb> will be called without any
175             arguments. In that case, either C<$@> contains the exception (and C<$!> is
176             irrelevant), or C<$!> contains an error number. In all other cases, C<$@>
177             will be C<undef>ined.
178              
179             The code block must not ever call an event-polling function or use
180             event-based programming that might cause any callbacks registered in the
181             parent to run.
182              
183             Win32 spoilers: Due to the endlessly sucky and broken native windows
184             perls (there is no way to cleanly exit a child process on that platform
185             that doesn't also kill the parent), you have to make sure that your main
186             program doesn't exit as long as any C<fork_calls> are still in progress,
187             otherwise the program won't exit. Also, on most windows platforms some
188             memory will leak for every invocation. We are open for improvements that
189             don't require XS hackery.
190              
191             Note that forking can be expensive in large programs (RSS 200MB+). On
192             windows, it is abysmally slow, do not expect more than 5..20 forks/s on
193             that sucky platform (note this uses perl's pseudo-threads, so avoid those
194             like the plague).
195              
196             Example: poor man's async disk I/O (better use L<AnyEvent::IO> together
197             with L<IO::AIO>).
198              
199             fork_call {
200             open my $fh, "</etc/passwd"
201             or die "passwd: $!";
202             local $/;
203             <$fh>
204             } sub {
205             my ($passwd) = @_;
206             ...
207             };
208              
209             =item $AnyEvent::Util::MAX_FORKS [default: 10]
210              
211             The maximum number of child processes that C<fork_call> will fork in
212             parallel. Any additional requests will be queued until a slot becomes free
213             again.
214              
215             The environment variable C<PERL_ANYEVENT_MAX_FORKS> is used to initialise
216             this value.
217              
218             =cut
219              
220             our $MAX_FORKS = int 1 * $ENV{PERL_ANYEVENT_MAX_FORKS};
221             $MAX_FORKS = 10 if $MAX_FORKS <= 0;
222              
223             my $forks;
224             my @fork_queue;
225              
226             sub _fork_schedule;
227             sub _fork_schedule {
228 0 0   0   0 require Storable unless $Storable::VERSION;
229 0 0       0 require POSIX unless $POSIX::VERSION;
230              
231 0         0 while ($forks < $MAX_FORKS) {
232 0 0       0 my $job = shift @fork_queue
233             or last;
234              
235 0         0 ++$forks;
236              
237 0         0 my $coderef = shift @$job;
238 0         0 my $cb = pop @$job;
239            
240             # gimme a break...
241 0 0 0     0 my ($r, $w) = portable_pipe
      0        
242             or ($forks and last) # allow failures when we have at least one job
243             or die "fork_call: $!";
244              
245 0         0 my $pid = fork;
246              
247 0 0 0     0 if ($pid != 0) {
    0 0        
    0 0        
248             # parent
249 0         0 close $w;
250              
251 0         0 my $buf;
252              
253             my $ww; $ww = AE::io $r, 0, sub {
254 0     0   0 my $len = sysread $r, $buf, 65536, length $buf;
255              
256 0 0 0     0 return unless defined $len or $! != Errno::EINTR;
257              
258 0 0       0 if (!$len) {
259 0         0 undef $ww;
260 0         0 close $r;
261 0         0 --$forks;
262 0         0 _fork_schedule;
263            
264 0         0 my $result = eval { Storable::thaw ($buf) };
  0         0  
265 0 0       0 $result = [$@] unless $result;
266 0         0 $@ = shift @$result;
267              
268 0         0 $cb->(@$result);
269              
270             # work around the endlessly broken windows perls
271 0         0 kill 9, $pid if AnyEvent::WIN32;
272              
273             # clean up the pid
274 0         0 waitpid $pid, 0;
275             }
276 0         0 };
277              
278             } elsif (defined $pid) {
279             # child
280 0         0 close $r;
281              
282 0         0 my $result = eval {
283 0         0 local $SIG{__DIE__};
284              
285 0         0 Storable::freeze ([undef, $coderef->(@$job)])
286             };
287              
288 0 0       0 $result = Storable::freeze (["$@"])
289             if $@;
290              
291             # windows forces us to these contortions
292 0         0 my $ofs;
293              
294 0         0 while () {
295 0 0       0 my $len = (length $result) - $ofs
296             or last;
297              
298 0 0       0 $len = syswrite $w, $result, $len < 65536 ? $len : 65536, $ofs;
299              
300 0 0 0     0 last unless $len || (!defined $len && $! == Errno::EINTR);
      0        
301              
302 0         0 $ofs += $len;
303             }
304              
305             # on native windows, _exit KILLS YOUR FORKED CHILDREN!
306 0         0 if (AnyEvent::WIN32) {
307             shutdown $w, 1; # signal parent to please kill us
308             sleep 10; # give parent a chance to clean up
309             sysread $w, (my $buf), 1; # this *might* detect the parent exiting in some cases.
310             }
311 0         0 POSIX::_exit (0);
312 0         0 exit 1;
313            
314             } elsif (($! != &Errno::EAGAIN && $! != &Errno::EWOULDBLOCK && $! != &Errno::ENOMEM) || !$forks) {
315             # we ignore some errors as long as we can run at least one job
316             # maybe we should wait a few seconds and retry instead
317 0         0 die "fork_call: $!";
318             }
319             }
320             }
321              
322             sub fork_call(&@) {
323 0     0 1 0 push @fork_queue, [@_];
324 0         0 _fork_schedule;
325             }
326              
327             END {
328 36     36   1530 if (AnyEvent::WIN32) {
329             while ($forks) {
330             @fork_queue = ();
331             AnyEvent->one_event;
332             }
333             }
334             }
335              
336             # to be removed
337             sub dotted_quad($) {
338 0     0 0 0 $_[0] =~ /^(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
339             \.(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
340             \.(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
341             \.(?:25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)$/x
342             }
343              
344             # just a forwarder
345             sub inet_aton {
346 0     0 0 0 require AnyEvent::Socket;
347 0         0 *inet_aton = \&AnyEvent::Socket::inet_aton;
348 0         0 goto &inet_aton
349             }
350              
351             =item fh_nonblocking $fh, $nonblocking
352              
353             Sets the blocking state of the given filehandle (true == nonblocking,
354             false == blocking). Uses fcntl on anything sensible and ioctl FIONBIO on
355             broken (i.e. windows) platforms.
356              
357             Instead of using this function, you could use C<AnyEvent::fh_block> or
358             C<AnyEvent::fh_unblock>.
359              
360             =cut
361              
362             BEGIN {
363 36     36   7618 *fh_nonblocking = \&AnyEvent::_fh_nonblocking;
364             }
365              
366             =item $guard = guard { CODE }
367              
368             This function creates a special object that, when destroyed, will execute
369             the code block.
370              
371             This is often handy in continuation-passing style code to clean up some
372             resource regardless of where you break out of a process.
373              
374             The L<Guard> module will be used to implement this function, if it is
375             available. Otherwise a pure-perl implementation is used.
376              
377             While the code is allowed to throw exceptions in unusual conditions, it is
378             not defined whether this exception will be reported (at the moment, the
379             Guard module and AnyEvent's pure-perl implementation both try to report
380             the error and continue).
381              
382             You can call one method on the returned object:
383              
384             =item $guard->cancel
385              
386             This simply causes the code block not to be invoked: it "cancels" the
387             guard.
388              
389             =cut
390              
391             BEGIN {
392 36 50 33 36   236 if (!$ENV{PERL_ANYEVENT_AVOID_GUARD} && eval { require Guard; $Guard::VERSION >= 0.5 }) {
  36         15977  
  36         15590  
393 36         102 *guard = \&Guard::guard;
394 36         176 AE::log 8 => "Using Guard module to implement guards.";
395             } else {
396             *AnyEvent::Util::guard::DESTROY = sub {
397 0         0 local $@;
398              
399 0         0 eval {
400 0         0 local $SIG{__DIE__};
401 0         0 ${$_[0]}->();
  0         0  
402             };
403              
404 0 0       0 AE::log 4 => "Runtime error in AnyEvent::guard callback: $@" if $@;
405 0         0 };
406              
407             *AnyEvent::Util::guard::cancel = sub ($) {
408 0         0 ${$_[0]} = sub { };
  0         0  
409 0         0 };
410              
411             *guard = sub (&) {
412 0         0 bless \(my $cb = shift), "AnyEvent::Util::guard"
413 0         0 };
414              
415 0         0 AE::log 8 => "Using pure-perl guard implementation.";
416             }
417             }
418              
419             =item AnyEvent::Util::close_all_fds_except @fds
420              
421             This rarely-used function simply closes all file descriptors (or tries to)
422             of the current process except the ones given as arguments.
423              
424             When you want to start a long-running background server, then it is often
425             beneficial to do this, as too many C-libraries are too stupid to mark
426             their internal fd's as close-on-exec.
427              
428             The function expects to be called shortly before an C<exec> call.
429              
430             Example: close all fds except 0, 1, 2.
431              
432             close_all_fds_except 0, 2, 1;
433              
434             =cut
435              
436             sub close_all_fds_except {
437 0     0 1 0 my %except; @except{@_} = ();
  0         0  
438              
439 0 0       0 require POSIX unless $POSIX::VERSION;
440              
441             # some OSes have a usable /dev/fd, sadly, very few
442 0 0       0 if ($^O =~ /(freebsd|cygwin|linux)/) {
443             # netbsd, openbsd, solaris have a broken /dev/fd
444 0         0 my $dir;
445 0 0 0     0 if (opendir $dir, "/dev/fd" or opendir $dir, "/proc/self/fd") {
446 0         0 my @fds = sort { $a <=> $b } grep /^\d+$/, readdir $dir;
  0         0  
447             # broken OS's have device nodes for 0..63 usually, solaris 0..255
448 0 0 0     0 if (@fds < 20 or "@fds" ne join " ", 0..$#fds) {
449             # assume the fds array is valid now
450             exists $except{$_} or POSIX::close ($_)
451 0   0     0 for @fds;
452 0         0 return;
453             }
454             }
455             }
456              
457 0   0     0 my $fd_max = eval { POSIX::sysconf (POSIX::_SC_OPEN_MAX ()) - 1 } || 1023;
458              
459             exists $except{$_} or POSIX::close ($_)
460 0   0     0 for 0..$fd_max;
461             }
462              
463             =item $cv = run_cmd $cmd, key => value...
464              
465             Run a given external command, potentially redirecting file descriptors and
466             return a condition variable that gets sent the exit status (like C<$?>)
467             when the program exits I<and> all redirected file descriptors have been
468             exhausted.
469              
470             The C<$cmd> is either a single string, which is then passed to a shell, or
471             an arrayref, which is passed to the C<execvp> function (the first array
472             element is used both for the executable name and argv[0]).
473              
474             The key-value pairs can be:
475              
476             =over 4
477              
478             =item ">" => $filename
479              
480             Redirects program standard output into the specified filename, similar to C<<
481             >filename >> in the shell.
482              
483             =item ">" => \$data
484              
485             Appends program standard output to the referenced scalar. The condvar will
486             not be signalled before EOF or an error is signalled.
487              
488             Specifying the same scalar in multiple ">" pairs is allowed, e.g. to
489             redirect both stdout and stderr into the same scalar:
490              
491             ">" => \$output,
492             "2>" => \$output,
493              
494             =item ">" => $filehandle
495              
496             Redirects program standard output to the given filehandle (or actually its
497             underlying file descriptor).
498              
499             =item ">" => $callback->($data)
500              
501             Calls the given callback each time standard output receives some data,
502             passing it the data received. On EOF or error, the callback will be
503             invoked once without any arguments.
504              
505             The condvar will not be signalled before EOF or an error is signalled.
506              
507             =item "fd>" => $see_above
508              
509             Like ">", but redirects the specified fd number instead.
510              
511             =item "<" => $see_above
512              
513             The same, but redirects the program's standard input instead. The same
514             forms as for ">" are allowed.
515              
516             In the callback form, the callback is supposed to return data to be
517             written, or the empty list or C<undef> or a zero-length scalar to signal
518             EOF.
519              
520             Similarly, either the write data must be exhausted or an error is to be
521             signalled before the condvar is signalled, for both string-reference and
522             callback forms.
523              
524             =item "fd<" => $see_above
525              
526             Like "<", but redirects the specified file descriptor instead.
527              
528             =item on_prepare => $cb
529              
530             Specify a callback that is executed just before the command is C<exec>'ed,
531             in the child process. Be careful not to use any event handling or other
532             services not available in the child.
533              
534             This can be useful to set up the environment in special ways, such as
535             changing the priority of the command or manipulating signal handlers (e.g.
536             setting C<SIGINT> to C<IGNORE>).
537              
538             =item close_all => $boolean
539              
540             When C<close_all> is enabled (default is disabled), then all extra file
541             descriptors will be closed, except the ones that were redirected and C<0>,
542             C<1> and C<2>.
543              
544             See C<close_all_fds_except> for more details.
545              
546             =item '$$' => \$pid
547              
548             A reference to a scalar which will receive the PID of the newly-created
549             subprocess after C<run_cmd> returns.
550              
551             Note the the PID might already have been recycled and used by an unrelated
552             process at the time C<run_cmd> returns, so it's not useful to send
553             signals, use as a unique key in data structures and so on.
554              
555             =back
556              
557             Example: run C<rm -rf />, redirecting standard input, output and error to
558             F</dev/null>.
559              
560             my $cv = run_cmd [qw(rm -rf /)],
561             "<", "/dev/null",
562             ">", "/dev/null",
563             "2>", "/dev/null";
564             $cv->recv and die "d'oh! something survived!"
565              
566             Example: run F<openssl> and create a self-signed certificate and key,
567             storing them in C<$cert> and C<$key>. When finished, check the exit status
568             in the callback and print key and certificate.
569              
570             my $cv = run_cmd [qw(openssl req
571             -new -nodes -x509 -days 3650
572             -newkey rsa:2048 -keyout /dev/fd/3
573             -batch -subj /CN=AnyEvent
574             )],
575             "<", "/dev/null",
576             ">" , \my $cert,
577             "3>", \my $key,
578             "2>", "/dev/null";
579              
580             $cv->cb (sub {
581             shift->recv and die "openssl failed";
582              
583             print "$key\n$cert\n";
584             });
585              
586             =cut
587              
588             sub run_cmd {
589 0     0 1 0 my $cmd = shift;
590              
591 0 0       0 require POSIX unless $POSIX::VERSION;
592              
593 0         0 my $cv = AE::cv;
594              
595 0         0 my %arg;
596             my %redir;
597 0         0 my @exe;
598              
599 0         0 while (@_) {
600 0         0 my ($type, $ob) = splice @_, 0, 2;
601              
602 0 0       0 my $fd = $type =~ s/^(\d+)// ? $1 : undef;
603              
604 0 0       0 if ($type eq ">") {
    0          
605 0 0       0 $fd = 1 unless defined $fd;
606              
607 0 0       0 if (defined eval { fileno $ob }) {
  0 0       0  
608 0         0 $redir{$fd} = $ob;
609             } elsif (ref $ob) {
610 0         0 my ($pr, $pw) = AnyEvent::Util::portable_pipe;
611 0         0 $cv->begin;
612              
613 0         0 fcntl $pr, AnyEvent::F_SETFD, AnyEvent::FD_CLOEXEC;
614 0         0 fh_nonblocking $pr, 1;
615 0         0 my $w; $w = AE::io $pr, 0,
616             "SCALAR" eq ref $ob
617             ? sub {
618 0 0 0 0   0 defined (sysread $pr, $$ob, 16384, length $$ob
      0        
619             and return)
620             or ($! == Errno::EINTR and return);
621 0         0 undef $w; $cv->end;
  0         0  
622             }
623             : sub {
624 0     0   0 my $buf;
625 0 0 0     0 defined (sysread $pr, $buf, 16384
      0        
626             and return $ob->($buf))
627             or ($! == Errno::EINTR and return);
628 0         0 undef $w; $cv->end;
  0         0  
629 0         0 $ob->();
630             }
631 0 0       0 ;
632 0         0 $redir{$fd} = $pw;
633             } else {
634             push @exe, sub {
635 0 0   0   0 open my $fh, ">", $ob
636             or POSIX::_exit (125);
637 0         0 $redir{$fd} = $fh;
638 0         0 };
639             }
640              
641             } elsif ($type eq "<") {
642 0 0       0 $fd = 0 unless defined $fd;
643              
644 0 0       0 if (defined eval { fileno $ob }) {
  0 0       0  
645 0         0 $redir{$fd} = $ob;
646             } elsif (ref $ob) {
647 0         0 my ($pr, $pw) = AnyEvent::Util::portable_pipe;
648 0         0 $cv->begin;
649              
650 0         0 my $data;
651 0 0       0 if ("SCALAR" eq ref $ob) {
652 0         0 $data = $$ob;
653 0     0   0 $ob = sub { };
654             } else {
655 0         0 $data = $ob->();
656             }
657              
658 0         0 fcntl $pw, AnyEvent::F_SETFD, AnyEvent::FD_CLOEXEC;
659 0         0 fh_nonblocking $pw, 1;
660 0         0 my $w; $w = AE::io $pw, 1, sub {
661 0     0   0 my $len = syswrite $pw, $data;
662              
663 0 0 0     0 return unless defined $len or $! != Errno::EINTR;
664              
665 0 0       0 if (!$len) {
666 0         0 undef $w; $cv->end;
  0         0  
667             } else {
668 0         0 substr $data, 0, $len, "";
669 0 0       0 unless (length $data) {
670 0         0 $data = $ob->();
671 0 0       0 unless (length $data) {
672 0         0 undef $w; $cv->end
  0         0  
673             }
674             }
675             }
676 0         0 };
677              
678 0         0 $redir{$fd} = $pr;
679             } else {
680             push @exe, sub {
681 0 0   0   0 open my $fh, "<", $ob
682             or POSIX::_exit (125);
683 0         0 $redir{$fd} = $fh;
684 0         0 };
685             }
686              
687             } else {
688 0         0 $arg{$type} = $ob;
689             }
690             }
691              
692 0         0 my $pid = fork;
693              
694 0 0       0 defined $pid
695             or Carp::croak "fork: $!";
696              
697 0 0       0 unless ($pid) {
698             # step 1, execute
699 0         0 $_->() for @exe;
700              
701             # step 2, move any existing fd's out of the way
702             # this also ensures that dup2 is never called with fd1==fd2
703             # so the cloexec flag is always cleared
704 0         0 my (@oldfh, @close);
705 0         0 for my $fh (values %redir) {
706 0         0 push @oldfh, $fh; # make sure we keep it open
707 0         0 $fh = fileno $fh; # we only want the fd
708              
709             # dup if we are in the way
710             # if we "leak" fds here, they will be dup2'ed over later
711             defined ($fh = POSIX::dup ($fh)) or POSIX::_exit (124)
712 0   0     0 while exists $redir{$fh};
713             }
714              
715             # step 3, execute redirects
716 0         0 while (my ($k, $v) = each %redir) {
717 0 0       0 defined POSIX::dup2 ($v, $k)
718             or POSIX::_exit (123);
719             }
720              
721             # step 4, close everything else, except 0, 1, 2
722 0 0       0 if ($arg{close_all}) {
723 0         0 close_all_fds_except 0, 1, 2, keys %redir
724             } else {
725             POSIX::close ($_)
726 0         0 for values %redir;
727             }
728              
729 0         0 eval { $arg{on_prepare}(); 1 } or POSIX::_exit (123)
  0         0  
730 0 0 0     0 if exists $arg{on_prepare};
731              
732             ref $cmd
733 0 0       0 ? exec {$cmd->[0]} @$cmd
  0         0  
734             : exec $cmd;
735              
736 0         0 POSIX::_exit (126);
737             }
738              
739 0         0 ${$arg{'$$'}} = $pid
740 0 0       0 if $arg{'$$'};
741              
742 0         0 %redir = (); # close child side of the fds
743              
744 0         0 my $status;
745 0     0   0 $cv->begin (sub { shift->send ($status) });
  0         0  
746 0         0 my $cw; $cw = AE::child $pid, sub {
747 0     0   0 $status = $_[1];
748 0         0 undef $cw; $cv->end;
  0         0  
749 0         0 };
750              
751 0         0 $cv
752             }
753              
754             =item AnyEvent::Util::punycode_encode $string
755              
756             Punycode-encodes the given C<$string> and returns its punycode form. Note
757             that uppercase letters are I<not> casefolded - you have to do that
758             yourself.
759              
760             Croaks when it cannot encode the string.
761              
762             =item AnyEvent::Util::punycode_decode $string
763              
764             Tries to punycode-decode the given C<$string> and return its unicode
765             form. Again, uppercase letters are not casefoled, you have to do that
766             yourself.
767              
768             Croaks when it cannot decode the string.
769              
770             =cut
771              
772             sub punycode_encode($) {
773 1     1 1 433 require "AnyEvent/Util/idna.pl";
774 1         6 goto &punycode_encode;
775             }
776              
777             sub punycode_decode($) {
778 0     0 1 0 require "AnyEvent/Util/idna.pl";
779 0         0 goto &punycode_decode;
780             }
781              
782             =item AnyEvent::Util::idn_nameprep $idn[, $display]
783              
784             Implements the IDNA nameprep normalisation algorithm. Or actually the
785             UTS#46 algorithm. Or maybe something similar - reality is complicated
786             between IDNA2003, UTS#46 and IDNA2008. If C<$display> is true then the name
787             is prepared for display, otherwise it is prepared for lookup (default).
788              
789             If you have no clue what this means, look at C<idn_to_ascii> instead.
790              
791             This function is designed to avoid using a lot of resources - it uses
792             about 1MB of RAM (most of this due to Unicode::Normalize). Also, names
793             that are already "simple" will only be checked for basic validity, without
794             the overhead of full nameprep processing.
795              
796             =cut
797              
798             our ($uts46_valid, $uts46_imap);
799              
800             sub idn_nameprep($;$) {
801 3     3 1 5 local $_ = $_[0];
802              
803             # lowercasing these should always be valid, and is required for xn-- detection
804 3         7 y/A-Z/a-z/;
805              
806 3 50       9 if (/[^0-9a-z\-.]/) {
807             # load the mapping data
808 3 100       7 unless (defined $uts46_imap) {
809 1         199184 require Unicode::Normalize;
810 1         575236 require "AnyEvent/Util/uts46data.pl";
811             }
812              
813             # uts46 nameprep
814              
815             # I naively tried to use a regex/transliterate approach first,
816             # with one regex and one y///, but the compiled code was 4.5MB.
817             # this version has a bit-table for the valid class, and
818             # a char-replacement search string
819              
820             # for speed (cough) reasons, we skip-case 0-9a-z, -, ., which
821             # really ought to be trivially valid. A-Z is valid, but already lowercased.
822             s{
823             ([^0-9a-z\-.])
824             }{
825 9         41 my $chr = $1;
826 9 100       18 unless (vec $uts46_valid, ord $chr, 1) {
827             # not in valid class, search for mapping
828 3         7 utf8::encode $chr; # the imap table is in utf-8
829 3 50       64 (my $rep = index $uts46_imap, "\x00$chr") >= 0
830             or Carp::croak "$_[0]: disallowed characters (U+" . (unpack "H*", $chr) . ") during idn_nameprep";
831              
832 3 50       17 (substr $uts46_imap, $rep, 128) =~ /\x00 .[\x80-\xbf]* ([^\x00]*) \x00/x
833             or die "FATAL: idn_nameprep imap table has unexpected contents";
834              
835 3         6 $rep = $1;
836 3 50 33     10 $chr = $rep unless $rep =~ s/^\x01// && $_[1]; # replace unless deviation and display
837 3         7 utf8::decode $chr;
838             }
839             $chr
840 3         14 }gex;
  9         25  
841              
842             # KC
843 3         26 $_ = Unicode::Normalize::NFKC ($_);
844             }
845              
846             # decode punycode components, check for invalid xx-- prefixes
847             s{
848             (^|\.)(..)--([^\.]*)
849             }{
850 0         0 my ($pfx, $ace, $pc) = ($1, $2, $3);
851              
852 0 0       0 if ($ace eq "xn") {
    0          
853 0         0 $pc = punycode_decode $pc; # will croak on error (we hope :)
854              
855 0         0 require Unicode::Normalize;
856 0 0       0 $pc eq Unicode::Normalize::NFC ($pc)
857             or Carp::croak "$_[0]: punycode label not in NFC detected during idn_nameprep";
858              
859 0         0 "$pfx$pc"
860             } elsif ($ace !~ /^[a-z0-9]{2}$/) {
861 0         0 "$pfx$ace--$pc"
862             } else {
863 0         0 Carp::croak "$_[0]: hyphens in 3rd/4th position of a label are not allowed";
864             }
865 3         9 }gex;
866              
867             # uts46 verification
868 3 50       14 /\.-|-\./
869             and Carp::croak "$_[0]: invalid hyphens detected during idn_nameprep";
870              
871             # missing: label begin with combining mark, idna2008 bidi
872              
873             # now check validity of each codepoint
874 3 50       9 if (/[^0-9a-z\-.]/) {
875             # load the mapping data
876 3 50       6 unless (defined $uts46_imap) {
877 0         0 require "AnyEvent/Util/uts46data.pl";
878             }
879              
880             vec $uts46_valid, ord, 1
881             or $_[1] && 0 <= index $uts46_imap, pack "C0U*", 0, ord, 1 # deviation == \x00$chr\x01
882             or Carp::croak "$_[0]: disallowed characters during idn_nameprep"
883 3   0     26 for split //;
      33        
      0        
884             }
885              
886             $_
887 3         15 }
888              
889             =item $domainname = AnyEvent::Util::idn_to_ascii $idn
890              
891             Converts the given unicode string (C<$idn>, international domain name,
892             e.g. 日本語。JP) to a pure-ASCII domain name (this is usually
893             called the "IDN ToAscii" transform). This transformation is idempotent,
894             which means you can call it just in case and it will do the right thing.
895              
896             Unlike some other "ToAscii" implementations, this one works on full domain
897             names and should never fail - if it cannot convert the name, then it will
898             return it unchanged.
899              
900             This function is an amalgam of IDNA2003, UTS#46 and IDNA2008 - it tries to
901             be reasonably compatible to other implementations, reasonably secure, as
902             much as IDNs can be secure, and reasonably efficient when confronted with
903             IDNs that are already valid DNS names.
904              
905             =cut
906              
907             sub idn_to_ascii($) {
908 5 100   5 1 101 return $_[0]
909             unless $_[0] =~ /[^\x00-\x7f]/;
910              
911 3         5 my @output;
912              
913 3 50       4 eval {
914             # punycode by label
915 3         9 for (split /\./, (idn_nameprep $_[0]), -1) {
916 8 100       19 if (/[^\x00-\x7f]/) {
917             eval {
918 3         10 push @output, "xn--" . punycode_encode $_;
919 3         8 1;
920 3 50       4 } or do {
921 0         0 push @output, $_;
922             };
923             } else {
924 5         9 push @output, $_;
925             }
926             }
927              
928             1
929 3         7 } or return $_[0];
930              
931             shift @output
932 3   33     11 while !length $output[0] && @output > 1;
933              
934 3         12 join ".", @output
935             }
936              
937             =item $idn = AnyEvent::Util::idn_to_unicode $idn
938              
939             Converts the given unicode string (C<$idn>, international domain name,
940             e.g. 日本語。JP, www.deliantra.net, www.xn--l-0ga.de) to
941             unicode form (this is usually called the "IDN ToUnicode" transform). This
942             transformation is idempotent, which means you can call it just in case and
943             it will do the right thing.
944              
945             Unlike some other "ToUnicode" implementations, this one works on full
946             domain names and should never fail - if it cannot convert the name, then
947             it will return it unchanged.
948              
949             This function is an amalgam of IDNA2003, UTS#46 and IDNA2008 - it tries to
950             be reasonably compatible to other implementations, reasonably secure, as
951             much as IDNs can be secure, and reasonably efficient when confronted with
952             IDNs that are already valid DNS names.
953              
954             At the moment, this function simply calls C<idn_nameprep $idn, 1>,
955             returning its argument when that function fails.
956              
957             =cut
958              
959             sub idn_to_unicode($) {
960 0     0 1   my $res = eval { idn_nameprep $_[0], 1 };
  0            
961 0 0         defined $res ? $res : $_[0]
962             }
963              
964             =back
965              
966             =head1 AUTHOR
967              
968             Marc Lehmann <schmorp@schmorp.de>
969             http://anyevent.schmorp.de
970              
971             =cut
972              
973             1
974