r49059 - in /branches/upstream/libanyevent-perl/current: ./ lib/ lib/AnyEvent/ lib/AnyEvent/Util/ t/ util/

jawnsy-guest at users.alioth.debian.org jawnsy-guest at users.alioth.debian.org
Mon Dec 21 04:43:59 UTC 2009


Author: jawnsy-guest
Date: Mon Dec 21 04:43:52 2009
New Revision: 49059

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=49059
Log:
[svn-upgrade] Integrating new upstream version, libanyevent-perl (5.230)

Added:
    branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/
    branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/idna.pl
    branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/uts46data.pl   (with props)
    branches/upstream/libanyevent-perl/current/t/08_idna.t
    branches/upstream/libanyevent-perl/current/util/
    branches/upstream/libanyevent-perl/current/util/gen_uts46data   (with props)
Modified:
    branches/upstream/libanyevent-perl/current/Changes
    branches/upstream/libanyevent-perl/current/MANIFEST
    branches/upstream/libanyevent-perl/current/META.json
    branches/upstream/libanyevent-perl/current/META.yml
    branches/upstream/libanyevent-perl/current/README
    branches/upstream/libanyevent-perl/current/lib/AE.pm
    branches/upstream/libanyevent-perl/current/lib/AnyEvent.pm
    branches/upstream/libanyevent-perl/current/lib/AnyEvent/DNS.pm
    branches/upstream/libanyevent-perl/current/lib/AnyEvent/Socket.pm
    branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util.pm

Modified: branches/upstream/libanyevent-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/Changes?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/Changes (original)
+++ branches/upstream/libanyevent-perl/current/Changes Mon Dec 21 04:43:52 2009
@@ -1,4 +1,11 @@
 Revision history for Perl extension AnyEvent.
+
+5.23  Sun Dec 20 23:48:00 CET 2009
+	- support IDNs in resolve_sockaddr, and therefore in tcp_connect.
+        - implement punycode_encode/decode, idn_nameprep,
+          idn_to_ascii and idn_to_unicode operations in AnyEvent::Util.
+	- provide $AE::VERSION.
+        - removed traces of "no strict 'refs'".
 
 5.22  Sat Dec  5 03:51:13 CET 2009
 	- downgrade-or-fail in AnyEvent::Handle::push_write, to

Modified: branches/upstream/libanyevent-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/MANIFEST?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/MANIFEST (original)
+++ branches/upstream/libanyevent-perl/current/MANIFEST Mon Dec 21 04:43:52 2009
@@ -11,6 +11,8 @@
 lib/AnyEvent/Debug.pm
 lib/AnyEvent/DNS.pm
 lib/AnyEvent/Util.pm
+lib/AnyEvent/Util/idna.pl
+lib/AnyEvent/Util/uts46data.pl
 lib/AnyEvent/TLS.pm
 lib/AnyEvent/Handle.pm
 lib/AnyEvent/Socket.pm
@@ -33,6 +35,7 @@
 t/05_dns.t
 t/06_socket.t
 t/07_io.t
+t/08_idna.t
 t/handle/01_readline.t
 t/handle/02_write.t
 t/handle/03_http_req.t
@@ -47,5 +50,7 @@
 eg/handle
 eg/ae0.pl
 eg/ae2.pl
+
+util/gen_uts46data
 META.yml                                 Module meta-data (added by MakeMaker)
 META.json                                Module meta-data (added by MakeMaker)

Modified: branches/upstream/libanyevent-perl/current/META.json
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/META.json?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/META.json (original)
+++ branches/upstream/libanyevent-perl/current/META.json Mon Dec 21 04:43:52 2009
@@ -1,1 +1,1 @@
-{"no_index":{"directory":["t","inc"]},"meta-spec":{"version":1.4,"url":"http://module-build.sourceforge.net/META-spec-v1.4.html"},"generated_by":"ExtUtils::MakeMaker version 6.54","distribution_type":"module","version":"5.22","name":"AnyEvent","author":[],"license":"unknown","build_requires":{"ExtUtils::MakeMaker":0},"requires":{},"recommends":{"Net::SSLeay":1.33,"Guard":1.02,"EV":3.05,"Async::Interrupt":1,"JSON::XS":2.2,"JSON":2.09},"abstract":null,"configure_requires":{"ExtUtils::MakeMaker":0}}
+{"no_index":{"directory":["t","inc"]},"meta-spec":{"version":1.4,"url":"http://module-build.sourceforge.net/META-spec-v1.4.html"},"generated_by":"ExtUtils::MakeMaker version 6.54","distribution_type":"module","version":"5.23","name":"AnyEvent","author":[],"license":"unknown","build_requires":{"ExtUtils::MakeMaker":0},"requires":{},"recommends":{"Net::SSLeay":1.33,"Guard":1.02,"EV":3.05,"Async::Interrupt":1,"JSON::XS":2.2,"JSON":2.09},"abstract":null,"configure_requires":{"ExtUtils::MakeMaker":0}}

Modified: branches/upstream/libanyevent-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/META.yml?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/META.yml (original)
+++ branches/upstream/libanyevent-perl/current/META.yml Mon Dec 21 04:43:52 2009
@@ -11,7 +11,7 @@
    },
    "generated_by" : "ExtUtils::MakeMaker version 6.54",
    "distribution_type" : "module",
-   "version" : "5.22",
+   "version" : "5.23",
    "name" : "AnyEvent",
    "author" : [],
    "license" : "unknown",

Modified: branches/upstream/libanyevent-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/README?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/README (original)
+++ branches/upstream/libanyevent-perl/current/README Mon Dec 21 04:43:52 2009
@@ -921,13 +921,26 @@
         detected, and the array will be ignored.
 
         Best use "AnyEvent::post_detect { BLOCK }" when your application
-        allows it,as it takes care of these details.
+        allows it, as it takes care of these details.
 
         This variable is mainly useful for modules that can do something
         useful when AnyEvent is used and thus want to know when it is
         initialised, but do not need to even load it by default. This array
         provides the means to hook into AnyEvent passively, without loading
         it.
+
+        Example: To load Coro::AnyEvent whenever Coro and AnyEvent are used
+        together, you could put this into Coro (this is the actual code used
+        by Coro to accomplish this):
+
+           if (defined $AnyEvent::MODEL) {
+              # AnyEvent already initialised, so load Coro::AnyEvent
+              require Coro::AnyEvent;
+           } else {
+              # AnyEvent not yet initialised, so make sure to load Coro::AnyEvent
+              # as soon as it is
+              push @AnyEvent::post_detect, sub { require Coro::AnyEvent };
+           }
 
 WHAT TO DO IN A MODULE
     As a module author, you should "use AnyEvent" and call AnyEvent methods

Modified: branches/upstream/libanyevent-perl/current/lib/AE.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AE.pm?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/lib/AE.pm (original)
+++ branches/upstream/libanyevent-perl/current/lib/AE.pm Mon Dec 21 04:43:52 2009
@@ -52,6 +52,8 @@
 package AE;
 
 use AnyEvent (); # BEGIN { AnyEvent::common_sense }
+
+our $VERSION = $AnyEvent::VERSION;
 
 =item $w = AE::io $fh_or_fd, $watch_write, $cb
 

Modified: branches/upstream/libanyevent-perl/current/lib/AnyEvent.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AnyEvent.pm?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/lib/AnyEvent.pm (original)
+++ branches/upstream/libanyevent-perl/current/lib/AnyEvent.pm Mon Dec 21 04:43:52 2009
@@ -968,12 +968,25 @@
 array will be ignored.
 
 Best use C<AnyEvent::post_detect { BLOCK }> when your application allows
-it,as it takes care of these details.
+it, as it takes care of these details.
 
 This variable is mainly useful for modules that can do something useful
 when AnyEvent is used and thus want to know when it is initialised, but do
 not need to even load it by default. This array provides the means to hook
 into AnyEvent passively, without loading it.
+
+Example: To load Coro::AnyEvent whenever Coro and AnyEvent are used
+together, you could put this into Coro (this is the actual code used by
+Coro to accomplish this):
+
+   if (defined $AnyEvent::MODEL) {
+      # AnyEvent already initialised, so load Coro::AnyEvent
+      require Coro::AnyEvent;
+   } else {
+      # AnyEvent not yet initialised, so make sure to load Coro::AnyEvent
+      # as soon as it is
+      push @AnyEvent::post_detect, sub { require Coro::AnyEvent };
+   }
 
 =back
 
@@ -1133,8 +1146,8 @@
 # basically a tuned-down version of common::sense
 sub common_sense {
    # from common:.sense 1.0
-   ${^WARNING_BITS} = "\xfc\x3f\x33\x00\x0f\xf3\xcf\xc0\xf3\xfc\x33\x03";
-   # use strict vars subs
+   ${^WARNING_BITS} = "\xfc\x3f\x33\x00\x0f\xf3\xcf\xc0\xf3\xfc\x33\x00";
+   # use strict vars subs - NO UTF-8, as Util.pm doesn't like this atm. (uts46data.pl)
    $^H |= 0x00000600;
 }
 
@@ -1142,7 +1155,7 @@
 
 use Carp ();
 
-our $VERSION = '5.22';
+our $VERSION = '5.23';
 our $MODEL;
 
 our $AUTOLOAD;

Modified: branches/upstream/libanyevent-perl/current/lib/AnyEvent/DNS.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AnyEvent/DNS.pm?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/lib/AnyEvent/DNS.pm (original)
+++ branches/upstream/libanyevent-perl/current/lib/AnyEvent/DNS.pm Mon Dec 21 04:43:52 2009
@@ -879,7 +879,7 @@
    $self->{search} = [];
 
    if ((AnyEvent::WIN32 || $^O =~ /cygwin/i)) {
-      no strict 'refs';
+      #no strict 'refs';
 
       # there are many options to find the current nameservers etc. on windows
       # all of them don't work consistently:
@@ -1125,7 +1125,7 @@
 sub _scheduler {
    my ($self) = @_;
 
-   no strict 'refs';
+   #no strict 'refs';
 
    $NOW = time;
 

Modified: branches/upstream/libanyevent-perl/current/lib/AnyEvent/Socket.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AnyEvent/Socket.pm?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/lib/AnyEvent/Socket.pm (original)
+++ branches/upstream/libanyevent-perl/current/lib/AnyEvent/Socket.pm Mon Dec 21 04:43:52 2009
@@ -437,8 +437,8 @@
 readable format.
 
 Note that C<resolve_sockaddr>, while initially a more complex interface,
-resolves host addresses, service names and SRV records and gives you an
-ordered list of socket addresses to try and should be preferred over
+resolves host addresses, IDNs, service names and SRV records and gives you
+an ordered list of socket addresses to try and should be preferred over
 C<inet_aton>.
 
 Example.
@@ -591,13 +591,14 @@
 protocol-independent way. It works remotely similar to the getaddrinfo
 posix function.
 
-For internet addresses, C<$node> is either an IPv4 or IPv6 address or an
-internet hostname, and C<$service> is either a service name (port name
-from F</etc/services>) or a numerical port number. If both C<$node> and
-C<$service> are names, then SRV records will be consulted to find the real
-service, otherwise they will be used as-is. If you know that the service
-name is not in your services database, then you can specify the service in
-the format C<name=port> (e.g. C<http=80>).
+For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
+internet hostname (DNS domain name or IDN), and C<$service> is either
+a service name (port name from F</etc/services>) or a numerical port
+number. If both C<$node> and C<$service> are names, then SRV records
+will be consulted to find the real service, otherwise they will be
+used as-is. If you know that the service name is not in your services
+database, then you can specify the service in the format C<name=port>
+(e.g. C<http=80>).
 
 For UNIX domain sockets, C<$node> must be the string C<unix/> and
 C<$service> must be the absolute pathname of the socket. In this case,
@@ -667,10 +668,10 @@
               or Carp::croak "$service/$proto: service unknown";
    }
 
-   my @target = [$node, $port];
-
    # resolve a records / provide sockaddr structures
    my $resolve = sub {
+      my @target = @_;
+
       my @res;
       my $cv = AE::cv {
          $cb->(
@@ -726,42 +727,46 @@
       $cv->end;
    };
 
+   $node = AnyEvent::Util::idn_to_ascii $node
+      if $node =~ /[^\x00-\x7f]/;
+
    # try srv records, if applicable
    if ($node eq "localhost") {
-      @target = (["127.0.0.1", $port], ["::1", $port]);
-      &$resolve;
+      $resolve->(["127.0.0.1", $port], ["::1", $port]);
    } elsif (defined $service && !parse_address $node) {
       AnyEvent::DNS::srv $service, $proto, $node, sub {
          my (@srv) = @_;
 
-         # no srv records, continue traditionally
-         @srv
-            or return &$resolve;
-
-         # the only srv record has "." ("" here) => abort
-         $srv[0][2] ne "" || $#srv
-            or return $cb->();
-
-         # use srv records then
-         @target = map ["$_->[3].", $_->[2]],
-                      grep $_->[3] ne ".",
-                         @srv;
-
-         &$resolve;
+         if (@srv) {
+            # the only srv record has "." ("" here) => abort
+            $srv[0][2] ne "" || $#srv
+               or return $cb->();
+
+            # use srv records then
+            $resolve->(
+               map ["$_->[3].", $_->[2]],
+                  grep $_->[3] ne ".",
+                     @srv
+            );
+         } else {
+            # no srv records, continue traditionally
+            $resolve->([$node, $port]);
+         }
       };
    } else {
-      &$resolve;
+      # most common case
+      $resolve->([$node, $port]);
    }
 }
 
 =item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
 
-This is a convenience function that creates a TCP socket and makes a 100%
-non-blocking connect to the given C<$host> (which can be a hostname or
-a textual IP address, or the string C<unix/> for UNIX domain sockets)
-and C<$service> (which can be a numeric port number or a service name,
-or a C<servicename=portnumber> string, or the pathname to a UNIX domain
-socket).
+This is a convenience function that creates a TCP socket and makes a
+100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
+hostname or a textual IP address, or the string C<unix/> for UNIX domain
+sockets) and C<$service> (which can be a numeric port number or a service
+name, or a C<servicename=portnumber> string, or the pathname to a UNIX
+domain socket).
 
 If both C<$host> and C<$port> are names, then this function will use SRV
 records to locate the real target(s).
@@ -877,7 +882,7 @@
 sub tcp_connect($$$;$) {
    my ($host, $port, $connect, $prepare) = @_;
 
-   # see http://cr.yp.to/docs/connect.html for some background
+   # see http://cr.yp.to/docs/connect.html for some tricky aspects
    # also http://advogato.org/article/672.html
 
    my %state = ( fh => undef );

Modified: branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util.pm?rev=49059&op=diff
==============================================================================
--- branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util.pm (original)
+++ branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util.pm Mon Dec 21 04:43:52 2009
@@ -29,7 +29,11 @@
 use base 'Exporter';
 
 our @EXPORT = qw(fh_nonblocking guard fork_call portable_pipe portable_socketpair run_cmd);
-our @EXPORT_OK = qw(AF_INET6 WSAEWOULDBLOCK WSAEINPROGRESS WSAEINVAL close_all_fds_except);
+our @EXPORT_OK = qw(
+   AF_INET6 WSAEWOULDBLOCK WSAEINPROGRESS WSAEINVAL
+   close_all_fds_except
+   punycode_encode punycode_decode idn_nameprep idn_to_ascii idn_to_unicode
+);
 
 our $VERSION = $AnyEvent::VERSION;
 
@@ -106,74 +110,75 @@
 
 =cut
 
-sub _win32_socketpair {
-   # perl's socketpair emulation fails on many vista machines, because
-   # vista returns fantasy port numbers.
-
-   for (1..10) {
-      socket my $l, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
-         or next;
-
-      bind $l, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01"
-         or next;
-
-      my $sa = getsockname $l
-         or next;
-
-      listen $l, 1
-         or next;
-
-      socket my $r, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
-         or next;
-
-      bind $r, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01"
-         or next;
-
-      connect $r, $sa
-         or next;
-
-      accept my $w, $l
-         or next;
-
-      # vista has completely broken peername/sockname that return
-      # fantasy ports. this combo seems to work, though.
-      #
-      (Socket::unpack_sockaddr_in getpeername $r)[0]
-      == (Socket::unpack_sockaddr_in getsockname $w)[0]
-         or (($! = WSAEINVAL), next);
-
-      # vista example (you can't make this shit up...):
-      #(Socket::unpack_sockaddr_in getsockname $r)[0] == 53364
-      #(Socket::unpack_sockaddr_in getpeername $r)[0] == 53363
-      #(Socket::unpack_sockaddr_in getsockname $w)[0] == 53363
-      #(Socket::unpack_sockaddr_in getpeername $w)[0] == 53365
-
-      return ($r, $w);
-   }
-
-   ()
-}
-
-sub portable_pipe() {
-   return _win32_socketpair
-      if AnyEvent::WIN32;
-
-   my ($r, $w);
-
-   pipe $r, $w
-      or return;
-
-   ($r, $w);
-}
-
-sub portable_socketpair() {
-   return _win32_socketpair
-      if AnyEvent::WIN32;
-
-   socketpair my $fh1, my $fh2, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC
-      or return;
-
-   ($fh1, $fh2)
+BEGIN {
+   if (AnyEvent::WIN32) {
+      *_win32_socketpair = sub () {
+         # perl's socketpair emulation fails on many vista machines, because
+         # vista returns fantasy port numbers.
+
+         for (1..10) {
+            socket my $l, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
+               or next;
+
+            bind $l, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01"
+               or next;
+
+            my $sa = getsockname $l
+               or next;
+
+            listen $l, 1
+               or next;
+
+            socket my $r, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
+               or next;
+
+            bind $r, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01"
+               or next;
+
+            connect $r, $sa
+               or next;
+
+            accept my $w, $l
+               or next;
+
+            # vista has completely broken peername/sockname that return
+            # fantasy ports. this combo seems to work, though.
+            #
+            (Socket::unpack_sockaddr_in getpeername $r)[0]
+            == (Socket::unpack_sockaddr_in getsockname $w)[0]
+               or (($! = WSAEINVAL), next);
+
+            # vista example (you can't make this shit up...):
+            #(Socket::unpack_sockaddr_in getsockname $r)[0] == 53364
+            #(Socket::unpack_sockaddr_in getpeername $r)[0] == 53363
+            #(Socket::unpack_sockaddr_in getsockname $w)[0] == 53363
+            #(Socket::unpack_sockaddr_in getpeername $w)[0] == 53365
+
+            return ($r, $w);
+         }
+
+         ()
+      };
+
+      *portable_socketpair = \&_win32_socketpair;
+      *portable_pipe       = \&_win32_socketpair;
+   } else {
+      *portable_pipe = sub () {
+         my ($r, $w);
+
+         pipe $r, $w
+            or return;
+
+         ($r, $w);
+      };
+
+      *portable_socketpair = sub () {
+         socketpair my $fh1, my $fh2, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC
+            or return;
+
+         ($fh1, $fh2)
+      };
+   }
 }
 
 =item fork_call { CODE } @args, $cb->(@res)
@@ -740,6 +745,215 @@
 
    $cv
 }
+
+=item AnyEvent::Util::punycode_encode $string
+
+Punycode-encodes the given C<$string> and returns its punycode form. Note
+that uppercase letters are I<not> casefolded - you have to do that
+yourself.
+
+Croaks when it cannot encode the string.
+
+=item AnyEvent::Util::punycode_decode $string
+
+Tries to punycode-decode the given C<$string> and return it's 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
+btween IDNA2003, UTS#46 and IDNA2008. If C<$display> is true then the name
+is prepared for display, otherwise it is prepared for lookup (default).
+
+If you have no clue what this means, look at C<idn_to_ascii> instead.
+
+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 "lib/AnyEvent/Util/uts46data.pl";
+      }
+
+      # uts46 nameprep
+
+      # I naively tried to use a regex/transliterate approach first,
+      # with one regex and one y///, but the compiled code was 4.5MB.
+      # this version has a bit-table for the valid class, and
+      # a char-replacement search string
+
+      # for speed (cough) reasons, we skip-case 0-9a-z, -, ., which
+      # really ought to be trivially valid. A-Z is valid, but already lowercased.
+      s{
+         ([^0-9a-z\-.])
+      }{
+         my $chr = $1;
+         unless (vec $uts46_valid, ord $chr, 1) {
+            # not in valid class, search for mapping
+            utf8::encode $chr; # the imap table is in utf-8
+            (my $rep = index $uts46_imap, "\x00$chr") >= 0
+               or Carp::croak "$_[0]: disallowed characters during idn_nameprep";
+
+            (substr $uts46_imap, $rep, 128) =~ /\x00 .[\x80-\xbf]* ([^\x00]+) \x00/x
+               or die "FATAL: idn_nameprep imap table has unexpected contents";
+
+            $rep = $1;
+            $chr = $rep unless $rep =~ s/^\x01// && $_[1]; # replace unless deviation and display
+            utf8::decode $chr;
+         }
+         $chr
+      }gex;
+
+      # KC
+      $_ = Unicode::Normalize::NFKC ($_);
+   }
+
+   # decode punycode components, check for invalid xx-- prefixes
+   s{
+      (^|\.)(..)--([^\.]*)
+   }{
+      my ($pfx, $ace, $pc) = ($1, $2, $3);
+
+      if ($ace eq "xn") {
+         $pc = punycode_decode $pc; # will croak on error (we hope :)
+
+         require Unicode::Normalize;
+         $pc eq Unicode::Normalize::NFC ($pc)
+            or Carp::croak "$_[0]: punycode label not in NFC detected during idn_nameprep";
+
+         "$pfx$pc"
+      } elsif ($ace !~ /^[a-z0-9]{2}$/) {
+         "$pfx$ace--$pc"
+      } else {
+         Carp::croak "$_[0]: hyphens in 3rd/4th position of a label are not allowed";
+      }
+   }gex;
+
+   # uts46 verification
+   /\.-|-\.|\.\./
+      and Carp::croak "$_[0]: invalid hyphens detected during idn_nameprep";
+
+   # missing: label begin with combining mark, idna2008 bidi
+
+   # now check validity of each codepoint
+   if (/[^0-9a-z\-.]/) {
+      # load the mapping data
+      unless (defined $uts46_imap) {
+         require "lib/AnyEvent/Util/uts46data.pl";
+      }
+
+      vec $uts46_valid, ord, 1
+         or $_[1] && 0 <= index $uts46_imap, pack "C0U*", 0, ord, 1 # deviation == \x00$chr\x01
+         or Carp::croak "$_[0]: disallowed characters during idn_nameprep"
+         for split //;
+   }
+
+   $_
+}
+
+=item $domainname = AnyEvent::Util::idn_to_ascii $idn
+
+Converts the given unicode string (C<$idn>, international domain name,
+e.g. 日本語。JP) to a pure-ASCII domain name (this is usually
+called the "IDN ToAscii" transform). This transformation is idempotent,
+which means you can call it just in case and it will do the right thing.
+
+Unlike some other "ToAscii" implementations, this one works on full domain
+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]) {
+         if (/[^\x00-\x7f]/) {
+            eval {
+               push @output, "xn--" . punycode_encode $_;
+               1;
+            } or do {
+               push @output, $_;
+            };
+         } else {
+            push @output, $_;
+         }
+      }
+
+      1
+   } or return $_[0];
+
+   join ".", @output
+}
+
+=item $idn = AnyEvent::Util::idn_to_unicode $idn
+
+Converts the given unicode string (C<$idn>, international domain name,
+e.g. 日本語。JP, www.deliantra.net, www.xn--l-0ga.de) to
+unicode form (this is usually called the "IDN ToUnicode" transform). This
+transformation is idempotent, which means you can call it just in case and
+it will do the right thing.
+
+Unlike some other "ToUnicode" implementations, this one works on full
+domain 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.
+
+At the moment, this function simply calls C<idn_nameprep $idn, 1>,
+returning it's argument when that function fails.
+
+=cut
+
+sub idn_to_unicode($) {
+   my $res = eval { idn_nameprep $_[0], 1 };
+   defined $res ? $res : $_[0]
+}
+
+
 1;
 
 =back

Added: branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/idna.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/idna.pl?rev=49059&op=file
==============================================================================
--- branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/idna.pl (added)
+++ branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/idna.pl Mon Dec 21 04:43:52 2009
@@ -1,0 +1,132 @@
+# based on RFC 3492
+
+use AnyEvent (); BEGIN { AnyEvent::common_sense }
+use Carp ();
+use List::Util ();
+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;
+
+   while ($h < @input) {
+      my $m = List::Util::min grep { $_ >= $n } map ord, @input;
+
+      $m - $n <= (0x7fffffff - $delta) / ($h + 1)
+         or Carp::croak "punycode_encode: overflow in punycode delta encoding";
+      $delta += ($m - $n) * ($h + 1);
+      $n = $m;
+
+      for my $i (@input) {
+         my $c = ord $i;
+         ++$delta < 0x7fffffff
+            or Carp::croak "punycode_encode: overflow in punycode delta encoding"
+            if $c < $n;
+
+         if ($c == $n) {
+            my ($q, $k) = ($delta, pyc_base);
+
+            while () {
+                my $t = List::Util::min pyc_tmax, List::Util::max pyc_tmin, $k - $bias;
+
+                last if $q < $t;
+
+                $output .= substr pyc_digits, $t + (($q - $t) % (pyc_base - $t)), 1;
+
+                $q = ($q - $t) / (pyc_base - $t);
+                $k += pyc_base;
+            }
+
+            $output .= substr pyc_digits, $q, 1;
+
+            $bias = pyc_adapt $delta, $h + 1, $h == $b;
+
+            $delta = 0;
+            ++$h;
+         }
+      }
+
+      ++$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]/
+         and Carp::croak "punycode_decode: malformed punycode";
+   }
+
+   while (length $input) {
+      my $oldi = $i;
+      my $w    = 1;
+
+      for (my $k = pyc_base; ; $k += pyc_base) {
+         (my $digit = index pyc_digits, substr $input, 0, 1, "")
+            >= 0
+            or Carp::croak "punycode_decode: malformed punycode";
+      
+         $i += $digit * $w;
+         
+         my $t = List::Util::max pyc_tmin, List::Util::min pyc_tmax, $k - $bias;
+         last if $digit < $t;
+
+         $w *= pyc_base - $t;
+      }
+
+      my $outlen = 1 + length $output;
+      $bias = pyc_adapt $i - $oldi, $outlen, $oldi == 0;
+
+      $n += $i / $outlen;
+      $i %=      $outlen;
+
+      substr $output, $i, 0, chr $n;
+      ++$i;
+   }
+
+   $output
+}
+
+1

Added: branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/uts46data.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/uts46data.pl?rev=49059&op=file
==============================================================================
Binary file - no diff available.

Propchange: branches/upstream/libanyevent-perl/current/lib/AnyEvent/Util/uts46data.pl
------------------------------------------------------------------------------
    svn:mime-type = application/octet-stream

Added: branches/upstream/libanyevent-perl/current/t/08_idna.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/t/08_idna.t?rev=49059&op=file
==============================================================================
--- branches/upstream/libanyevent-perl/current/t/08_idna.t (added)
+++ branches/upstream/libanyevent-perl/current/t/08_idna.t Mon Dec 21 04:43:52 2009
@@ -1,0 +1,20 @@
+use utf8;
+use AnyEvent::Util;
+
+$| = 1; print "1..11\n";
+
+print "ok 1\n";
+
+print "ko-eka" eq (AnyEvent::Util::punycode_encode "öko" ) ? "" : "not ", "ok 2\n";
+print "wgv71a" eq (AnyEvent::Util::punycode_encode "日本") ? "" : "not ", "ok 3\n";
+
+print "öko"  eq (AnyEvent::Util::punycode_decode "ko-eka") ? "" : "not ", "ok 4\n";
+print "日本" eq (AnyEvent::Util::punycode_decode "wgv71a") ? "" : "not ", "ok 5\n";
+
+print "www.xn--ko-eka.eu"   eq (AnyEvent::Util::idn_to_ascii "www.öko.eu"  ) ? "" : "not ", "ok 6\n";
+print "xn--1-jn6bt1b.co.jp" eq (AnyEvent::Util::idn_to_ascii "日本1.co.jp" ) ? "" : "not ", "ok 7\n";
+print "xn--tda.com"         eq (AnyEvent::Util::idn_to_ascii "xn--tda.com" ) ? "" : "not ", "ok 8\n";
+print "xn--a-ecp.ru"        eq (AnyEvent::Util::idn_to_ascii "xn--a-ecp.ru") ? "" : "not ", "ok 9\n";
+print "xn--wgv71a119e.jp"   eq (AnyEvent::Util::idn_to_ascii "日本語。JP") ? "" : "not ", "ok 10\n";
+
+print "ok 11\n";

Added: branches/upstream/libanyevent-perl/current/util/gen_uts46data
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libanyevent-perl/current/util/gen_uts46data?rev=49059&op=file
==============================================================================
--- branches/upstream/libanyevent-perl/current/util/gen_uts46data (added)
+++ branches/upstream/libanyevent-perl/current/util/gen_uts46data Mon Dec 21 04:43:52 2009
@@ -1,0 +1,78 @@
+#!/opt/bin/perl
+
+# creates lib/AnyEvent/Util/uts46.pl - better do not run it!
+
+use common::sense;
+use utf8;
+no warnings 'utf8';
+
+binmode STDOUT, ":utf8";
+
+open my $fh, "GET http://www.unicode.org/Public/idna/5.2.0/IdnaMappingTable.txt |"
+   or die;
+
+my $valid;
+my $imap;   # index map \x00 char replacement
+
+while (<$fh>) {
+   next unless /^[0-9A-F]/;
+
+   /^
+    ([0-9A-F]{4,}) (?: \.\.([0-9A-F]{4,}) )?
+    \s*;\s*(\S+)
+    (?: \s*;\s*([0-9A-F ]+?) )?
+    \s*
+    (?: \#.* )?
+    $
+   /x or die "$_: unparsable";
+
+   my ($r1, $r2, $type, $map) = (hex $1, hex $2, $3, $4);
+
+   my $R1 = chr $r1;
+   my $R2 = chr $r2;
+
+   $map = join "", map chr hex, split ' ', $map;
+
+   given ($type) {
+      when ("disallowed") {
+         # nop
+      }
+      when (/mapped|deviation|ignored/) {
+         $map = "\x01$map" if $type eq "deviation";
+
+         $imap .= "\x00" . chr . $map
+            for $r1 .. $r2 || $r1;
+      }
+      when ("valid") {
+         (vec $valid, $_, 1) = 1
+            for $r1 .. $r2 || $r1;
+      }
+      default {
+         die "default: $R1,$R2,$type,$map;\n";
+      }
+   }
+}
+
+open my $fh, ">lib/AnyEvent/Util/uts46data.pl"
+   or die;
+binmode $fh, ":perlio";
+print $fh "# autogenerated by util/gen_uts46data\n";
+
+utf8::encode $imap;
+0 > index $imap, "\x02" # it's not supposed to be anywhere in there
+   or die "imap contains \\x02";
+print $fh "\$uts46_imap = q\x02$imap\x00\x02;\n";
+
+# try to find a valid quoting character - there usually are many legal combos
+for (1..127) { # stay out of utf-8 range
+   if (0 >= index $valid, chr) {
+      print $fh "\$uts46_valid = q", chr, $valid, chr, ";\n";
+      goto valid_ok;
+   }
+}
+die "unable to found valid quoting character";
+valid_ok:;
+
+print $fh "1;\n";
+close $fh;
+

Propchange: branches/upstream/libanyevent-perl/current/util/gen_uts46data
------------------------------------------------------------------------------
    svn:executable = *




More information about the Pkg-perl-cvs-commits mailing list