← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:07 2013

Filename/usr/lib/perl/5.10/IO/Socket.pm
StatementsExecuted 44 statements in 4.50ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1113.02ms3.24msIO::Socket::::BEGIN@17IO::Socket::BEGIN@17
33367µs4.71msIO::Socket::::importIO::Socket::import
11161µs1.66msIO::Socket::::BEGIN@12IO::Socket::BEGIN@12
11142µs85µsIO::Socket::::BEGIN@11IO::Socket::BEGIN@11
11129µs67µsIO::Socket::::BEGIN@16IO::Socket::BEGIN@16
11127µs136µsIO::Socket::::BEGIN@13IO::Socket::BEGIN@13
11122µs30µsIO::Socket::::BEGIN@14IO::Socket::BEGIN@14
22210µs10µsIO::Socket::::register_domainIO::Socket::register_domain
1117µs7µsIO::Socket::::CORE:packIO::Socket::CORE:pack (opcode)
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
9144µsrequire 5.006;
10
11368µs2128µ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
123127µs33.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
13363µs2246µ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
14398µs238µ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
1512µsour(@ISA, $VERSION, @EXPORT_OK);
16356µs2105µ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
1733.59ms23.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
211191µsrequire IO::Socket::INET;
221130µsrequire IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
23
24120µs@ISA = qw(IO::Handle);
25
2612µs$VERSION = "1.31";
27
2813µ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 {
311248µs 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;
363136µs Exporter::export 'Socket', $callpkg, @_;
# spent 136µs making 3 calls to Exporter::export, avg 45µ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
521900nsmy @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 {
55420µ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
190sub close {
191 @_ == 1 or croak 'usage: $sock->close()';
192 my $sock = shift;
193 ${*$sock}{'io_socket_peername'} = undef;
194 $sock->SUPER::close();
195}
196
197sub 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
206sub 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
216sub 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
243sub sockname {
244 @_ == 1 or croak 'usage: $sock->sockname()';
245 getsockname($_[0]);
246}
247
248sub peername {
249 @_ == 1 or croak 'usage: $sock->peername()';
250 my($sock) = @_;
251 ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
252}
253
254sub connected {
255 @_ == 1 or croak 'usage: $sock->connected()';
256 my($sock) = @_;
257 getpeername($sock);
258}
259
260sub 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
280sub 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
290sub 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
297sub setsockopt {
298 @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
299 setsockopt($_[0],$_[1],$_[2],$_[3]);
300}
301
302121µs17µsmy $intsize = length(pack("i",0));
# spent 7µs making 1 call to IO::Socket::CORE:pack
303
304sub 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
313sub sockopt {
314 my $sock = shift;
315 @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
316 : $sock->setsockopt(SOL_SOCKET,@_);
317}
318
319sub atmark {
320 @_ == 1 or croak 'usage: $sock->atmark()';
321 my($sock) = @_;
322 sockatmark($sock);
323}
324
325sub 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
336sub sockdomain {
337 @_ == 1 or croak 'usage: $sock->sockdomain()';
338 my $sock = shift;
339 ${*$sock}{'io_socket_domain'};
340}
341
342sub socktype {
343 @_ == 1 or croak 'usage: $sock->socktype()';
344 my $sock = shift;
345 ${*$sock}{'io_socket_type'}
346}
347
348sub protocol {
349 @_ == 1 or croak 'usage: $sock->protocol()';
350 my($sock) = @_;
351 ${*$sock}{'io_socket_proto'};
352}
353
354120µs1;
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
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.