Profile of IO/Socket/INET.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:36 2012

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/5.12.3/x86_64-linux/IO/Socket/INET.pm
Statements | Executed 30 statements in 1.54ms

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