← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:13 2021

Filename/usr/local/lib/perl5/5.32/mach/IO/Socket/INET.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sIO::Socket::INET::::BEGIN@10IO::Socket::INET::BEGIN@10
0000s0sIO::Socket::INET::::BEGIN@11IO::Socket::INET::BEGIN@11
0000s0sIO::Socket::INET::::BEGIN@12IO::Socket::INET::BEGIN@12
0000s0sIO::Socket::INET::::BEGIN@13IO::Socket::INET::BEGIN@13
0000s0sIO::Socket::INET::::BEGIN@14IO::Socket::INET::BEGIN@14
0000s0sIO::Socket::INET::::BEGIN@9IO::Socket::INET::BEGIN@9
0000s0sIO::Socket::INET::::_cache_protoIO::Socket::INET::_cache_proto
0000s0sIO::Socket::INET::::_errorIO::Socket::INET::_error
0000s0sIO::Socket::INET::::_get_addrIO::Socket::INET::_get_addr
0000s0sIO::Socket::INET::::_get_proto_nameIO::Socket::INET::_get_proto_name
0000s0sIO::Socket::INET::::_get_proto_numberIO::Socket::INET::_get_proto_number
0000s0sIO::Socket::INET::::_sock_infoIO::Socket::INET::_sock_info
0000s0sIO::Socket::INET::::bindIO::Socket::INET::bind
0000s0sIO::Socket::INET::::configureIO::Socket::INET::configure
0000s0sIO::Socket::INET::::connectIO::Socket::INET::connect
0000s0sIO::Socket::INET::::newIO::Socket::INET::new
0000s0sIO::Socket::INET::::peeraddrIO::Socket::INET::peeraddr
0000s0sIO::Socket::INET::::peerhostIO::Socket::INET::peerhost
0000s0sIO::Socket::INET::::peerportIO::Socket::INET::peerport
0000s0sIO::Socket::INET::::sockaddrIO::Socket::INET::sockaddr
0000s0sIO::Socket::INET::::sockhostIO::Socket::INET::sockhost
0000s0sIO::Socket::INET::::sockportIO::Socket::INET::sockport
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# IO::Socket::INET.pm
2#
3# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6
7package IO::Socket::INET;
8
9use strict;
10use IO::Socket;
11use Socket;
12use Carp;
13use Exporter;
14use Errno;
15
16our @ISA = qw(IO::Socket);
17our $VERSION = "1.41";
18
19my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
20
21IO::Socket::INET->register_domain( AF_INET );
22
23my %socket_type = ( tcp => SOCK_STREAM,
24 udp => SOCK_DGRAM,
25 icmp => SOCK_RAW
26 );
27my %proto_number;
28$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP;
29$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP;
30$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
31my %proto_name = reverse %proto_number;
32
33sub new {
34 my $class = shift;
35 unshift(@_, "PeerAddr") if @_ == 1;
36 return $class->SUPER::new(@_);
37}
38
39sub _cache_proto {
40 my @proto = @_;
41 for (map lc($_), $proto[0], split(' ', $proto[1])) {
42 $proto_number{$_} = $proto[2];
43 }
44 $proto_name{$proto[2]} = $proto[0];
45}
46
47sub _get_proto_number {
48 my $name = lc(shift);
49 return undef unless defined $name;
50 return $proto_number{$name} if exists $proto_number{$name};
51
52 my @proto = eval { getprotobyname($name) };
53 return undef unless @proto;
54 _cache_proto(@proto);
55
56 return $proto[2];
57}
58
59sub _get_proto_name {
60 my $num = shift;
61 return undef unless defined $num;
62 return $proto_name{$num} if exists $proto_name{$num};
63
64 my @proto = eval { getprotobynumber($num) };
65 return undef unless @proto;
66 _cache_proto(@proto);
67
68 return $proto[0];
69}
70
71sub _sock_info {
72 my($addr,$port,$proto) = @_;
73 my $origport = $port;
74 my @serv = ();
75
76 $port = $1
77 if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
78
79 if(defined $proto && $proto =~ /\D/) {
80 my $num = _get_proto_number($proto);
81 unless (defined $num) {
82 $@ = "Bad protocol '$proto'";
83 return;
84 }
85 $proto = $num;
86 }
87
88 if(defined $port) {
89 my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
90 my $pnum = ($port =~ m,^(\d+)$,)[0];
91
92 @serv = getservbyname($port, _get_proto_name($proto) || "")
93 if ($port =~ m,\D,);
94
95 $port = $serv[2] || $defport || $pnum;
96 unless (defined $port) {
97 $@ = "Bad service '$origport'";
98 return;
99 }
100
101 $proto = _get_proto_number($serv[3]) if @serv && !$proto;
102 }
103
104 return ($addr || undef,
105 $port || undef,
106 $proto || undef
107 );
108}
109
110sub _error {
111 my $sock = shift;
112 my $err = shift;
113 {
114 local($!);
115 my $title = ref($sock).": ";
116 $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
117 $sock->close()
118 if(defined fileno($sock));
119 }
120 $! = $err;
121 return undef;
122}
123
124sub _get_addr {
125 my($sock,$addr_str, $multi) = @_;
126 my @addr;
127 if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
128 (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
129 } else {
130 my $h = inet_aton($addr_str);
131 push(@addr, $h) if defined $h;
132 }
133 @addr;
134}
135
136sub configure {
137 my($sock,$arg) = @_;
138 my($lport,$rport,$laddr,$raddr,$proto,$type);
139
140
141 $arg->{LocalAddr} = $arg->{LocalHost}
142 if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
143
144 ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
145 $arg->{LocalPort},
146 $arg->{Proto})
147 or return _error($sock, $!, $@);
148
149 $laddr = defined $laddr ? inet_aton($laddr)
150 : INADDR_ANY;
151
152 return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
153 unless(defined $laddr);
154
155 $arg->{PeerAddr} = $arg->{PeerHost}
156 if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
157
158 unless(exists $arg->{Listen}) {
159 ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
160 $arg->{PeerPort},
161 $proto)
162 or return _error($sock, $!, $@);
163 }
164
165 $proto ||= _get_proto_number('tcp');
166
167 $type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
168
169 my @raddr = ();
170
171 if(defined $raddr) {
172 @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
173 return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
174 unless @raddr;
175 }
176
177 while(1) {
178
179 $sock->socket(AF_INET, $type, $proto) or
180 return _error($sock, $!, "$!");
181
182 if (defined $arg->{Blocking}) {
183 defined $sock->blocking($arg->{Blocking})
184 or return _error($sock, $!, "$!");
185 }
186
187 if ($arg->{Reuse} || $arg->{ReuseAddr}) {
188 $sock->sockopt(SO_REUSEADDR,1) or
189 return _error($sock, $!, "$!");
190 }
191
192 if ($arg->{ReusePort}) {
193 $sock->sockopt(SO_REUSEPORT,1) or
194 return _error($sock, $!, "$!");
195 }
196
197 if ($arg->{Broadcast}) {
198 $sock->sockopt(SO_BROADCAST,1) or
199 return _error($sock, $!, "$!");
200 }
201
202 if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
203 $sock->bind($lport || 0, $laddr) or
204 return _error($sock, $!, "$!");
205 }
206
207 if(exists $arg->{Listen}) {
208 $sock->listen($arg->{Listen} || 5) or
209 return _error($sock, $!, "$!");
210 last;
211 }
212
213 # don't try to connect unless we're given a PeerAddr
214 last unless exists($arg->{PeerAddr});
215
216 $raddr = shift @raddr;
217
218 return _error($sock, $EINVAL, 'Cannot determine remote port')
219 unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
220
221 last
222 unless($type == SOCK_STREAM || defined $raddr);
223
224 return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
225 unless defined $raddr;
226
227# my $timeout = ${*$sock}{'io_socket_timeout'};
228# my $before = time() if $timeout;
229
230 undef $@;
231 if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
232# ${*$sock}{'io_socket_timeout'} = $timeout;
233 return $sock;
234 }
235
236 return _error($sock, $!, $@ || "Timeout")
237 unless @raddr;
238
239# if ($timeout) {
240# my $new_timeout = $timeout - (time() - $before);
241# return _error($sock,
242# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
243# "Timeout") if $new_timeout <= 0;
244# ${*$sock}{'io_socket_timeout'} = $new_timeout;
245# }
246
247 }
248
249 $sock;
250}
251
252sub connect {
253 @_ == 2 || @_ == 3 or
254 croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
255 my $sock = shift;
256 return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
257}
258
259sub bind {
260 @_ == 2 || @_ == 3 or
261 croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
262 my $sock = shift;
263 return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
264}
265
266sub sockaddr {
267 @_ == 1 or croak 'usage: $sock->sockaddr()';
268 my($sock) = @_;
269 my $name = $sock->sockname;
270 $name ? (sockaddr_in($name))[1] : undef;
271}
272
273sub sockport {
274 @_ == 1 or croak 'usage: $sock->sockport()';
275 my($sock) = @_;
276 my $name = $sock->sockname;
277 $name ? (sockaddr_in($name))[0] : undef;
278}
279
280sub sockhost {
281 @_ == 1 or croak 'usage: $sock->sockhost()';
282 my($sock) = @_;
283 my $addr = $sock->sockaddr;
284 $addr ? inet_ntoa($addr) : undef;
285}
286
287sub peeraddr {
288 @_ == 1 or croak 'usage: $sock->peeraddr()';
289 my($sock) = @_;
290 my $name = $sock->peername;
291 $name ? (sockaddr_in($name))[1] : undef;
292}
293
294sub peerport {
295 @_ == 1 or croak 'usage: $sock->peerport()';
296 my($sock) = @_;
297 my $name = $sock->peername;
298 $name ? (sockaddr_in($name))[0] : undef;
299}
300
301sub peerhost {
302 @_ == 1 or croak 'usage: $sock->peerhost()';
303 my($sock) = @_;
304 my $addr = $sock->peeraddr;
305 $addr ? inet_ntoa($addr) : undef;
306}
307
3081;
309
310__END__