← 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.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sIO::Socket::::BEGIN@10IO::Socket::BEGIN@10
0000s0sIO::Socket::::BEGIN@12IO::Socket::BEGIN@12
0000s0sIO::Socket::::BEGIN@13IO::Socket::BEGIN@13
0000s0sIO::Socket::::BEGIN@14IO::Socket::BEGIN@14
0000s0sIO::Socket::::BEGIN@15IO::Socket::BEGIN@15
0000s0sIO::Socket::::BEGIN@16IO::Socket::BEGIN@16
0000s0sIO::Socket::::BEGIN@17IO::Socket::BEGIN@17
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::::importIO::Socket::import
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::::register_domainIO::Socket::register_domain
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
2# IO::Socket.pm
3#
4# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
5# This program is free software; you can redistribute it and/or
6# modify it under the same terms as Perl itself.
7
8package IO::Socket;
9
10use 5.008_001;
11
12use IO::Handle;
13use Socket 1.3;
14use Carp;
15use strict;
16use Exporter;
17use Errno;
18
19# legacy
20
21require IO::Socket::INET;
22require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
23
24our @ISA = qw(IO::Handle);
25
26our $VERSION = "1.43";
27
28our @EXPORT_OK = qw(sockatmark);
29
30sub import {
31 my $pkg = shift;
32 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;
36 Exporter::export 'Socket', $callpkg, @_;
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
52my @domain2pkg;
53
54sub register_domain {
55 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
86 # "A value of 0 for protocol will let the system select an
87 # appropriate protocol"
88 # so we need to look up what the system selected,
89 # not cache PF_UNSPEC.
90 ${*$sock}{'io_socket_proto'} = $protocol if $protocol;
91
92 $sock;
93}
94
95sub socketpair {
96 @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
97 my($class,$domain,$type,$protocol) = @_;
98 my $sock1 = $class->new();
99 my $sock2 = $class->new();
100
101 socketpair($sock1,$sock2,$domain,$type,$protocol) or
102 return ();
103
104 ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
105 ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
106
107 ($sock1,$sock2);
108}
109
110sub connect {
111 @_ == 2 or croak 'usage: $sock->connect(NAME)';
112 my $sock = shift;
113 my $addr = shift;
114 my $timeout = ${*$sock}{'io_socket_timeout'};
115 my $err;
116 my $blocking;
117
118 $blocking = $sock->blocking(0) if $timeout;
119 if (!connect($sock, $addr)) {
120 if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
121 require IO::Select;
122
123 my $sel = new IO::Select $sock;
124
125 undef $!;
126 my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
127 if(@$e[0]) {
128 # Windows return from select after the timeout in case of
129 # WSAECONNREFUSED(10061) if exception set is not used.
130 # This behavior is different from Linux.
131 # Using the exception
132 # set we now emulate the behavior in Linux
133 # - Karthik Rajagopalan
134 $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
135 $@ = "connect: $err";
136 }
137 elsif(!@$w[0]) {
138 $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
139 $@ = "connect: timeout";
140 }
141 elsif (!connect($sock,$addr) &&
142 not ($!{EISCONN} || ($^O eq 'MSWin32' &&
143 ($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
144 ) {
145 # Some systems refuse to re-connect() to
146 # an already open socket and set errno to EISCONN.
147 # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
148 # EINVAL (22) (5.19.4 onwards).
149 $err = $!;
150 $@ = "connect: $!";
151 }
152 }
153 elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
154 $err = $!;
155 $@ = "connect: $!";
156 }
157 }
158
159 $sock->blocking(1) if $blocking;
160
161 $! = $err if $err;
162
163 $err ? undef : $sock;
164}
165
166# Enable/disable blocking IO on sockets.
167# Without args return the current status of blocking,
168# with args change the mode as appropriate, returning the
169# old setting, or in case of error during the mode change
170# undef.
171
172sub blocking {
173 my $sock = shift;
174
175 return $sock->SUPER::blocking(@_)
176 if $^O ne 'MSWin32' && $^O ne 'VMS';
177
178 # Windows handles blocking differently
179 #
180 # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
181 # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
182 #
183 # 0x8004667e is FIONBIO
184 #
185 # which is used to set blocking behaviour.
186
187 # NOTE:
188 # This is a little confusing, the perl keyword for this is
189 # 'blocking' but the OS level behaviour is 'non-blocking', probably
190 # because sockets are blocking by default.
191 # Therefore internally we have to reverse the semantics.
192
193 my $orig= !${*$sock}{io_sock_nonblocking};
194
195 return $orig unless @_;
196
197 my $block = shift;
198
199 if ( !$block != !$orig ) {
200 ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
201 ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
202 or return undef;
203 }
204
205 return $orig;
206}
207
208
209sub close {
210 @_ == 1 or croak 'usage: $sock->close()';
211 my $sock = shift;
212 ${*$sock}{'io_socket_peername'} = undef;
213 $sock->SUPER::close();
214}
215
216sub bind {
217 @_ == 2 or croak 'usage: $sock->bind(NAME)';
218 my $sock = shift;
219 my $addr = shift;
220
221 return bind($sock, $addr) ? $sock
222 : undef;
223}
224
225sub listen {
226 @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
227 my($sock,$queue) = @_;
228 $queue = 5
229 unless $queue && $queue > 0;
230
231 return listen($sock, $queue) ? $sock
232 : undef;
233}
234
235sub accept {
236 @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
237 my $sock = shift;
238 my $pkg = shift || $sock;
239 my $timeout = ${*$sock}{'io_socket_timeout'};
240 my $new = $pkg->new(Timeout => $timeout);
241 my $peer = undef;
242
243 if(defined $timeout) {
244 require IO::Select;
245
246 my $sel = new IO::Select $sock;
247
248 unless ($sel->can_read($timeout)) {
249 $@ = 'accept: timeout';
250 $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
251 return;
252 }
253 }
254
255 $peer = accept($new,$sock)
256 or return;
257
258 ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
259
260 return wantarray ? ($new, $peer)
261 : $new;
262}
263
264sub sockname {
265 @_ == 1 or croak 'usage: $sock->sockname()';
266 getsockname($_[0]);
267}
268
269sub peername {
270 @_ == 1 or croak 'usage: $sock->peername()';
271 my($sock) = @_;
272 ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
273}
274
275sub connected {
276 @_ == 1 or croak 'usage: $sock->connected()';
277 my($sock) = @_;
278 getpeername($sock);
279}
280
281sub send {
282 @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
283 my $sock = $_[0];
284 my $flags = $_[2] || 0;
285 my $peer;
286
287 if ($_[3]) {
288 # the caller explicitly requested a TO, so use it
289 # this is non-portable for "connected" UDP sockets
290 $peer = $_[3];
291 }
292 elsif (!defined getpeername($sock)) {
293 # we're not connected, so we require a peer from somewhere
294 $peer = $sock->peername;
295
296 croak 'send: Cannot determine peer address'
297 unless(defined $peer);
298 }
299
300 my $r = $peer
301 ? send($sock, $_[1], $flags, $peer)
302 : send($sock, $_[1], $flags);
303
304 # remember who we send to, if it was successful
305 ${*$sock}{'io_socket_peername'} = $peer
306 if(@_ == 4 && defined $r);
307
308 $r;
309}
310
311sub recv {
312 @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
313 my $sock = $_[0];
314 my $len = $_[2];
315 my $flags = $_[3] || 0;
316
317 # remember who we recv'd from
318 ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
319}
320
321sub shutdown {
322 @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
323 my($sock, $how) = @_;
324 ${*$sock}{'io_socket_peername'} = undef;
325 shutdown($sock, $how);
326}
327
328sub setsockopt {
329 @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
330 setsockopt($_[0],$_[1],$_[2],$_[3]);
331}
332
333my $intsize = length(pack("i",0));
334
335sub getsockopt {
336 @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
337 my $r = getsockopt($_[0],$_[1],$_[2]);
338 # Just a guess
339 $r = unpack("i", $r)
340 if(defined $r && length($r) == $intsize);
341 $r;
342}
343
344sub sockopt {
345 my $sock = shift;
346 @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
347 : $sock->setsockopt(SOL_SOCKET,@_);
348}
349
350sub atmark {
351 @_ == 1 or croak 'usage: $sock->atmark()';
352 my($sock) = @_;
353 sockatmark($sock);
354}
355
356sub timeout {
357 @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
358 my($sock,$val) = @_;
359 my $r = ${*$sock}{'io_socket_timeout'};
360
361 ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
362 if(@_ == 2);
363
364 $r;
365}
366
367sub sockdomain {
368 @_ == 1 or croak 'usage: $sock->sockdomain()';
369 my $sock = shift;
370 if (!defined(${*$sock}{'io_socket_domain'})) {
371 my $addr = $sock->sockname();
372 ${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
373 if (defined($addr));
374 }
375 ${*$sock}{'io_socket_domain'};
376}
377
378sub socktype {
379 @_ == 1 or croak 'usage: $sock->socktype()';
380 my $sock = shift;
381 ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
382 if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
383 ${*$sock}{'io_socket_type'}
384}
385
386sub protocol {
387 @_ == 1 or croak 'usage: $sock->protocol()';
388 my($sock) = @_;
389 ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
390 if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
391 ${*$sock}{'io_socket_proto'};
392}
393
3941;
395
396__END__