1 | # IO::Socket.pm
|
---|
2 | #
|
---|
3 | # Copyright (c) 1997-8 Graham Barr <[email protected]>. 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 | require 5.006;
|
---|
10 |
|
---|
11 | use IO::Handle;
|
---|
12 | use Socket 1.3;
|
---|
13 | use Carp;
|
---|
14 | use strict;
|
---|
15 | our(@ISA, $VERSION, @EXPORT_OK);
|
---|
16 | use Exporter;
|
---|
17 | use Errno;
|
---|
18 |
|
---|
19 | # legacy
|
---|
20 |
|
---|
21 | require IO::Socket::INET;
|
---|
22 | require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
|
---|
23 |
|
---|
24 | @ISA = qw(IO::Handle);
|
---|
25 |
|
---|
26 | $VERSION = "1.29";
|
---|
27 |
|
---|
28 | @EXPORT_OK = qw(sockatmark);
|
---|
29 |
|
---|
30 | sub 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 |
|
---|
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 | my @domain2pkg;
|
---|
53 |
|
---|
54 | sub register_domain {
|
---|
55 | my($p,$d) = @_;
|
---|
56 | $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}) {
|
---|
116 | require IO::Select;
|
---|
117 |
|
---|
118 | my $sel = new IO::Select $sock;
|
---|
119 |
|
---|
120 | if (!$sel->can_write($timeout)) {
|
---|
121 | $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
|
---|
122 | $@ = "connect: timeout";
|
---|
123 | }
|
---|
124 | elsif (!connect($sock,$addr) && not $!{EISCONN}) {
|
---|
125 | # Some systems refuse to re-connect() to
|
---|
126 | # an already open socket and set errno to EISCONN.
|
---|
127 | $err = $!;
|
---|
128 | $@ = "connect: $!";
|
---|
129 | }
|
---|
130 | }
|
---|
131 | elsif ($blocking || !$!{EINPROGRESS}) {
|
---|
132 | $err = $!;
|
---|
133 | $@ = "connect: $!";
|
---|
134 | }
|
---|
135 | }
|
---|
136 |
|
---|
137 | $sock->blocking(1) if $blocking;
|
---|
138 |
|
---|
139 | $! = $err if $err;
|
---|
140 |
|
---|
141 | $err ? undef : $sock;
|
---|
142 | }
|
---|
143 |
|
---|
144 | sub bind {
|
---|
145 | @_ == 2 or croak 'usage: $sock->bind(NAME)';
|
---|
146 | my $sock = shift;
|
---|
147 | my $addr = shift;
|
---|
148 |
|
---|
149 | return bind($sock, $addr) ? $sock
|
---|
150 | : undef;
|
---|
151 | }
|
---|
152 |
|
---|
153 | sub listen {
|
---|
154 | @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
|
---|
155 | my($sock,$queue) = @_;
|
---|
156 | $queue = 5
|
---|
157 | unless $queue && $queue > 0;
|
---|
158 |
|
---|
159 | return listen($sock, $queue) ? $sock
|
---|
160 | : undef;
|
---|
161 | }
|
---|
162 |
|
---|
163 | sub accept {
|
---|
164 | @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
|
---|
165 | my $sock = shift;
|
---|
166 | my $pkg = shift || $sock;
|
---|
167 | my $timeout = ${*$sock}{'io_socket_timeout'};
|
---|
168 | my $new = $pkg->new(Timeout => $timeout);
|
---|
169 | my $peer = undef;
|
---|
170 |
|
---|
171 | if(defined $timeout) {
|
---|
172 | require IO::Select;
|
---|
173 |
|
---|
174 | my $sel = new IO::Select $sock;
|
---|
175 |
|
---|
176 | unless ($sel->can_read($timeout)) {
|
---|
177 | $@ = 'accept: timeout';
|
---|
178 | $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
|
---|
179 | return;
|
---|
180 | }
|
---|
181 | }
|
---|
182 |
|
---|
183 | $peer = accept($new,$sock)
|
---|
184 | or return;
|
---|
185 |
|
---|
186 | return wantarray ? ($new, $peer)
|
---|
187 | : $new;
|
---|
188 | }
|
---|
189 |
|
---|
190 | sub sockname {
|
---|
191 | @_ == 1 or croak 'usage: $sock->sockname()';
|
---|
192 | getsockname($_[0]);
|
---|
193 | }
|
---|
194 |
|
---|
195 | sub peername {
|
---|
196 | @_ == 1 or croak 'usage: $sock->peername()';
|
---|
197 | my($sock) = @_;
|
---|
198 | getpeername($sock)
|
---|
199 | || ${*$sock}{'io_socket_peername'}
|
---|
200 | || undef;
|
---|
201 | }
|
---|
202 |
|
---|
203 | sub connected {
|
---|
204 | @_ == 1 or croak 'usage: $sock->connected()';
|
---|
205 | my($sock) = @_;
|
---|
206 | getpeername($sock);
|
---|
207 | }
|
---|
208 |
|
---|
209 | sub send {
|
---|
210 | @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
|
---|
211 | my $sock = $_[0];
|
---|
212 | my $flags = $_[2] || 0;
|
---|
213 | my $peer = $_[3] || $sock->peername;
|
---|
214 |
|
---|
215 | croak 'send: Cannot determine peer address'
|
---|
216 | unless($peer);
|
---|
217 |
|
---|
218 | my $r = defined(getpeername($sock))
|
---|
219 | ? send($sock, $_[1], $flags)
|
---|
220 | : send($sock, $_[1], $flags, $peer);
|
---|
221 |
|
---|
222 | # remember who we send to, if it was successful
|
---|
223 | ${*$sock}{'io_socket_peername'} = $peer
|
---|
224 | if(@_ == 4 && defined $r);
|
---|
225 |
|
---|
226 | $r;
|
---|
227 | }
|
---|
228 |
|
---|
229 | sub recv {
|
---|
230 | @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
|
---|
231 | my $sock = $_[0];
|
---|
232 | my $len = $_[2];
|
---|
233 | my $flags = $_[3] || 0;
|
---|
234 |
|
---|
235 | # remember who we recv'd from
|
---|
236 | ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
|
---|
237 | }
|
---|
238 |
|
---|
239 | sub shutdown {
|
---|
240 | @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
|
---|
241 | my($sock, $how) = @_;
|
---|
242 | shutdown($sock, $how);
|
---|
243 | }
|
---|
244 |
|
---|
245 | sub setsockopt {
|
---|
246 | @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
|
---|
247 | setsockopt($_[0],$_[1],$_[2],$_[3]);
|
---|
248 | }
|
---|
249 |
|
---|
250 | my $intsize = length(pack("i",0));
|
---|
251 |
|
---|
252 | sub getsockopt {
|
---|
253 | @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
|
---|
254 | my $r = getsockopt($_[0],$_[1],$_[2]);
|
---|
255 | # Just a guess
|
---|
256 | $r = unpack("i", $r)
|
---|
257 | if(defined $r && length($r) == $intsize);
|
---|
258 | $r;
|
---|
259 | }
|
---|
260 |
|
---|
261 | sub sockopt {
|
---|
262 | my $sock = shift;
|
---|
263 | @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
|
---|
264 | : $sock->setsockopt(SOL_SOCKET,@_);
|
---|
265 | }
|
---|
266 |
|
---|
267 | sub atmark {
|
---|
268 | @_ == 1 or croak 'usage: $sock->atmark()';
|
---|
269 | my($sock) = @_;
|
---|
270 | sockatmark($sock);
|
---|
271 | }
|
---|
272 |
|
---|
273 | sub timeout {
|
---|
274 | @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
|
---|
275 | my($sock,$val) = @_;
|
---|
276 | my $r = ${*$sock}{'io_socket_timeout'};
|
---|
277 |
|
---|
278 | ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
|
---|
279 | if(@_ == 2);
|
---|
280 |
|
---|
281 | $r;
|
---|
282 | }
|
---|
283 |
|
---|
284 | sub sockdomain {
|
---|
285 | @_ == 1 or croak 'usage: $sock->sockdomain()';
|
---|
286 | my $sock = shift;
|
---|
287 | ${*$sock}{'io_socket_domain'};
|
---|
288 | }
|
---|
289 |
|
---|
290 | sub socktype {
|
---|
291 | @_ == 1 or croak 'usage: $sock->socktype()';
|
---|
292 | my $sock = shift;
|
---|
293 | ${*$sock}{'io_socket_type'}
|
---|
294 | }
|
---|
295 |
|
---|
296 | sub protocol {
|
---|
297 | @_ == 1 or croak 'usage: $sock->protocol()';
|
---|
298 | my($sock) = @_;
|
---|
299 | ${*$sock}{'io_socket_proto'};
|
---|
300 | }
|
---|
301 |
|
---|
302 | 1;
|
---|
303 |
|
---|
304 | __END__
|
---|
305 |
|
---|
306 | =head1 NAME
|
---|
307 |
|
---|
308 | IO::Socket - Object interface to socket communications
|
---|
309 |
|
---|
310 | =head1 SYNOPSIS
|
---|
311 |
|
---|
312 | use IO::Socket;
|
---|
313 |
|
---|
314 | =head1 DESCRIPTION
|
---|
315 |
|
---|
316 | C<IO::Socket> provides an object interface to creating and using sockets. It
|
---|
317 | is built upon the L<IO::Handle> interface and inherits all the methods defined
|
---|
318 | by L<IO::Handle>.
|
---|
319 |
|
---|
320 | C<IO::Socket> only defines methods for those operations which are common to all
|
---|
321 | types of socket. Operations which are specified to a socket in a particular
|
---|
322 | domain have methods defined in sub classes of C<IO::Socket>
|
---|
323 |
|
---|
324 | C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
|
---|
325 |
|
---|
326 | =head1 CONSTRUCTOR
|
---|
327 |
|
---|
328 | =over 4
|
---|
329 |
|
---|
330 | =item new ( [ARGS] )
|
---|
331 |
|
---|
332 | Creates an C<IO::Socket>, which is a reference to a
|
---|
333 | newly created symbol (see the C<Symbol> package). C<new>
|
---|
334 | optionally takes arguments, these arguments are in key-value pairs.
|
---|
335 | C<new> only looks for one key C<Domain> which tells new which domain
|
---|
336 | the socket will be in. All other arguments will be passed to the
|
---|
337 | configuration method of the package for that domain, See below.
|
---|
338 |
|
---|
339 | NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
|
---|
340 |
|
---|
341 | As of VERSION 1.18 all IO::Socket objects have autoflush turned on
|
---|
342 | by default. This was not the case with earlier releases.
|
---|
343 |
|
---|
344 | NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
|
---|
345 |
|
---|
346 | =back
|
---|
347 |
|
---|
348 | =head1 METHODS
|
---|
349 |
|
---|
350 | See L<perlfunc> for complete descriptions of each of the following
|
---|
351 | supported C<IO::Socket> methods, which are just front ends for the
|
---|
352 | corresponding built-in functions:
|
---|
353 |
|
---|
354 | socket
|
---|
355 | socketpair
|
---|
356 | bind
|
---|
357 | listen
|
---|
358 | accept
|
---|
359 | send
|
---|
360 | recv
|
---|
361 | peername (getpeername)
|
---|
362 | sockname (getsockname)
|
---|
363 | shutdown
|
---|
364 |
|
---|
365 | Some methods take slightly different arguments to those defined in L<perlfunc>
|
---|
366 | in attempt to make the interface more flexible. These are
|
---|
367 |
|
---|
368 | =over 4
|
---|
369 |
|
---|
370 | =item accept([PKG])
|
---|
371 |
|
---|
372 | perform the system call C<accept> on the socket and return a new
|
---|
373 | object. The new object will be created in the same class as the listen
|
---|
374 | socket, unless C<PKG> is specified. This object can be used to
|
---|
375 | communicate with the client that was trying to connect.
|
---|
376 |
|
---|
377 | In a scalar context the new socket is returned, or undef upon
|
---|
378 | failure. In a list context a two-element array is returned containing
|
---|
379 | the new socket and the peer address; the list will be empty upon
|
---|
380 | failure.
|
---|
381 |
|
---|
382 | The timeout in the [PKG] can be specified as zero to effect a "poll",
|
---|
383 | but you shouldn't do that because a new IO::Select object will be
|
---|
384 | created behind the scenes just to do the single poll. This is
|
---|
385 | horrendously inefficient. Use rather true select() with a zero
|
---|
386 | timeout on the handle, or non-blocking IO.
|
---|
387 |
|
---|
388 | =item socketpair(DOMAIN, TYPE, PROTOCOL)
|
---|
389 |
|
---|
390 | Call C<socketpair> and return a list of two sockets created, or an
|
---|
391 | empty list on failure.
|
---|
392 |
|
---|
393 | =back
|
---|
394 |
|
---|
395 | Additional methods that are provided are:
|
---|
396 |
|
---|
397 | =over 4
|
---|
398 |
|
---|
399 | =item atmark
|
---|
400 |
|
---|
401 | True if the socket is currently positioned at the urgent data mark,
|
---|
402 | false otherwise.
|
---|
403 |
|
---|
404 | use IO::Socket;
|
---|
405 |
|
---|
406 | my $sock = IO::Socket::INET->new('some_server');
|
---|
407 | $sock->read($data, 1024) until $sock->atmark;
|
---|
408 |
|
---|
409 | Note: this is a reasonably new addition to the family of socket
|
---|
410 | functions, so all systems may not support this yet. If it is
|
---|
411 | unsupported by the system, an attempt to use this method will
|
---|
412 | abort the program.
|
---|
413 |
|
---|
414 | The atmark() functionality is also exportable as sockatmark() function:
|
---|
415 |
|
---|
416 | use IO::Socket 'sockatmark';
|
---|
417 |
|
---|
418 | This allows for a more traditional use of sockatmark() as a procedural
|
---|
419 | socket function. If your system does not support sockatmark(), the
|
---|
420 | C<use> declaration will fail at compile time.
|
---|
421 |
|
---|
422 | =item connected
|
---|
423 |
|
---|
424 | If the socket is in a connected state the peer address is returned.
|
---|
425 | If the socket is not in a connected state then undef will be returned.
|
---|
426 |
|
---|
427 | =item protocol
|
---|
428 |
|
---|
429 | Returns the numerical number for the protocol being used on the socket, if
|
---|
430 | known. If the protocol is unknown, as with an AF_UNIX socket, zero
|
---|
431 | is returned.
|
---|
432 |
|
---|
433 | =item sockdomain
|
---|
434 |
|
---|
435 | Returns the numerical number for the socket domain type. For example, for
|
---|
436 | an AF_INET socket the value of &AF_INET will be returned.
|
---|
437 |
|
---|
438 | =item sockopt(OPT [, VAL])
|
---|
439 |
|
---|
440 | Unified method to both set and get options in the SOL_SOCKET level. If called
|
---|
441 | with one argument then getsockopt is called, otherwise setsockopt is called.
|
---|
442 |
|
---|
443 | =item socktype
|
---|
444 |
|
---|
445 | Returns the numerical number for the socket type. For example, for
|
---|
446 | a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
|
---|
447 |
|
---|
448 | =item timeout([VAL])
|
---|
449 |
|
---|
450 | Set or get the timeout value associated with this socket. If called without
|
---|
451 | any arguments then the current setting is returned. If called with an argument
|
---|
452 | the current setting is changed and the previous value returned.
|
---|
453 |
|
---|
454 | =back
|
---|
455 |
|
---|
456 | =head1 SEE ALSO
|
---|
457 |
|
---|
458 | L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
|
---|
459 |
|
---|
460 | =head1 AUTHOR
|
---|
461 |
|
---|
462 | Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
|
---|
463 | Perl Porters. Please report all bugs to <[email protected]>.
|
---|
464 |
|
---|
465 | =head1 COPYRIGHT
|
---|
466 |
|
---|
467 | Copyright (c) 1997-8 Graham Barr <[email protected]>. All rights reserved.
|
---|
468 | This program is free software; you can redistribute it and/or
|
---|
469 | modify it under the same terms as Perl itself.
|
---|
470 |
|
---|
471 | The atmark() implementation: Copyright 2001, Lincoln Stein <[email protected]>.
|
---|
472 | This module is distributed under the same terms as Perl itself.
|
---|
473 | Feel free to use, modify and redistribute it as long as you retain
|
---|
474 | the correct attribution.
|
---|
475 |
|
---|
476 | =cut
|
---|