Profile of IO/Socket.pm

Filename	/usr/lib/perl/5.10/IO/Socket.pm
Statements	Executed 44 statements in 4.50ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	3.02ms	3.24ms	IO::Socket::::BEGIN@17IO::Socket::BEGIN@17
3	3	3	67µs	4.71ms	IO::Socket::::importIO::Socket::import
1	1	1	61µs	1.66ms	IO::Socket::::BEGIN@12IO::Socket::BEGIN@12
1	1	1	42µs	85µs	IO::Socket::::BEGIN@11IO::Socket::BEGIN@11
1	1	1	29µs	67µs	IO::Socket::::BEGIN@16IO::Socket::BEGIN@16
1	1	1	27µs	136µs	IO::Socket::::BEGIN@13IO::Socket::BEGIN@13
1	1	1	22µs	30µs	IO::Socket::::BEGIN@14IO::Socket::BEGIN@14
2	2	2	10µs	10µs	IO::Socket::::register_domainIO::Socket::register_domain
1	1	1	7µs	7µs	IO::Socket::::CORE:packIO::Socket::CORE:pack (opcode)
0	0	0	0s	0s	IO::Socket::::acceptIO::Socket::accept
0	0	0	0s	0s	IO::Socket::::atmarkIO::Socket::atmark
0	0	0	0s	0s	IO::Socket::::bindIO::Socket::bind
0	0	0	0s	0s	IO::Socket::::blockingIO::Socket::blocking
0	0	0	0s	0s	IO::Socket::::closeIO::Socket::close
0	0	0	0s	0s	IO::Socket::::configureIO::Socket::configure
0	0	0	0s	0s	IO::Socket::::connectIO::Socket::connect
0	0	0	0s	0s	IO::Socket::::connectedIO::Socket::connected
0	0	0	0s	0s	IO::Socket::::getsockoptIO::Socket::getsockopt
0	0	0	0s	0s	IO::Socket::::listenIO::Socket::listen
0	0	0	0s	0s	IO::Socket::::newIO::Socket::new
0	0	0	0s	0s	IO::Socket::::peernameIO::Socket::peername
0	0	0	0s	0s	IO::Socket::::protocolIO::Socket::protocol
0	0	0	0s	0s	IO::Socket::::recvIO::Socket::recv
0	0	0	0s	0s	IO::Socket::::sendIO::Socket::send
0	0	0	0s	0s	IO::Socket::::setsockoptIO::Socket::setsockopt
0	0	0	0s	0s	IO::Socket::::shutdownIO::Socket::shutdown
0	0	0	0s	0s	IO::Socket::::sockdomainIO::Socket::sockdomain
0	0	0	0s	0s	IO::Socket::::socketIO::Socket::socket
0	0	0	0s	0s	IO::Socket::::socketpairIO::Socket::socketpair
0	0	0	0s	0s	IO::Socket::::socknameIO::Socket::sockname
0	0	0	0s	0s	IO::Socket::::sockoptIO::Socket::sockopt
0	0	0	0s	0s	IO::Socket::::socktypeIO::Socket::socktype
0	0	0	0s	0s	IO::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
7					package IO::Socket;
8
9	1	44µs			require 5.006;
10
11	3	68µs	2	128µs	# spent 85µs (42+43) within IO::Socket::BEGIN@11 which was called: # once (42µs+43µs) by Net::LDAP::BEGIN@8 at line 11 use IO::Handle; # spent 85µs making 1 call to IO::Socket::BEGIN@11 # spent 43µs making 1 call to Exporter::import
12	3	127µs	3	3.26ms	# spent 1.66ms (61µs+1.60) within IO::Socket::BEGIN@12 which was called: # once (61µs+1.60ms) by Net::LDAP::BEGIN@8 at line 12 use Socket 1.3; # spent 1.66ms making 1 call to IO::Socket::BEGIN@12 # spent 1.57ms making 1 call to Exporter::import # spent 33µs making 1 call to UNIVERSAL::VERSION
13	3	63µs	2	246µs	# spent 136µs (27+109) within IO::Socket::BEGIN@13 which was called: # once (27µs+109µs) by Net::LDAP::BEGIN@8 at line 13 use Carp; # spent 136µs making 1 call to IO::Socket::BEGIN@13 # spent 109µs making 1 call to Exporter::import
14	3	98µs	2	38µs	# spent 30µs (22+8) within IO::Socket::BEGIN@14 which was called: # once (22µs+8µs) by Net::LDAP::BEGIN@8 at line 14 use strict; # spent 30µs making 1 call to IO::Socket::BEGIN@14 # spent 8µs making 1 call to strict::import
15	1	2µs			our(@ISA, $VERSION, @EXPORT_OK);
16	3	56µs	2	105µs	# spent 67µs (29+38) within IO::Socket::BEGIN@16 which was called: # once (29µs+38µs) by Net::LDAP::BEGIN@8 at line 16 use Exporter; # spent 67µs making 1 call to IO::Socket::BEGIN@16 # spent 38µs making 1 call to Exporter::import
17	3	3.59ms	2	3.30ms	# spent 3.24ms (3.02+225µs) within IO::Socket::BEGIN@17 which was called: # once (3.02ms+225µs) by Net::LDAP::BEGIN@8 at line 17 use Errno; # spent 3.24ms making 1 call to IO::Socket::BEGIN@17 # spent 55µs making 1 call to Exporter::import
18
19					# legacy
20
21	1	191µs			require IO::Socket::INET;
22	1	130µs			require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
23
24	1	20µs			@ISA = qw(IO::Handle);
25
26	1	2µs			$VERSION = "1.31";
27
28	1	3µs			@EXPORT_OK = qw(sockatmark);
29
30					# spent 4.71ms (67µs+4.65) within IO::Socket::import which was called 3 times, avg 1.57ms/call: # once (31µs+1.95ms) by IO::Socket::INET::BEGIN@11 at line 11 of IO/Socket/INET.pm # once (21µs+1.63ms) by Net::LDAP::BEGIN@8 at line 8 of Net/LDAP.pm # once (16µs+1.06ms) by IO::Socket::UNIX::BEGIN@11 at line 11 of IO/Socket/UNIX.pm sub import {
31	3	5µs			my $pkg = shift;
32	3	24µ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	3	6µs			my $callpkg = caller;
36	3	14µs	3	136µs	Exporter::export 'Socket', $callpkg, @_; # spent 136µs making 3 calls to Exporter::export, avg 45µs/call
37					}
38					}
39
40					sub 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
52	1	900ns			my @domain2pkg;
53
54					# spent 10µs within IO::Socket::register_domain which was called 2 times, avg 5µs/call: # once (6µs+0s) by Net::LDAP::BEGIN@8 at line 22 of IO/Socket/INET.pm # once (4µs+0s) by Net::LDAP::BEGIN@8 at line 18 of IO/Socket/UNIX.pm sub register_domain {
55	2	3µs			my($p,$d) = @_;
56	2	17µs			$domain2pkg[$d] = $p;
57					}
58
59					sub 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
76					sub 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
90					sub 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
105					sub 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
154					sub 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					sub close {
191					@_ == 1 or croak 'usage: $sock->close()';
192					my $sock = shift;
193					${*$sock}{'io_socket_peername'} = undef;
194					$sock->SUPER::close();
195					}
196
197					sub bind {
198					@_ == 2 or croak 'usage: $sock->bind(NAME)';
199					my $sock = shift;
200					my $addr = shift;
201
202					return bind($sock, $addr) ? $sock
203					: undef;
204					}
205
206					sub listen {
207					@_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
208					my($sock,$queue) = @_;
209					$queue = 5
210					unless $queue && $queue > 0;
211
212					return listen($sock, $queue) ? $sock
213					: undef;
214					}
215
216					sub accept {
217					@_ == 1 \|\| @_ == 2 or croak 'usage $sock->accept([PKG])';
218					my $sock = shift;
219					my $pkg = shift \|\| $sock;
220					my $timeout = ${*$sock}{'io_socket_timeout'};
221					my $new = $pkg->new(Timeout => $timeout);
222					my $peer = undef;
223
224					if(defined $timeout) {
225					require IO::Select;
226
227					my $sel = new IO::Select $sock;
228
229					unless ($sel->can_read($timeout)) {
230					$@ = 'accept: timeout';
231					$! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
232					return;
233					}
234					}
235
236					$peer = accept($new,$sock)
237					or return;
238
239					return wantarray ? ($new, $peer)
240					: $new;
241					}
242
243					sub sockname {
244					@_ == 1 or croak 'usage: $sock->sockname()';
245					getsockname($_[0]);
246					}
247
248					sub peername {
249					@_ == 1 or croak 'usage: $sock->peername()';
250					my($sock) = @_;
251					${*$sock}{'io_socket_peername'} \|\|= getpeername($sock);
252					}
253
254					sub connected {
255					@_ == 1 or croak 'usage: $sock->connected()';
256					my($sock) = @_;
257					getpeername($sock);
258					}
259
260					sub send {
261					@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
262					my $sock = $_[0];
263					my $flags = $_[2] \|\| 0;
264					my $peer = $_[3] \|\| $sock->peername;
265
266					croak 'send: Cannot determine peer address'
267					unless(defined $peer);
268
269					my $r = defined(getpeername($sock))
270					? send($sock, $_[1], $flags)
271					: send($sock, $_[1], $flags, $peer);
272
273					# remember who we send to, if it was successful
274					${*$sock}{'io_socket_peername'} = $peer
275					if(@_ == 4 && defined $r);
276
277					$r;
278					}
279
280					sub recv {
281					@_ == 3 \|\| @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
282					my $sock = $_[0];
283					my $len = $_[2];
284					my $flags = $_[3] \|\| 0;
285
286					# remember who we recv'd from
287					${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
288					}
289
290					sub shutdown {
291					@_ == 2 or croak 'usage: $sock->shutdown(HOW)';
292					my($sock, $how) = @_;
293					${*$sock}{'io_socket_peername'} = undef;
294					shutdown($sock, $how);
295					}
296
297					sub setsockopt {
298					@_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
299					setsockopt($_[0],$_[1],$_[2],$_[3]);
300					}
301
302	1	21µs	1	7µs	my $intsize = length(pack("i",0)); # spent 7µs making 1 call to IO::Socket::CORE:pack
303
304					sub getsockopt {
305					@_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
306					my $r = getsockopt($_[0],$_[1],$_[2]);
307					# Just a guess
308					$r = unpack("i", $r)
309					if(defined $r && length($r) == $intsize);
310					$r;
311					}
312
313					sub sockopt {
314					my $sock = shift;
315					@_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
316					: $sock->setsockopt(SOL_SOCKET,@_);
317					}
318
319					sub atmark {
320					@_ == 1 or croak 'usage: $sock->atmark()';
321					my($sock) = @_;
322					sockatmark($sock);
323					}
324
325					sub timeout {
326					@_ == 1 \|\| @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
327					my($sock,$val) = @_;
328					my $r = ${*$sock}{'io_socket_timeout'};
329
330					${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
331					if(@_ == 2);
332
333					$r;
334					}
335
336					sub sockdomain {
337					@_ == 1 or croak 'usage: $sock->sockdomain()';
338					my $sock = shift;
339					${*$sock}{'io_socket_domain'};
340					}
341
342					sub socktype {
343					@_ == 1 or croak 'usage: $sock->socktype()';
344					my $sock = shift;
345					${*$sock}{'io_socket_type'}
346					}
347
348					sub protocol {
349					@_ == 1 or croak 'usage: $sock->protocol()';
350					my($sock) = @_;
351					${*$sock}{'io_socket_proto'};
352					}
353
354	1	20µs			1;
355
356					__END__

					# spent 7µs within IO::Socket::CORE:pack which was called: # once (7µs+0s) by Net::LDAP::BEGIN@8 at line 302 sub IO::Socket::CORE:pack; # opcode