Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | 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 <perl5-porters@perl.org>. | |
464 | ||
465 | =head1 COPYRIGHT | |
466 | ||
467 | Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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 <lstein@cshl.org>. | |
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 |