[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/Socket.pm

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC vs.
Revision 1.83 by root, Mon Jun 29 21:00:32 2009 UTC

 AnyEvent::Socket - useful IPv4 and IPv6 stuff.
 =head1 SYNOPSIS
- use AnyEvent::Socket;
+   use AnyEvent::Socket;
- tcp_connect "gameserver.deliantra.net", 13327, sub {
+   tcp_connect "gameserver.deliantra.net", 13327, sub {
-    my ($fh) = @_
+      my ($fh) = @_
-       or die "gameserver.deliantra.net connect failed: $!";
+         or die "gameserver.deliantra.net connect failed: $!";
-    # enjoy your filehandle
+      # enjoy your filehandle
- };
+   };
- # a simple tcp server
+   # a simple tcp server
- tcp_server undef, 8888, sub {
+   tcp_server undef, 8888, sub {
-    my ($fh, $host, $port) = @_;
+      my ($fh, $host, $port) = @_;
-    syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
+      syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
- };
+   };
 =head1 DESCRIPTION
 This module implements various utility functions for handling internet
 protocol addresses and sockets, in an as transparent and simple way as
 use AnyEvent::DNS ();
 use base 'Exporter';
 our @EXPORT = qw(
+   parse_hostport
    parse_ipv4 parse_ipv6
    parse_ip parse_address
    format_ip format_address
    address_family
    inet_aton
    tcp_server
    tcp_connect
 );
-our $VERSION = '1.0';
+our $VERSION = 4.45;
 =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
    # check leading parts against range
    return undef if grep $_ >= 256, @_[0 .. @_ - 2];
    # check trailing part against range
-   return undef if $_[-1] >= 1 << (8 * (4 - $#_));
+   return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
    pack "N", (pop)
              + ($_[0] << 24)
              + ($_[1] << 16)
              + ($_[2] <<  8);
       ? pack "S", AF_UNIX
       : undef
 }
-=item $ipn = parse_address $text
+=item $ipn = parse_address $ip
 Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
 here refers to the host address (not socket address) in network form
 (binary).
 If the C<$text> is C<unix/>, then this function returns a special token
 recognised by the other functions in this module to mean "UNIX domain
 socket".
+If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
+then it will be treated as an IPv4 address. If you don't want that, you
+have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
+=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($) {
-   &parse_ipv4 || &parse_ipv6 || &parse_unix
+   for (&parse_ipv6) {
+      if ($_) {
+         s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
+         return $_;
+      } else {
+         return &parse_ipv4 || &parse_unix
+      }
+   }
 }
-*parse_ip =\&parse_address; #d#
+*aton = \&parse_address;
+=item ($host, $service) = parse_hostport $string[, $default_service]
+Splitting a string of the form C<hostname:port> is a common
+problem. Unfortunately, just splitting on the colon makes it hard to
+specify IPv6 addresses and doesn't support the less common but well
+standardised C<[ip literal]> syntax.
+This function tries to do this job in a better way, it supports the
+following formats, where C<port> can be a numerical port number of a
+service name, or a C<name=port> string, and the C< port> and C<:port>
+parts are optional. Also, everywhere where an IP address is supported
+a hostname or unix domain socket address is also supported (see
+C<parse_unix>).
+   hostname:port    e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
+   ipv4:port        e.g. "198.182.196.56", "127.1:22"
+   ipv6             e.g. "::1", "affe::1"
+   [ipv4or6]:port   e.g. "[::1]", "[10.0.1]:80"
+   [ipv4or6] port   e.g. "[127.0.0.1]", "[www.x.org] 17"
+   ipv4or6 port     e.g. "::1 443", "10.0.0.1 smtp"
+It also supports defaulting the service name in a simple way by using
+C<$default_service> if no service was detected. If neither a service was
+detected nor a default was specified, then this function returns the
+empty list. The same happens when a parse error weas detected, such as a
+hostname with a colon in it (the function is rather conservative, though).
+Example:
+  print join ",", parse_hostport "localhost:443";
+  # => "localhost,443"
+  print join ",", parse_hostport "localhost", "https";
+  # => "localhost,https"
+  print join ",", parse_hostport "[::1]";
+  # => "," (empty list)
+=cut
+sub parse_hostport($;$) {
+   my ($host, $port);
+   for ("$_[0]") { # work on a copy, just in case, and also reset pos
+      # parse host, special cases: "ipv6" or "ipv6 port"
+      unless (
+         ($host) = /^\s* ([0-9a-fA-F:]*:[0-9a-fA-F:]*:[0-9a-fA-F\.:]*)/xgc
+         and parse_ipv6 $host
+      ) {
+         /^\s*/xgc;
+         if (/^ \[ ([^\[\]]+) \]/xgc) {
+            $host = $1;
+         } elsif (/^ ([^\[\]:\ ]+) /xgc) {
+            $host = $1;
+         } else {
+            return;
+         }
+      }
+      # parse port
+      if (/\G (?:\s+|:) ([^:[:space:]]+) \s*$/xgc) {
+         $port = $1;
+      } elsif (/\G\s*$/gc && length $_[1]) {
+         $port = $_[1];
+      } else {
+         return;
+      }
+   }
+   # hostnames must not contain :'s
+   return if $host =~ /:/ && !parse_ipv6 $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.
       : 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
+its textual format. Rarely used, see C<format_address> for a nicer
+interface.
+=item $text = format_ipv6 $ipn
+Expects a sixteen octet string representing a binary IPv6 address and
+returns its textual format. Rarely used, see C<format_address> for a
+nicer interface.
 =item $text = format_address $ipn
 Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
 octets for IPv6) and convert it into textual form.
 This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
 except it automatically detects the address type.
 Returns C<undef> if it cannot detect the type.
-=cut
+If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
+the contained IPv4 address will be returned. If you do not want that, you
+have to call C<format_ipv6> manually.
-sub format_address;
+=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 (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
+      return "::ffff:" . format_ipv4 substr $_[0], 12;
+   } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
+      # v4translated
+      return "::ffff:0:" . format_ipv4 substr $_[0], 12;
+   } else {
+      my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
+      # this is rather sucky, I admit
+      $ip =~ s/^0:(?:0:)*(0$)?/::/
+         or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
+         or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
+         or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
+         or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
+         or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
+         or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
+         or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
+      return $ip
+   }
+}
 sub format_address($) {
    my $af = address_family $_[0];
    if ($af == AF_INET) {
-      return join ".", unpack "C4", $_[0]
+      return &format_ipv4;
    } elsif ($af == AF_INET6) {
-      if (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
-         # v4compatible
-         return "::" . format_address substr $_[0], 12;
-      } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
+      return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
-         # v4mapped
+         ? format_ipv4 substr $_[0], 12
-         return "::ffff:" . format_address substr $_[0], 12;
+         : &format_ipv6;
-      } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
-         # v4translated
-         return "::ffff:0:" . format_address substr $_[0], 12;
-      } else {
-         my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
-         $ip =~ s/^0:(?:0:)*(0$)?/::/
-            or $ip =~ s/(:0)+$/::/
-            or $ip =~ s/(:0)+/:/;
-         return $ip
-      }
    } elsif ($af == AF_UNIX) {
       return "unix/"
    } else {
       return undef
    }
 }
-*format_ip = \&format_address;
+*ntoa = \&format_address;
 =item inet_aton $name_or_address, $cb->(@addresses)
 Works similarly to its Socket counterpart, except that it uses a
 callback. Also, if a host has only an IPv6 address, this might be passed
 # check for broken platforms with extra field in sockaddr structure
 # kind of a rfc vs. bsd issue, as usual (ok, normally it's a
 # unix vs. bsd issue, a iso C vs. bsd issue or simply a
 # correctness vs. bsd issue.
-my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55"
+my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
                   ? "xC" : "S";
 =item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
 Pack the given port/host combination into a binary sockaddr
 C<sctp>. The default is currently C<tcp>, but in the future, this function
 might try to use other protocols such as C<sctp>, depending on the socket
 type and any SRV records it might find.
 C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
-only IPv4) or C<6> (use only IPv6). This setting might be influenced by
+only IPv4) or C<6> (use only IPv6). The default is influenced by
 C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
 C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
-C<undef> in which case it gets automatically chosen).
+C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
+unless C<$proto> is C<udp>).
 The callback will receive zero or more array references that contain
 C<$family, $type, $proto> for use in C<socket> and a binary
 C<$sockaddr> for use in C<connect> (or C<bind>).
    resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
 =cut
+# 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 resolve_sockaddr($$$$$$) {
    my ($node, $service, $proto, $family, $type, $cb) = @_;
    if ($node eq "unix/") {
-      return $cb->() if $family || !/^\//; # no can do
+      return $cb->() if $family || $service !~ /^\//; # no can do
-      return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);
+      return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
    }
    unless (AF_INET6) {
       $family != 6
          or return $cb->();
    $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
    $proto ||= "tcp";
    $type  ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
-   my $proton = (getprotobyname $proto)[2]
+   my $proton = $PROTO_BYNAME{lc $proto} || (getprotobyname $proto)[2]
       or Carp::croak "$proto: protocol unknown";
    my $port;
    if ($service =~ /^(\S+)=(\d+)$/) {
       $cv->begin;
       for my $idx (0 .. $#target) {
          my ($node, $port) = @{ $target[$idx] };
          if (my $noden = parse_address $node) {
+            my $af = address_family $noden;
-            if (4 == length $noden && $family != 6) {
+            if ($af == AF_INET && $family != 6) {
                push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
                            pack_sockaddr $port, $noden]]
             }
-            if (16 == length $noden && $family != 4) {
+            if ($af == AF_INET6 && $family != 4) {
                push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
                            pack_sockaddr $port, $noden]]
             }
          } else {
             # ipv4
             if ($family != 6) {
                $cv->begin;
-               a $node, sub {
+               AnyEvent::DNS::a $node, sub {
                   push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
                               pack_sockaddr $port, parse_ipv4 $_]]
                      for @_;
                   $cv->end;
                };
             }
             # ipv6
             if ($family != 4) {
                $cv->begin;
-               aaaa $node, sub {
+               AnyEvent::DNS::aaaa $node, sub {
                   push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
                               pack_sockaddr $port, parse_ipv6 $_]]
                      for @_;
                   $cv->end;
                };
    # try srv records, if applicable
    if ($node eq "localhost") {
       @target = (["127.0.0.1", $port], ["::1", $port]);
       &$resolve;
    } elsif (defined $service && !parse_address $node) {
-      srv $service, $proto, $node, sub {
+      AnyEvent::DNS::srv $service, $proto, $node, sub {
          my (@srv) = @_;
          # no srv records, continue traditionally
          @srv
             or return &$resolve;
-         # only srv record has "." => abort
+         # the only srv record has "." ("" here) => abort
-         $srv[0][2] ne "." || $#srv
+         $srv[0][2] ne "" || $#srv
             or return $cb->();
          # use srv records then
          @target = map ["$_->[3].", $_->[2]],
                       grep $_->[3] ne ".",
 lessen the impact of this windows bug, a default timeout of 30 seconds
 will be imposed on windows. Cygwin is not affected.
 Simple Example: connect to localhost on port 22.
-  tcp_connect localhost => 22, sub {
+   tcp_connect localhost => 22, sub {
-     my $fh = shift
+      my $fh = shift
-        or die "unable to connect: $!";
+         or die "unable to connect: $!";
-     # do something
+      # do something
-  };
+   };
 Complex Example: connect to www.google.com on port 80 and make a simple
 GET request without much error handling. Also limit the connection timeout
 to 15 seconds.
    # also http://advogato.org/article/672.html
    my %state = ( fh => undef );
    # name/service to type/sockaddr resolution
-   resolve_sockaddr $host, $port, 0, 0, 0, sub {
+   resolve_sockaddr $host, $port, 0, 0, undef, sub {
       my @target = @_;
       $state{next} = sub {
          return unless exists $state{fh};
             $state{next}();
          }) if $timeout;
          # called when the connect was successful, which,
          # in theory, could be the case immediately (but never is in practise)
-         my $connected = sub {
+         $state{connected} = sub {
             delete $state{ww};
             delete $state{to};
             # we are connected, or maybe there was an error
             if (my $sin = getpeername $state{fh}) {
                my ($port, $host) = unpack_sockaddr $sin;
-               my $guard = guard {
+               my $guard = guard { %state = () };
-                  %state = ();
-               };
-               $connect->($state{fh}, format_address $host, $port, sub {
+               $connect->(delete $state{fh}, format_address $host, $port, sub {
                   $guard->cancel;
                   $state{next}();
                });
             } else {
                # dummy read to fetch real error code
             }
          };
          # now connect
          if (connect $state{fh}, $sockaddr) {
-            $connected->();
+            $state{connected}->();
          } elsif ($! == &Errno::EINPROGRESS # POSIX
                   || $! == &Errno::EWOULDBLOCK
                   # WSAEINPROGRESS intentionally not checked - it means something else entirely
                   || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
                   || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
-            $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
+            $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
          } else {
             $state{next}();
          }
       };
 Create and bind a stream socket to the given host, and port, set the
 SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
 implies, this function can also bind on UNIX domain sockets.
 For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
-C<undef>, in which case it binds either to C<0> or to C<::>, depending on
+C<undef>, in which case it binds either to C<0> or to C<::>, depending
-whether IPv4 or IPv6 is the preferred protocol).
+on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
+future versions, as applicable).
 To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
 wildcard address, use C<::>.
 The port is specified by C<$service>, which must be either a service name or
 address and port number of the local socket endpoint as second and third
 arguments.
 It should return the length of the listen queue (or C<0> for the default).
+Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
+C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
+hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
+if you want both IPv4 and IPv6 listening sockets you should create the
+IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
+any C<EADDRINUSE> errors.
 Example: bind on some TCP port on the local machine and tell each client
 to go away.
    tcp_server undef, undef, sub {
       my ($fh, $host, $port) = @_;
    }, sub {
       my ($fh, $thishost, $thisport) = @_;
       warn "bound to $thishost, port $thisport\n";
    };
+Example: bind a server on a unix domain socket.
+   tcp_server "unix/", "/tmp/mydir/mysocket", sub {
+      my ($fh) = @_;
+   };
 =cut
 sub tcp_server($$$;$) {
    my ($host, $service, $accept, $prepare) = @_;
       or Carp::croak "tcp_server/socket: $!";
    if ($af == AF_INET || $af == AF_INET6) {
       setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
          or Carp::croak "tcp_server/so_reuseaddr: $!"
-            unless !AnyEvent::WIN32; # work around windows bug
+            unless AnyEvent::WIN32; # work around windows bug
       unless ($service =~ /^\d*$/) {
          $service = (getservbyname $service, "tcp")[2]
                     or Carp::croak "$service: service unknown"
       }
    $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
       # this closure keeps $state alive
       while (my $peer = accept my $fh, $state{fh}) {
          fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
          my ($service, $host) = unpack_sockaddr $peer;
          $accept->($fh, format_address $host, $service);
       }
    });
 1;
 =back
+=head1 SECURITY CONSIDERATIONS
+This module is quite powerful, with with power comes the ability to abuse
+as well: If you accept "hostnames" and ports from untrusted sources,
+then note that this can be abused to delete files (host=C<unix/>). This
+is not really a problem with this module, however, as blindly accepting
+any address and protocol and trying to bind a server or connect to it is
+harmful in general.
 =head1 AUTHOR
  Marc Lehmann <schmorp@schmorp.de>
  http://home.schmorp.de/

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC vs. Revision 1.83 by root, Mon Jun 29 21:00:32 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC vs.
Revision 1.83 by root, Mon Jun 29 21:00:32 2009 UTC