Commit | Line | Data |
774d564b |
1 | # IO::Socket.pm |
8add82fc |
2 | # |
cf7fe8a2 |
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 |
774d564b |
5 | # modify it under the same terms as Perl itself. |
8add82fc |
6 | |
7 | package IO::Socket; |
8 | |
63a347c7 |
9 | require v5.6; |
8add82fc |
10 | |
8add82fc |
11 | use IO::Handle; |
12 | use Socket 1.3; |
13 | use Carp; |
14 | use strict; |
63a347c7 |
15 | our(@ISA, $VERSION, @EXPORT_OK); |
8add82fc |
16 | use Exporter; |
c9fcc6c4 |
17 | use Errno; |
8add82fc |
18 | |
cf7fe8a2 |
19 | # legacy |
20 | |
21 | require IO::Socket::INET; |
3a2f06e9 |
22 | require IO::Socket::UNIX if ($^O ne 'epoc'); |
cf7fe8a2 |
23 | |
8add82fc |
24 | @ISA = qw(IO::Handle); |
25 | |
63a347c7 |
26 | $VERSION = "1.27"; |
27 | |
28 | @EXPORT_OK = qw(sockatmark); |
8add82fc |
29 | |
30 | sub import { |
31 | my $pkg = shift; |
e822bc79 |
32 | if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast |
63a347c7 |
33 | Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark'); |
34 | } else { |
35 | my $callpkg = caller; |
36 | Exporter::export 'Socket', $callpkg, @_; |
37 | } |
8add82fc |
38 | } |
39 | |
40 | sub new { |
41 | my($class,%arg) = @_; |
cf7fe8a2 |
42 | my $sock = $class->SUPER::new(); |
43 | |
44 | $sock->autoflush(1); |
8add82fc |
45 | |
cf7fe8a2 |
46 | ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; |
8add82fc |
47 | |
cf7fe8a2 |
48 | return scalar(%arg) ? $sock->configure(\%arg) |
49 | : $sock; |
8add82fc |
50 | } |
51 | |
cf7fe8a2 |
52 | my @domain2pkg; |
27d4819a |
53 | |
54 | sub register_domain { |
55 | my($p,$d) = @_; |
774d564b |
56 | $domain2pkg[$d] = $p; |
27d4819a |
57 | } |
58 | |
8add82fc |
59 | sub configure { |
cf7fe8a2 |
60 | my($sock,$arg) = @_; |
27d4819a |
61 | my $domain = delete $arg->{Domain}; |
62 | |
63 | croak 'IO::Socket: Cannot configure a generic socket' |
64 | unless defined $domain; |
65 | |
774d564b |
66 | croak "IO::Socket: Unsupported socket domain" |
67 | unless defined $domain2pkg[$domain]; |
27d4819a |
68 | |
7a4c00b4 |
69 | croak "IO::Socket: Cannot configure socket in domain '$domain'" |
cf7fe8a2 |
70 | unless ref($sock) eq "IO::Socket"; |
27d4819a |
71 | |
cf7fe8a2 |
72 | bless($sock, $domain2pkg[$domain]); |
73 | $sock->configure($arg); |
8add82fc |
74 | } |
75 | |
76 | sub socket { |
cf7fe8a2 |
77 | @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; |
78 | my($sock,$domain,$type,$protocol) = @_; |
8add82fc |
79 | |
cf7fe8a2 |
80 | socket($sock,$domain,$type,$protocol) or |
8add82fc |
81 | return undef; |
82 | |
cf7fe8a2 |
83 | ${*$sock}{'io_socket_domain'} = $domain; |
84 | ${*$sock}{'io_socket_type'} = $type; |
85 | ${*$sock}{'io_socket_proto'} = $protocol; |
774d564b |
86 | |
cf7fe8a2 |
87 | $sock; |
8add82fc |
88 | } |
89 | |
90 | sub socketpair { |
c4be5b27 |
91 | @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; |
8add82fc |
92 | my($class,$domain,$type,$protocol) = @_; |
cf7fe8a2 |
93 | my $sock1 = $class->new(); |
94 | my $sock2 = $class->new(); |
8add82fc |
95 | |
cf7fe8a2 |
96 | socketpair($sock1,$sock2,$domain,$type,$protocol) or |
8add82fc |
97 | return (); |
98 | |
cf7fe8a2 |
99 | ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; |
100 | ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; |
8add82fc |
101 | |
cf7fe8a2 |
102 | ($sock1,$sock2); |
8add82fc |
103 | } |
104 | |
105 | sub connect { |
cf7fe8a2 |
106 | @_ == 2 or croak 'usage: $sock->connect(NAME)'; |
107 | my $sock = shift; |
108 | my $addr = shift; |
109 | my $timeout = ${*$sock}{'io_socket_timeout'}; |
c9fcc6c4 |
110 | my $err; |
00fdd80d |
111 | my $blocking; |
112 | $blocking = $sock->blocking(0) if $timeout; |
cf7fe8a2 |
113 | |
c9fcc6c4 |
114 | if (!connect($sock, $addr)) { |
af663859 |
115 | if ($timeout && $!{EINPROGRESS}) { |
c9fcc6c4 |
116 | require IO::Select; |
8add82fc |
117 | |
c9fcc6c4 |
118 | my $sel = new IO::Select $sock; |
8add82fc |
119 | |
c9fcc6c4 |
120 | if (!$sel->can_write($timeout)) { |
121 | $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); |
122 | $@ = "connect: timeout"; |
cf7fe8a2 |
123 | } |
f9c1db8d |
124 | elsif(!connect($sock,$addr) && not $!{EISCONN}) { |
af663859 |
125 | # Some systems refuse to re-connect() to |
126 | # an already open socket and set errno to EISCONN. |
f9c1db8d |
127 | $err = $!; |
128 | $@ = "connect: $!"; |
cf7fe8a2 |
129 | } |
130 | } |
c9fcc6c4 |
131 | else { |
132 | $err = $!; |
133 | $@ = "connect: $!"; |
134 | } |
135 | } |
760ac839 |
136 | |
c9fcc6c4 |
137 | $sock->blocking(1) if $blocking; |
00fdd80d |
138 | |
c9fcc6c4 |
139 | $! = $err if $err; |
00fdd80d |
140 | |
c9fcc6c4 |
141 | $err ? undef : $sock; |
8add82fc |
142 | } |
143 | |
144 | sub bind { |
cf7fe8a2 |
145 | @_ == 2 or croak 'usage: $sock->bind(NAME)'; |
146 | my $sock = shift; |
147 | my $addr = shift; |
8add82fc |
148 | |
cf7fe8a2 |
149 | return bind($sock, $addr) ? $sock |
150 | : undef; |
8add82fc |
151 | } |
152 | |
153 | sub listen { |
cf7fe8a2 |
154 | @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; |
155 | my($sock,$queue) = @_; |
8add82fc |
156 | $queue = 5 |
157 | unless $queue && $queue > 0; |
158 | |
cf7fe8a2 |
159 | return listen($sock, $queue) ? $sock |
160 | : undef; |
8add82fc |
161 | } |
162 | |
163 | sub accept { |
cf7fe8a2 |
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'}; |
8add82fc |
168 | my $new = $pkg->new(Timeout => $timeout); |
169 | my $peer = undef; |
170 | |
c9fcc6c4 |
171 | if($timeout) { |
172 | require IO::Select; |
cf7fe8a2 |
173 | |
c9fcc6c4 |
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; |
cf7fe8a2 |
185 | |
c9fcc6c4 |
186 | return wantarray ? ($new, $peer) |
187 | : $new; |
8add82fc |
188 | } |
189 | |
190 | sub sockname { |
cf7fe8a2 |
191 | @_ == 1 or croak 'usage: $sock->sockname()'; |
8add82fc |
192 | getsockname($_[0]); |
193 | } |
194 | |
195 | sub peername { |
cf7fe8a2 |
196 | @_ == 1 or croak 'usage: $sock->peername()'; |
197 | my($sock) = @_; |
198 | getpeername($sock) |
199 | || ${*$sock}{'io_socket_peername'} |
8add82fc |
200 | || undef; |
201 | } |
202 | |
cf7fe8a2 |
203 | sub connected { |
204 | @_ == 1 or croak 'usage: $sock->connected()'; |
205 | my($sock) = @_; |
206 | getpeername($sock); |
207 | } |
208 | |
8add82fc |
209 | sub send { |
cf7fe8a2 |
210 | @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; |
211 | my $sock = $_[0]; |
8add82fc |
212 | my $flags = $_[2] || 0; |
cf7fe8a2 |
213 | my $peer = $_[3] || $sock->peername; |
8add82fc |
214 | |
215 | croak 'send: Cannot determine peer address' |
216 | unless($peer); |
217 | |
cf7fe8a2 |
218 | my $r = defined(getpeername($sock)) |
219 | ? send($sock, $_[1], $flags) |
220 | : send($sock, $_[1], $flags, $peer); |
8add82fc |
221 | |
222 | # remember who we send to, if it was sucessful |
cf7fe8a2 |
223 | ${*$sock}{'io_socket_peername'} = $peer |
8add82fc |
224 | if(@_ == 4 && defined $r); |
225 | |
226 | $r; |
227 | } |
228 | |
229 | sub recv { |
cf7fe8a2 |
230 | @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; |
8add82fc |
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 | |
cf7fe8a2 |
239 | sub shutdown { |
240 | @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; |
241 | my($sock, $how) = @_; |
242 | shutdown($sock, $how); |
243 | } |
8add82fc |
244 | |
245 | sub setsockopt { |
cf7fe8a2 |
246 | @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; |
8add82fc |
247 | setsockopt($_[0],$_[1],$_[2],$_[3]); |
248 | } |
249 | |
250 | my $intsize = length(pack("i",0)); |
251 | |
252 | sub getsockopt { |
cf7fe8a2 |
253 | @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; |
8add82fc |
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 { |
cf7fe8a2 |
262 | my $sock = shift; |
263 | @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) |
264 | : $sock->setsockopt(SOL_SOCKET,@_); |
8add82fc |
265 | } |
266 | |
63a347c7 |
267 | sub atmark { |
268 | @_ == 1 or croak 'usage: $sock->atmark()'; |
269 | my($sock) = @_; |
270 | sockatmark($sock); |
271 | } |
272 | |
8add82fc |
273 | sub timeout { |
cf7fe8a2 |
274 | @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; |
275 | my($sock,$val) = @_; |
276 | my $r = ${*$sock}{'io_socket_timeout'} || undef; |
8add82fc |
277 | |
cf7fe8a2 |
278 | ${*$sock}{'io_socket_timeout'} = 0 + $val |
8add82fc |
279 | if(@_ == 2); |
280 | |
281 | $r; |
282 | } |
283 | |
27d4819a |
284 | sub sockdomain { |
cf7fe8a2 |
285 | @_ == 1 or croak 'usage: $sock->sockdomain()'; |
286 | my $sock = shift; |
287 | ${*$sock}{'io_socket_domain'}; |
27d4819a |
288 | } |
289 | |
8add82fc |
290 | sub socktype { |
cf7fe8a2 |
291 | @_ == 1 or croak 'usage: $sock->socktype()'; |
292 | my $sock = shift; |
293 | ${*$sock}{'io_socket_type'} |
8add82fc |
294 | } |
295 | |
27d4819a |
296 | sub protocol { |
cf7fe8a2 |
297 | @_ == 1 or croak 'usage: $sock->protocol()'; |
298 | my($sock) = @_; |
8fd73a68 |
299 | ${*$sock}{'io_socket_proto'}; |
27d4819a |
300 | } |
301 | |
cf7fe8a2 |
302 | 1; |
8add82fc |
303 | |
cf7fe8a2 |
304 | __END__ |
27d4819a |
305 | |
cf7fe8a2 |
306 | =head1 NAME |
e713eafe |
307 | |
cf7fe8a2 |
308 | IO::Socket - Object interface to socket communications |
8add82fc |
309 | |
cf7fe8a2 |
310 | =head1 SYNOPSIS |
7a4c00b4 |
311 | |
cf7fe8a2 |
312 | use IO::Socket; |
7a4c00b4 |
313 | |
cf7fe8a2 |
314 | =head1 DESCRIPTION |
7a4c00b4 |
315 | |
cf7fe8a2 |
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>. |
8add82fc |
319 | |
cf7fe8a2 |
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> |
e713eafe |
323 | |
cf7fe8a2 |
324 | C<IO::Socket> will export all functions (and constants) defined by L<Socket>. |
e713eafe |
325 | |
cf7fe8a2 |
326 | =head1 CONSTRUCTOR |
8add82fc |
327 | |
27d4819a |
328 | =over 4 |
329 | |
cf7fe8a2 |
330 | =item new ( [ARGS] ) |
27d4819a |
331 | |
cf7fe8a2 |
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. |
8add82fc |
338 | |
cf7fe8a2 |
339 | NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE |
3cb6de81 |
340 | |
cf7fe8a2 |
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. |
27d4819a |
343 | |
cf7fe8a2 |
344 | NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE |
27d4819a |
345 | |
346 | =back |
8add82fc |
347 | |
cf7fe8a2 |
348 | =head1 METHODS |
8add82fc |
349 | |
cf7fe8a2 |
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: |
8add82fc |
353 | |
cf7fe8a2 |
354 | socket |
355 | socketpair |
356 | bind |
357 | listen |
358 | accept |
359 | send |
360 | recv |
361 | peername (getpeername) |
362 | sockname (getsockname) |
363 | shutdown |
8add82fc |
364 | |
cf7fe8a2 |
365 | Some methods take slightly different arguments to those defined in L<perlfunc> |
366 | in attempt to make the interface more flexible. These are |
8add82fc |
367 | |
cf7fe8a2 |
368 | =over 4 |
8add82fc |
369 | |
cf7fe8a2 |
370 | =item accept([PKG]) |
8add82fc |
371 | |
cf7fe8a2 |
372 | perform the system call C<accept> on the socket and return a new object. The |
373 | new object will be created in the same class as the listen socket, unless |
374 | C<PKG> is specified. This object can be used to communicate with the client |
375 | that was trying to connect. In a scalar context the new socket is returned, |
91e74348 |
376 | or undef upon failure. In a list context a two-element array is returned |
c4be5b27 |
377 | containing the new socket and the peer address; the list will |
cf7fe8a2 |
378 | be empty upon failure. |
8add82fc |
379 | |
c4be5b27 |
380 | =item socketpair(DOMAIN, TYPE, PROTOCOL) |
381 | |
382 | Call C<socketpair> and return a list of two sockets created, or an |
383 | empty list on failure. |
384 | |
385 | =back |
386 | |
387 | Additional methods that are provided are: |
388 | |
389 | =over 4 |
8add82fc |
390 | |
63a347c7 |
391 | =item atmark |
8add82fc |
392 | |
63a347c7 |
393 | True if the socket is currently positioned at the urgent data mark, |
394 | false otherwise. |
8add82fc |
395 | |
63a347c7 |
396 | use IO::Socket; |
27d4819a |
397 | |
63a347c7 |
398 | my $sock = IO::Socket::INET->new('some_server'); |
399 | $sock->read(1024,$data) until $sock->atmark; |
8add82fc |
400 | |
63a347c7 |
401 | Note: this is a reasonably new addition to the family of socket |
402 | functions, so all systems may not support this yet. If it is |
403 | unsupported by the system, an attempt to use this method will |
404 | abort the program. |
8add82fc |
405 | |
63a347c7 |
406 | The atmark() functionality is also exportable as sockatmark() function: |
8add82fc |
407 | |
63a347c7 |
408 | use IO::Socket 'sockatmark'; |
8add82fc |
409 | |
63a347c7 |
410 | This allows for a more traditional use of sockatmark() as a procedural |
411 | socket function. |
412 | |
413 | =item connected |
414 | |
415 | If the socket is in a connected state the the peer address is returned. |
416 | If the socket is not in a connected state then undef will be returned. |
27d4819a |
417 | |
cf7fe8a2 |
418 | =item protocol |
8add82fc |
419 | |
cf7fe8a2 |
420 | Returns the numerical number for the protocol being used on the socket, if |
421 | known. If the protocol is unknown, as with an AF_UNIX socket, zero |
422 | is returned. |
8add82fc |
423 | |
63a347c7 |
424 | =item sockdomain |
8add82fc |
425 | |
63a347c7 |
426 | Returns the numerical number for the socket domain type. For example, for |
427 | a AF_INET socket the value of &AF_INET will be returned. |
428 | |
429 | =item sockopt(OPT [, VAL]) |
430 | |
431 | Unified method to both set and get options in the SOL_SOCKET level. If called |
432 | with one argument then getsockopt is called, otherwise setsockopt is called. |
433 | |
434 | =item socktype |
435 | |
436 | Returns the numerical number for the socket type. For example, for |
437 | a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. |
438 | |
439 | =item timeout([VAL]) |
440 | |
441 | Set or get the timeout value associated with this socket. If called without |
442 | any arguments then the current setting is returned. If called with an argument |
443 | the current setting is changed and the previous value returned. |
27d4819a |
444 | |
445 | =back |
8add82fc |
446 | |
7a4c00b4 |
447 | =head1 SEE ALSO |
8add82fc |
448 | |
cf7fe8a2 |
449 | L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> |
8add82fc |
450 | |
7a4c00b4 |
451 | =head1 AUTHOR |
8add82fc |
452 | |
63a347c7 |
453 | Graham Barr. atmark() by Lincoln Stein. Currently maintained by the |
454 | Perl Porters. Please report all bugs to <perl5-porters@perl.org>. |
760ac839 |
455 | |
8add82fc |
456 | =head1 COPYRIGHT |
457 | |
cf7fe8a2 |
458 | Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. |
459 | This program is free software; you can redistribute it and/or |
460 | modify it under the same terms as Perl itself. |
8add82fc |
461 | |
63a347c7 |
462 | The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>. |
463 | This module is distributed under the same terms as Perl itself. |
464 | Feel free to use, modify and redistribute it as long as you retain |
465 | the correct attribution. |
466 | |
8add82fc |
467 | =cut |