Avoid most getprotobyname/number calls in IO::Socket::INET

Message-ID: <lr3bjlbg3r.fsf@caliper.activestate.com>

p4raw-id: //depot/perl@26921

diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm
index 73f4abd..a50b11c 100644 (file)
--- a/ext/IO/lib/IO/Socket/INET.pm
+++ b/ext/IO/lib/IO/Socket/INET.pm
@@ -24,6 +24,11 @@ my %socket_type = ( tcp  => SOCK_STREAM,
                    udp  => SOCK_DGRAM,
                    icmp => SOCK_RAW
                  );
+my %proto_number;
+$proto_number{tcp}  = Socket::IPPROTO_TCP()  if defined &Socket::IPPROTO_TCP;
+$proto_number{upd}  = Socket::IPPROTO_UDP()  if defined &Socket::IPPROTO_UDP;
+$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
+my %proto_name = reverse %proto_number;
 
 sub new {
     my $class = shift;
@@ -31,30 +36,60 @@ sub new {
     return $class->SUPER::new(@_);
 }
 
+sub _cache_proto {
+    my @proto = @_;
+    for (map lc($_), $proto[0], split(' ', $proto[1])) {
+       $proto_number{$_} = $proto[2];
+    }
+    $proto_name{$proto[2]} = $proto[0];
+}
+
+sub _get_proto_number {
+    my $name = lc(shift);
+    return undef unless defined $name;
+    return $proto_number{$name} if exists $proto_number{$name};
+
+    my @proto = getprotobyname($name);
+    return undef unless @proto;
+    _cache_proto(@proto);
+
+    return $proto[2];
+}
+
+sub _get_proto_name {
+    my $num = shift;
+    return undef unless defined $num;
+    return $proto_name{$num} if exists $proto_name{$num};
+
+    my @proto = getprotobynumber($num);
+    return undef unless @proto;
+    _cache_proto(@proto);
+
+    return $proto[0];
+}
+
 sub _sock_info {
   my($addr,$port,$proto) = @_;
   my $origport = $port;
-  my @proto = ();
   my @serv = ();
 
   $port = $1
        if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
 
   if(defined $proto  && $proto =~ /\D/) {
-    if(@proto = getprotobyname($proto)) {
-      $proto = $proto[2] || undef;
-    }
-    else {
+    my $num = _get_proto_number($proto);
+    unless (defined $num) {
       $@ = "Bad protocol '$proto'";
       return;
     }
+    $proto = $num;
   }
 
   if(defined $port) {
     my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
     my $pnum = ($port =~ m,^(\d+)$,)[0];
 
-    @serv = getservbyname($port, $proto[0] || "")
+    @serv = getservbyname($port, _get_proto_name($proto) || "")
        if ($port =~ m,\D,);
 
     $port = $serv[2] || $defport || $pnum;
@@ -63,8 +98,7 @@ sub _sock_info {
        return;
     }
 
-    $proto = (getprotobyname($serv[3]))[2] || undef
-       if @serv && !$proto;
+    $proto = _get_proto_number($serv[3]) if @serv && !$proto;
   }
 
  return ($addr || undef,
@@ -128,10 +162,9 @@ sub configure {
                        or return _error($sock, $!, $@);
     }
 
-    $proto ||= (getprotobyname('tcp'))[2];
+    $proto ||= _get_proto_number('tcp');
 
-    my $pname = (getprotobynumber($proto))[0];
-    $type = $arg->{Type} || $socket_type{lc $pname};
+    $type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
 
     my @raddr = ();