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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.26 by root, Mon May 26 02:18:41 2008 UTC vs.
Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC

 no warnings;
 use strict;
 use Carp ();
 use Errno ();
-use Socket qw(AF_INET SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
+use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
 use AnyEvent ();
 use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
 use AnyEvent::DNS ();
 use base 'Exporter';
-our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
+our @EXPORT = qw(
+   parse_ipv4 parse_ipv6
+   parse_ip parse_address
+   format_ip format_address
+   address_family
+   inet_aton
+   tcp_server
+   tcp_connect
+);
 our $VERSION = '1.0';
 =item $ipn = parse_ipv4 $dotted_quad
    # and done
    pack "n*", map hex, @h, @t
 }
+sub parse_unix($) {
+   $_[0] eq "unix/"
+      ? pack "S", AF_UNIX
+      : undef
+}
-=item $ipn = parse_ip $text
+=item $ipn = parse_address $text
-Combines C<parse_ipv4> and C<parse_ipv6> in one function.
+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).
-=cut
+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".
+=cut
-sub parse_ip($) {
+sub parse_address($) {
-   &parse_ipv4 || &parse_ipv6
+   &parse_ipv4 || &parse_ipv6 || &parse_unix
 }
+*parse_ip =\&parse_address; #d#
+=item $sa_family = address_family $ipn
+Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
+of the given host address in network format.
+=cut
+sub address_family($) {
+   4 == length $_[0]
+      ? AF_INET
+      : 16 == length $_[0]
+         ? AF_INET6
+         : unpack "S", $_[0]
+}
-=item $text = format_ip $ipn
+=item $text = format_address $ipn
-Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)
+Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
-and converts it into textual form.
+octets for IPv6) and convert it into textual form.
+Returns C<unix/> for UNIX domain sockets.
 This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
 except it automatically detects the address type.
-=cut
+Returns C<undef> if it cannot detect the type.
-sub format_ip;
+=cut
+sub format_address;
-sub format_ip($) {
+sub format_address($) {
-   if (4 == length $_[0]) {
+   my $af = address_family $_[0];
+   if ($af == AF_INET) {
       return join ".", unpack "C4", $_[0]
-   } elsif (16 == length $_[0]) {
+   } 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;
-      if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
+      } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
          # v4mapped
-         return "::ffff:" . format_ip substr $_[0], 12;
+         return "::ffff:" . format_address 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_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;
 =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
 to the callback instead (use the length to detect this - 4 for IPv4, 16
 for IPv6).
 Unlike the L<Socket> function of the same name, you can get multiple IPv4
-and IPv6 addresses as result.
+and IPv6 addresses as result (and maybe even other adrdess types).
 =cut
 sub inet_aton {
    my ($name, $cb) = @_;
          }
       });
    }
 }
+# 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")
+                  ? "xC" : "S";
-=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host
+=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
-Pack the given port/host combination into a binary sockaddr structure. Handles
+Pack the given port/host combination into a binary sockaddr
-both IPv4 and IPv6 host addresses.
+structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
+domain sockets (C<$host> == C<unix/> and C<$service> == absolute
+pathname).
 =cut
 sub pack_sockaddr($$) {
-   if (4 == length $_[1]) {
+   my $af = address_family $_[1];
+   if ($af == AF_INET) {
       Socket::pack_sockaddr_in $_[0], $_[1]
-   } elsif (16 == length $_[1]) {
+   } elsif ($af == AF_INET6) {
-      pack "SnL a16 L",
+      pack "$pack_family nL a16 L",
          AF_INET6,
          $_[0], # port
          0,     # flowinfo
          $_[1], # addr
          0      # scope id
+   } elsif ($af == AF_UNIX) {
+      Socket::pack_sockaddr_un $_[0]
    } else {
       Carp::croak "pack_sockaddr: invalid host";
    }
 }
-=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa
+=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
 Unpack the given binary sockaddr structure (as used by bind, getpeername
-etc.) into a C<$port, $host> combination.
+etc.) into a C<$service, $host> combination.
-Handles both IPv4 and IPv6 sockaddr structures.
+For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
+address in network format (binary).
+For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
+is a special token that is understood by the other functions in this
+module (C<format_address> converts it to C<unix/>).
 =cut
 sub unpack_sockaddr($) {
-   my $af = unpack "S", $_[0];
+   my $af = Socket::sockaddr_family $_[0];
    if ($af == AF_INET) {
       Socket::unpack_sockaddr_in $_[0]
    } elsif ($af == AF_INET6) {
       unpack "x2 n x4 a16", $_[0]
+   } elsif ($af == AF_UNIX) {
+      ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
    } else {
       Carp::croak "unpack_sockaddr: unsupported protocol family $af";
    }
 }
-sub _tcp_port($) {
+=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
-   $_[0] =~ /^(\d*)$/ and return $1*1;
-   (getservbyname $_[0], "tcp")[2]
+Tries to resolve the given nodename and service name into protocol families
+and sockaddr structures usable to connect to this node and service in a
+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 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,
+C<$proto> will be ignored.
+C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
+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
+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).
+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>).
+The application should try these in the order given.
+Example:
+   resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
+=cut
+sub resolve_sockaddr($$$$$$) {
+   my ($node, $service, $proto, $family, $type, $cb) = @_;
+   if ($node eq "unix/") {
+      return $cb->() if $family || !/^\//; # no can do
+      return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);
+   }
+   unless (AF_INET6) {
+      $family != 6
+         or return $cb->();
+      $family = 4;
+   }
+   $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
+   $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
+   $family ||= 4 unless $AnyEvent::PROTOCOL{ipv6};
+   $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
+   $proto ||= "tcp";
+   $type  ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
+   my $proton = (getprotobyname $proto)[2]
-      or Carp::croak "$_[0]: service unknown"
+      or Carp::croak "$proto: protocol unknown";
+   my $port;
+   if ($service =~ /^(\S+)=(\d+)$/) {
+      ($service, $port) = ($1, $2);
+   } elsif ($service =~ /^\d+$/) {
+      ($service, $port) = (undef, $service);
+   } else {
+      $port = (getservbyname $service, $proto)[2]
+              or Carp::croak "$service/$proto: service unknown";
+   }
+   my @target = [$node, $port];
+   # resolve a records / provide sockaddr structures
+   my $resolve = sub {
+      my @res;
+      my $cv = AnyEvent->condvar (cb => sub {
+         $cb->(
+            map $_->[2],
+            sort {
+               $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
+                  or $a->[0] <=> $b->[0]
+            }
+            @res
+         )
+      });
+      $cv->begin;
+      for my $idx (0 .. $#target) {
+         my ($node, $port) = @{ $target[$idx] };
+         if (my $noden = parse_address $node) {
+            if (4 == length $noden && $family != 6) {
+               push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
+                           pack_sockaddr $port, $noden]]
+            }
+            if (16 == length $noden && $family != 4) {
+               push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
+                           pack_sockaddr $port, $noden]]
+            }
+         } else {
+            # ipv4
+            if ($family != 6) {
+               $cv->begin;
+               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;
+               AnyEvent::DNS::aaaa $node, sub {
+                  push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
+                              pack_sockaddr $port, parse_ipv6 $_]]
+                     for @_;
+                  $cv->end;
+               };
+            }
+         }
+      }
+      $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) {
+      AnyEvent::DNS::srv $service, $proto, $node, sub {
+         my (@srv) = @_;
+         # no srv records, continue traditionally
+         @srv
+            or return &$resolve;
+         # only srv record has "." => abort
+         $srv[0][2] ne "." || $#srv
+            or return $cb->();
+         # use srv records then
+         @target = map ["$_->[3].", $_->[2]],
+                      grep $_->[3] ne ".",
+                         @srv;
+         &$resolve;
+      };
+   } else {
+      &$resolve;
+   }
 }
 =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
+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)
-textual IP address) and C<$service> (which can be a numeric port number or
+and C<$service> (which can be a numeric port number or a service name,
-a service name, or a C<servicename=portnumber> string).
+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).
 In either case, it will create a list of target hosts (e.g. for multihomed
 timeout value (or C<0>, C<undef> or the empty list to indicate the default
 timeout is to be used).
 Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
 socket (although only IPv4 is currently supported by this module).
+Note to the poor Microsoft Windows users: Windows (of course) doesn't
+correctly signal connection errors, so unless your event library works
+around this, failed connections will simply hang. The only event libraries
+that handle this condition correctly are L<EV> and L<Glib>. Additionally,
+AnyEvent works around this bug with L<Event> and in its pure-perl
+backend. All other libraries cannot correctly handle this condition. To
+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 {
      my $fh = shift
          # could call $fh->bind etc. here
          15
       };
+Example: connect to a UNIX domain socket.
+   tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
+      ...
+   }
 =cut
 sub tcp_connect($$$;$) {
    my ($host, $port, $connect, $prepare) = @_;
    # see http://cr.yp.to/docs/connect.html for some background
+   # also http://advogato.org/article/672.html
    my %state = ( fh => undef );
-   # name resolution
+   # name/service to type/sockaddr resolution
-   AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {
+   resolve_sockaddr $host, $port, 0, 0, 0, sub {
       my @target = @_;
       $state{next} = sub {
          return unless exists $state{fh};
          socket $state{fh}, $domain, $type, $proto
             or return $state{next}();
          fh_nonblocking $state{fh}, 1;
-         # prepare and optional timeout
-         if ($prepare) {
-            my $timeout = $prepare->($state{fh});
+         my $timeout = $prepare && $prepare->($state{fh});
+         $timeout ||= 30 if AnyEvent::WIN32;
-            $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
+         $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
-               $! = &Errno::ETIMEDOUT;
+            $! = &Errno::ETIMEDOUT;
-               $state{next}();
+            $state{next}();
-            }) if $timeout;
+         }) if $timeout;
-         }
          # called when the connect was successful, which,
          # in theory, could be the case immediately (but never is in practise)
          my $connected = sub {
             delete $state{ww};
                my $guard = guard {
                   %state = ();
                };
-               $connect->($state{fh}, format_ip $host, $port, sub {
+               $connect->($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->();
-         } elsif ($! == &Errno::EINPROGRESS || $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
+         } 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);
          } else {
-            %state = ();
+            $state{next}();
-            $connect->();
          }
       };
       $! = &Errno::ENXIO;
       $state{next}();
    };
    defined wantarray && guard { %state = () }
 }
-=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]
+=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
-Create and bind a TCP socket to the given host, and port, set the
+Create and bind a stream socket to the given host, and port, set the
-SO_REUSEADDR flag and call C<listen>.
+SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
+implies, this function can also bind on UNIX domain sockets.
-C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it
+For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
-binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the
+C<undef>, in which case it binds either to C<0> or to C<::>, depending
-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<$port>, which must be either a service name or
+The port is specified by C<$service>, which must be either a service name or
 a numeric port number (or C<0> or C<undef>, in which case an ephemeral
 port will be used).
+For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
+the absolute pathname of the socket. This function will try to C<unlink>
+the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
+below.
 For each new connection that could be C<accept>ed, call the C<<
 $accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
 mode) as first and the peer host and port as second and third arguments
 (see C<tcp_connect> for details).
 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) = @_;
    };
 =cut
 sub tcp_server($$$;$) {
-   my ($host, $port, $accept, $prepare) = @_;
+   my ($host, $service, $accept, $prepare) = @_;
    $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
            ? "::" : "0"
       unless defined $host;
-   my $ipn = parse_ip $host
+   my $ipn = parse_address $host
-      or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as IPv4 or IPv6 address";
+      or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
-   my $domain = 4 == length $ipn ? AF_INET : AF_INET6;
+   my $af = address_family $ipn;
    my %state;
+   # win32 perl is too stupid to get this right :/
+   Carp::croak "tcp_server/socket: address family not supported"
+      if AnyEvent::WIN32 && $af == AF_UNIX;
-   socket $state{fh}, $domain, SOCK_STREAM, 0
+   socket $state{fh}, $af, SOCK_STREAM, 0
-      or Carp::croak "socket: $!";
+      or Carp::croak "tcp_server/socket: $!";
+   if ($af == AF_INET || $af == AF_INET6) {
-   setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
+      setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
-      or Carp::croak "so_reuseaddr: $!";
+         or Carp::croak "tcp_server/so_reuseaddr: $!"
+            unless AnyEvent::WIN32; # work around windows bug
+      unless ($service =~ /^\d*$/) {
+         $service = (getservbyname $service, "tcp")[2]
+                    or Carp::croak "$service: service unknown"
+      }
+   } elsif ($af == AF_UNIX) {
+      unlink $service;
+   }
-   bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn
+   bind $state{fh}, pack_sockaddr $service, $ipn
       or Carp::croak "bind: $!";
    fh_nonblocking $state{fh}, 1;
    my $len;
    if ($prepare) {
-      my ($port, $host) = unpack_sockaddr getsockname $state{fh};
+      my ($service, $host) = unpack_sockaddr getsockname $state{fh};
-      $len = $prepare && $prepare->($state{fh}, format_ip $host, $port);
+      $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
    }
    $len ||= 128;
    listen $state{fh}, $len
    $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 ($port, $host) = unpack_sockaddr $peer;
+         my ($service, $host) = unpack_sockaddr $peer;
-         $accept->($fh, format_ip $host, $port);
+         $accept->($fh, format_address $host, $service);
       }
    });
    defined wantarray
       ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
 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.26 by root, Mon May 26 02:18:41 2008 UTC vs. Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.26 by root, Mon May 26 02:18:41 2008 UTC vs.
Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC