← 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:23:05 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/5.12.3/x86_64-linux/IO/Socket.pm
StatementsExecuted 44 statements in 1.65ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
33326µs2.80msIO::Socket::::importIO::Socket::import
11124µs732µsIO::Socket::::BEGIN@12IO::Socket::BEGIN@12
11111µs23µsIO::Socket::::BEGIN@11IO::Socket::BEGIN@11
1119µs20µsIO::Socket::::BEGIN@17IO::Socket::BEGIN@17
1118µs39µsIO::Socket::::BEGIN@13IO::Socket::BEGIN@13
1118µs8µsIO::Socket::::CORE:packIO::Socket::CORE:pack (opcode)
1117µs19µsIO::Socket::::BEGIN@16IO::Socket::BEGIN@16
1116µs8µsIO::Socket::::BEGIN@14IO::Socket::BEGIN@14
2226µs6µsIO::Socket::::register_domainIO::Socket::register_domain
0000s0sIO::Socket::::acceptIO::Socket::accept
0000s0sIO::Socket::::atmarkIO::Socket::atmark
0000s0sIO::Socket::::bindIO::Socket::bind
0000s0sIO::Socket::::blockingIO::Socket::blocking
0000s0sIO::Socket::::closeIO::Socket::close
0000s0sIO::Socket::::configureIO::Socket::configure
0000s0sIO::Socket::::connectIO::Socket::connect
0000s0sIO::Socket::::connectedIO::Socket::connected
0000s0sIO::Socket::::getsockoptIO::Socket::getsockopt
0000s0sIO::Socket::::listenIO::Socket::listen
0000s0sIO::Socket::::newIO::Socket::new
0000s0sIO::Socket::::peernameIO::Socket::peername
0000s0sIO::Socket::::protocolIO::Socket::protocol
0000s0sIO::Socket::::recvIO::Socket::recv
0000s0sIO::Socket::::sendIO::Socket::send
0000s0sIO::Socket::::setsockoptIO::Socket::setsockopt
0000s0sIO::Socket::::shutdownIO::Socket::shutdown
0000s0sIO::Socket::::sockdomainIO::Socket::sockdomain
0000s0sIO::Socket::::socketIO::Socket::socket
0000s0sIO::Socket::::socketpairIO::Socket::socketpair
0000s0sIO::Socket::::socknameIO::Socket::sockname
0000s0sIO::Socket::::sockoptIO::Socket::sockopt
0000s0sIO::Socket::::socktypeIO::Socket::socktype
0000s0sIO::Socket::::timeoutIO::Socket::timeout
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.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;
8
9124µsrequire 5.006;
10
11319µs235µs
# spent 23µs (11+12) within IO::Socket::BEGIN@11 which was called: # once (11µs+12µs) by IO::Socket::INET::BEGIN@11 at line 11
use IO::Handle;
# spent 23µs making 1 call to IO::Socket::BEGIN@11 # spent 12µs making 1 call to Exporter::import
12350µs31.44ms
# spent 732µs (24+708) within IO::Socket::BEGIN@12 which was called: # once (24µs+708µs) by IO::Socket::INET::BEGIN@11 at line 12
use Socket 1.3;
# spent 732µs making 1 call to IO::Socket::BEGIN@12 # spent 687µs making 1 call to Exporter::import # spent 21µs making 1 call to UNIVERSAL::VERSION
13318µs270µs
# spent 39µs (8+31) within IO::Socket::BEGIN@13 which was called: # once (8µs+31µs) by IO::Socket::INET::BEGIN@11 at line 13
use Carp;
# spent 39µs making 1 call to IO::Socket::BEGIN@13 # spent 31µs making 1 call to Exporter::import
14348µs210µs
# spent 8µs (6+2) within IO::Socket::BEGIN@14 which was called: # once (6µs+2µs) by IO::Socket::INET::BEGIN@11 at line 14
use strict;
# spent 8µs making 1 call to IO::Socket::BEGIN@14 # spent 2µs making 1 call to strict::import
151700nsour(@ISA, $VERSION, @EXPORT_OK);
16317µs230µs
# spent 19µs (7+11) within IO::Socket::BEGIN@16 which was called: # once (7µs+11µs) by IO::Socket::INET::BEGIN@11 at line 16
use Exporter;
# spent 19µs making 1 call to IO::Socket::BEGIN@16 # spent 11µs making 1 call to Exporter::import
1731.32ms230µs
# spent 20µs (9+11) within IO::Socket::BEGIN@17 which was called: # once (9µs+11µs) by IO::Socket::INET::BEGIN@11 at line 17
use Errno;
# spent 20µs making 1 call to IO::Socket::BEGIN@17 # spent 10µs making 1 call to Exporter::import
18
19# legacy
20
211400nsrequire IO::Socket::INET;
22188µsrequire IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
23
24112µs@ISA = qw(IO::Handle);
25
261600ns$VERSION = "1.31";
27
281500ns@EXPORT_OK = qw(sockatmark);
29
30
# spent 2.80ms (26µs+2.77) within IO::Socket::import which was called 3 times, avg 932µs/call: # once (9µs+1.28ms) by Tapper::MCP::Net::BEGIN@13 at line 13 of lib/Tapper/MCP/Net.pm # once (11µs+785µs) by IO::Socket::UNIX::BEGIN@11 at line 11 of IO/Socket/UNIX.pm # once (6µs+708µs) by IO::Socket::INET::BEGIN@11 at line 11 of IO/Socket/INET.pm
sub import {
31611µs my $pkg = shift;
3268µs if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
33 Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
34 } else {
35 my $callpkg = caller;
36357µs Exporter::export 'Socket', $callpkg, @_;
# spent 57µs making 3 calls to Exporter::export, avg 19µs/call
37 }
38}
39
40sub new {
41 my($class,%arg) = @_;
42 my $sock = $class->SUPER::new();
43
44 $sock->autoflush(1);
45
46 ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
47
48 return scalar(%arg) ? $sock->configure(\%arg)
49 : $sock;
50}
51
521300nsmy @domain2pkg;
53
54
# spent 6µs within IO::Socket::register_domain which was called 2 times, avg 3µs/call: # once (3µs+0s) by IO::Socket::INET::BEGIN@11 at line 18 of IO/Socket/UNIX.pm # once (3µs+0s) by Tapper::MCP::Net::BEGIN@13 at line 22 of IO/Socket/INET.pm
sub register_domain {
55411µs my($p,$d) = @_;
56 $domain2pkg[$d] = $p;
57}
58
59sub configure {
60 my($sock,$arg) = @_;
61 my $domain = delete $arg->{Domain};
62
63 croak 'IO::Socket: Cannot configure a generic socket'
64 unless defined $domain;
65
66 croak "IO::Socket: Unsupported socket domain"
67 unless defined $domain2pkg[$domain];
68
69 croak "IO::Socket: Cannot configure socket in domain '$domain'"
70 unless ref($sock) eq "IO::Socket";
71
72 bless($sock, $domain2pkg[$domain]);
73 $sock->configure($arg);
74}
75
76sub socket {
77 @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
78 my($sock,$domain,$type,$protocol) = @_;
79
80 socket($sock,$domain,$type,$protocol) or
81 return undef;
82
83 ${*$sock}{'io_socket_domain'} = $domain;
84 ${*$sock}{'io_socket_type'} = $type;
85 ${*$sock}{'io_socket_proto'} = $protocol;
86
87 $sock;
88}
89
90sub socketpair {
91 @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
92 my($class,$domain,$type,$protocol) = @_;
93 my $sock1 = $class->new();
94 my $sock2 = $class->new();
95
96 socketpair($sock1,$sock2,$domain,$type,$protocol) or
97 return ();
98
99 ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
100 ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
101
102 ($sock1,$sock2);
103}
104
105sub connect {
106 @_ == 2 or croak 'usage: $sock->connect(NAME)';
107 my $sock = shift;
108 my $addr = shift;
109 my $timeout = ${*$sock}{'io_socket_timeout'};
110 my $err;
111 my $blocking;
112
113 $blocking = $sock->blocking(0) if $timeout;
114 if (!connect($sock, $addr)) {
115 if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
116 require IO::Select;
117
118 my $sel = new IO::Select $sock;
119
120 undef $!;
121 if (!$sel->can_write($timeout)) {
122 $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
123 $@ = "connect: timeout";
124 }
125 elsif (!connect($sock,$addr) &&
126 not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
127 ) {
128 # Some systems refuse to re-connect() to
129 # an already open socket and set errno to EISCONN.
130 # Windows sets errno to WSAEINVAL (10022)
131 $err = $!;
132 $@ = "connect: $!";
133 }
134 }
135 elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
136 $err = $!;
137 $@ = "connect: $!";
138 }
139 }
140
141 $sock->blocking(1) if $blocking;
142
143 $! = $err if $err;
144
145 $err ? undef : $sock;
146}
147
148# Enable/disable blocking IO on sockets.
149# Without args return the current status of blocking,
150# with args change the mode as appropriate, returning the
151# old setting, or in case of error during the mode change
152# undef.
153
154sub blocking {
155 my $sock = shift;
156
157 return $sock->SUPER::blocking(@_)
158 if $^O ne 'MSWin32';
159
160 # Windows handles blocking differently
161 #
162 # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
163 # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
164 #
165 # 0x8004667e is FIONBIO
166 #
167 # which is used to set blocking behaviour.
168
169 # NOTE:
170 # This is a little confusing, the perl keyword for this is
171 # 'blocking' but the OS level behaviour is 'non-blocking', probably
172 # because sockets are blocking by default.
173 # Therefore internally we have to reverse the semantics.
174
175 my $orig= !${*$sock}{io_sock_nonblocking};
176
177 return $orig unless @_;
178
179 my $block = shift;
180
181 if ( !$block != !$orig ) {
182 ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
183 ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
184 or return undef;
185 }
186
187 return $orig;
188}
189
190
191sub close {
192 @_ == 1 or croak 'usage: $sock->close()';
193 my $sock = shift;
194 ${*$sock}{'io_socket_peername'} = undef;
195 $sock->SUPER::close();
196}
197
198sub bind {
199 @_ == 2 or croak 'usage: $sock->bind(NAME)';
200 my $sock = shift;
201 my $addr = shift;
202
203 return bind($sock, $addr) ? $sock
204 : undef;
205}
206
207sub listen {
208 @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
209 my($sock,$queue) = @_;
210 $queue = 5
211 unless $queue && $queue > 0;
212
213 return listen($sock, $queue) ? $sock
214 : undef;
215}
216
217sub accept {
218 @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
219 my $sock = shift;
220 my $pkg = shift || $sock;
221 my $timeout = ${*$sock}{'io_socket_timeout'};
222 my $new = $pkg->new(Timeout => $timeout);
223 my $peer = undef;
224
225 if(defined $timeout) {
226 require IO::Select;
227
228 my $sel = new IO::Select $sock;
229
230 unless ($sel->can_read($timeout)) {
231 $@ = 'accept: timeout';
232 $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
233 return;
234 }
235 }
236
237 $peer = accept($new,$sock)
238 or return;
239
240 return wantarray ? ($new, $peer)
241 : $new;
242}
243
244sub sockname {
245 @_ == 1 or croak 'usage: $sock->sockname()';
246 getsockname($_[0]);
247}
248
249sub peername {
250 @_ == 1 or croak 'usage: $sock->peername()';
251 my($sock) = @_;
252 ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
253}
254
255sub connected {
256 @_ == 1 or croak 'usage: $sock->connected()';
257 my($sock) = @_;
258 getpeername($sock);
259}
260
261sub send {
262 @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
263 my $sock = $_[0];
264 my $flags = $_[2] || 0;
265 my $peer = $_[3] || $sock->peername;
266
267 croak 'send: Cannot determine peer address'
268 unless(defined $peer);
269
270 my $r = defined(getpeername($sock))
271 ? send($sock, $_[1], $flags)
272 : send($sock, $_[1], $flags, $peer);
273
274 # remember who we send to, if it was successful
275 ${*$sock}{'io_socket_peername'} = $peer
276 if(@_ == 4 && defined $r);
277
278 $r;
279}
280
281sub recv {
282 @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
283 my $sock = $_[0];
284 my $len = $_[2];
285 my $flags = $_[3] || 0;
286
287 # remember who we recv'd from
288 ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
289}
290
291sub shutdown {
292 @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
293 my($sock, $how) = @_;
294 ${*$sock}{'io_socket_peername'} = undef;
295 shutdown($sock, $how);
296}
297
298sub setsockopt {
299 @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
300 setsockopt($_[0],$_[1],$_[2],$_[3]);
301}
302
303113µs18µsmy $intsize = length(pack("i",0));
# spent 8µs making 1 call to IO::Socket::CORE:pack
304
305sub getsockopt {
306 @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
307 my $r = getsockopt($_[0],$_[1],$_[2]);
308 # Just a guess
309 $r = unpack("i", $r)
310 if(defined $r && length($r) == $intsize);
311 $r;
312}
313
314sub sockopt {
315 my $sock = shift;
316 @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
317 : $sock->setsockopt(SOL_SOCKET,@_);
318}
319
320sub atmark {
321 @_ == 1 or croak 'usage: $sock->atmark()';
322 my($sock) = @_;
323 sockatmark($sock);
324}
325
326sub timeout {
327 @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
328 my($sock,$val) = @_;
329 my $r = ${*$sock}{'io_socket_timeout'};
330
331 ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
332 if(@_ == 2);
333
334 $r;
335}
336
337sub sockdomain {
338 @_ == 1 or croak 'usage: $sock->sockdomain()';
339 my $sock = shift;
340 ${*$sock}{'io_socket_domain'};
341}
342
343sub socktype {
344 @_ == 1 or croak 'usage: $sock->socktype()';
345 my $sock = shift;
346 ${*$sock}{'io_socket_type'}
347}
348
349sub protocol {
350 @_ == 1 or croak 'usage: $sock->protocol()';
351 my($sock) = @_;
352 ${*$sock}{'io_socket_proto'};
353}
354
35517µs1;
356
357__END__
 
# spent 8µs within IO::Socket::CORE:pack which was called: # once (8µs+0s) by IO::Socket::INET::BEGIN@11 at line 303
sub IO::Socket::CORE:pack; # opcode