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 | |
8add82fc |
9 | require 5.000; |
10 | |
8add82fc |
11 | use IO::Handle; |
12 | use Socket 1.3; |
13 | use Carp; |
14 | use strict; |
7a4c00b4 |
15 | use vars qw(@ISA $VERSION); |
8add82fc |
16 | use Exporter; |
17 | |
cf7fe8a2 |
18 | # legacy |
19 | |
20 | require IO::Socket::INET; |
21 | require IO::Socket::UNIX; |
22 | |
8add82fc |
23 | @ISA = qw(IO::Handle); |
24 | |
00fdd80d |
25 | $VERSION = "1.251"; |
8add82fc |
26 | |
27 | sub import { |
28 | my $pkg = shift; |
29 | my $callpkg = caller; |
30 | Exporter::export 'Socket', $callpkg, @_; |
31 | } |
32 | |
33 | sub new { |
34 | my($class,%arg) = @_; |
cf7fe8a2 |
35 | my $sock = $class->SUPER::new(); |
36 | |
37 | $sock->autoflush(1); |
8add82fc |
38 | |
cf7fe8a2 |
39 | ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; |
8add82fc |
40 | |
cf7fe8a2 |
41 | return scalar(%arg) ? $sock->configure(\%arg) |
42 | : $sock; |
8add82fc |
43 | } |
44 | |
cf7fe8a2 |
45 | my @domain2pkg; |
27d4819a |
46 | |
47 | sub register_domain { |
48 | my($p,$d) = @_; |
774d564b |
49 | $domain2pkg[$d] = $p; |
27d4819a |
50 | } |
51 | |
8add82fc |
52 | sub configure { |
cf7fe8a2 |
53 | my($sock,$arg) = @_; |
27d4819a |
54 | my $domain = delete $arg->{Domain}; |
55 | |
56 | croak 'IO::Socket: Cannot configure a generic socket' |
57 | unless defined $domain; |
58 | |
774d564b |
59 | croak "IO::Socket: Unsupported socket domain" |
60 | unless defined $domain2pkg[$domain]; |
27d4819a |
61 | |
7a4c00b4 |
62 | croak "IO::Socket: Cannot configure socket in domain '$domain'" |
cf7fe8a2 |
63 | unless ref($sock) eq "IO::Socket"; |
27d4819a |
64 | |
cf7fe8a2 |
65 | bless($sock, $domain2pkg[$domain]); |
66 | $sock->configure($arg); |
8add82fc |
67 | } |
68 | |
69 | sub socket { |
cf7fe8a2 |
70 | @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; |
71 | my($sock,$domain,$type,$protocol) = @_; |
8add82fc |
72 | |
cf7fe8a2 |
73 | socket($sock,$domain,$type,$protocol) or |
8add82fc |
74 | return undef; |
75 | |
cf7fe8a2 |
76 | ${*$sock}{'io_socket_domain'} = $domain; |
77 | ${*$sock}{'io_socket_type'} = $type; |
78 | ${*$sock}{'io_socket_proto'} = $protocol; |
774d564b |
79 | |
cf7fe8a2 |
80 | $sock; |
8add82fc |
81 | } |
82 | |
83 | sub socketpair { |
84 | @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; |
85 | my($class,$domain,$type,$protocol) = @_; |
cf7fe8a2 |
86 | my $sock1 = $class->new(); |
87 | my $sock2 = $class->new(); |
8add82fc |
88 | |
cf7fe8a2 |
89 | socketpair($sock1,$sock2,$domain,$type,$protocol) or |
8add82fc |
90 | return (); |
91 | |
cf7fe8a2 |
92 | ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; |
93 | ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; |
8add82fc |
94 | |
cf7fe8a2 |
95 | ($sock1,$sock2); |
8add82fc |
96 | } |
97 | |
98 | sub connect { |
cf7fe8a2 |
99 | @_ == 2 or croak 'usage: $sock->connect(NAME)'; |
100 | my $sock = shift; |
101 | my $addr = shift; |
102 | my $timeout = ${*$sock}{'io_socket_timeout'}; |
103 | |
00fdd80d |
104 | my $blocking; |
105 | $blocking = $sock->blocking(0) if $timeout; |
cf7fe8a2 |
106 | |
00fdd80d |
107 | eval { |
8add82fc |
108 | croak 'connect: Bad address' |
109 | if(@_ == 2 && !defined $_[1]); |
110 | |
cf7fe8a2 |
111 | unless(connect($sock, $addr)) { |
112 | if($timeout && ($! == &IO::EINPROGRESS)) { |
113 | require IO::Select; |
8add82fc |
114 | |
cf7fe8a2 |
115 | my $sel = new IO::Select $sock; |
8add82fc |
116 | |
cf7fe8a2 |
117 | unless($sel->can_write($timeout) && defined($sock->peername)) { |
cf7fe8a2 |
118 | croak "connect: timeout"; |
119 | } |
120 | } |
121 | else { |
cf7fe8a2 |
122 | croak "connect: $!"; |
123 | } |
124 | } |
8add82fc |
125 | }; |
760ac839 |
126 | |
00fdd80d |
127 | my $ret = $@ ? undef : $sock; |
128 | |
129 | $sock->blocking($blocking) if $timeout; |
130 | |
131 | $ret; |
8add82fc |
132 | } |
133 | |
134 | sub bind { |
cf7fe8a2 |
135 | @_ == 2 or croak 'usage: $sock->bind(NAME)'; |
136 | my $sock = shift; |
137 | my $addr = shift; |
8add82fc |
138 | |
cf7fe8a2 |
139 | return bind($sock, $addr) ? $sock |
140 | : undef; |
8add82fc |
141 | } |
142 | |
143 | sub listen { |
cf7fe8a2 |
144 | @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; |
145 | my($sock,$queue) = @_; |
8add82fc |
146 | $queue = 5 |
147 | unless $queue && $queue > 0; |
148 | |
cf7fe8a2 |
149 | return listen($sock, $queue) ? $sock |
150 | : undef; |
8add82fc |
151 | } |
152 | |
153 | sub accept { |
cf7fe8a2 |
154 | @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; |
155 | my $sock = shift; |
156 | my $pkg = shift || $sock; |
157 | my $timeout = ${*$sock}{'io_socket_timeout'}; |
8add82fc |
158 | my $new = $pkg->new(Timeout => $timeout); |
159 | my $peer = undef; |
160 | |
161 | eval { |
162 | if($timeout) { |
cf7fe8a2 |
163 | require IO::Select; |
164 | |
165 | my $sel = new IO::Select $sock; |
166 | |
8add82fc |
167 | croak "accept: timeout" |
cf7fe8a2 |
168 | unless $sel->can_read($timeout); |
8add82fc |
169 | } |
cf7fe8a2 |
170 | $peer = accept($new,$sock) || undef; |
8add82fc |
171 | }; |
172 | |
173 | return wantarray ? defined $peer ? ($new, $peer) |
174 | : () |
175 | : defined $peer ? $new |
176 | : undef; |
177 | } |
178 | |
179 | sub sockname { |
cf7fe8a2 |
180 | @_ == 1 or croak 'usage: $sock->sockname()'; |
8add82fc |
181 | getsockname($_[0]); |
182 | } |
183 | |
184 | sub peername { |
cf7fe8a2 |
185 | @_ == 1 or croak 'usage: $sock->peername()'; |
186 | my($sock) = @_; |
187 | getpeername($sock) |
188 | || ${*$sock}{'io_socket_peername'} |
8add82fc |
189 | || undef; |
190 | } |
191 | |
cf7fe8a2 |
192 | sub connected { |
193 | @_ == 1 or croak 'usage: $sock->connected()'; |
194 | my($sock) = @_; |
195 | getpeername($sock); |
196 | } |
197 | |
8add82fc |
198 | sub send { |
cf7fe8a2 |
199 | @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; |
200 | my $sock = $_[0]; |
8add82fc |
201 | my $flags = $_[2] || 0; |
cf7fe8a2 |
202 | my $peer = $_[3] || $sock->peername; |
8add82fc |
203 | |
204 | croak 'send: Cannot determine peer address' |
205 | unless($peer); |
206 | |
cf7fe8a2 |
207 | my $r = defined(getpeername($sock)) |
208 | ? send($sock, $_[1], $flags) |
209 | : send($sock, $_[1], $flags, $peer); |
8add82fc |
210 | |
211 | # remember who we send to, if it was sucessful |
cf7fe8a2 |
212 | ${*$sock}{'io_socket_peername'} = $peer |
8add82fc |
213 | if(@_ == 4 && defined $r); |
214 | |
215 | $r; |
216 | } |
217 | |
218 | sub recv { |
cf7fe8a2 |
219 | @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; |
8add82fc |
220 | my $sock = $_[0]; |
221 | my $len = $_[2]; |
222 | my $flags = $_[3] || 0; |
223 | |
224 | # remember who we recv'd from |
225 | ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); |
226 | } |
227 | |
cf7fe8a2 |
228 | sub shutdown { |
229 | @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; |
230 | my($sock, $how) = @_; |
231 | shutdown($sock, $how); |
232 | } |
8add82fc |
233 | |
234 | sub setsockopt { |
cf7fe8a2 |
235 | @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; |
8add82fc |
236 | setsockopt($_[0],$_[1],$_[2],$_[3]); |
237 | } |
238 | |
239 | my $intsize = length(pack("i",0)); |
240 | |
241 | sub getsockopt { |
cf7fe8a2 |
242 | @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; |
8add82fc |
243 | my $r = getsockopt($_[0],$_[1],$_[2]); |
244 | # Just a guess |
245 | $r = unpack("i", $r) |
246 | if(defined $r && length($r) == $intsize); |
247 | $r; |
248 | } |
249 | |
250 | sub sockopt { |
cf7fe8a2 |
251 | my $sock = shift; |
252 | @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) |
253 | : $sock->setsockopt(SOL_SOCKET,@_); |
8add82fc |
254 | } |
255 | |
256 | sub timeout { |
cf7fe8a2 |
257 | @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; |
258 | my($sock,$val) = @_; |
259 | my $r = ${*$sock}{'io_socket_timeout'} || undef; |
8add82fc |
260 | |
cf7fe8a2 |
261 | ${*$sock}{'io_socket_timeout'} = 0 + $val |
8add82fc |
262 | if(@_ == 2); |
263 | |
264 | $r; |
265 | } |
266 | |
27d4819a |
267 | sub sockdomain { |
cf7fe8a2 |
268 | @_ == 1 or croak 'usage: $sock->sockdomain()'; |
269 | my $sock = shift; |
270 | ${*$sock}{'io_socket_domain'}; |
27d4819a |
271 | } |
272 | |
8add82fc |
273 | sub socktype { |
cf7fe8a2 |
274 | @_ == 1 or croak 'usage: $sock->socktype()'; |
275 | my $sock = shift; |
276 | ${*$sock}{'io_socket_type'} |
8add82fc |
277 | } |
278 | |
27d4819a |
279 | sub protocol { |
cf7fe8a2 |
280 | @_ == 1 or croak 'usage: $sock->protocol()'; |
281 | my($sock) = @_; |
282 | ${*$sock}{'io_socket_protocol'}; |
27d4819a |
283 | } |
284 | |
cf7fe8a2 |
285 | 1; |
8add82fc |
286 | |
cf7fe8a2 |
287 | __END__ |
27d4819a |
288 | |
cf7fe8a2 |
289 | =head1 NAME |
e713eafe |
290 | |
cf7fe8a2 |
291 | IO::Socket - Object interface to socket communications |
8add82fc |
292 | |
cf7fe8a2 |
293 | =head1 SYNOPSIS |
7a4c00b4 |
294 | |
cf7fe8a2 |
295 | use IO::Socket; |
7a4c00b4 |
296 | |
cf7fe8a2 |
297 | =head1 DESCRIPTION |
7a4c00b4 |
298 | |
cf7fe8a2 |
299 | C<IO::Socket> provides an object interface to creating and using sockets. It |
300 | is built upon the L<IO::Handle> interface and inherits all the methods defined |
301 | by L<IO::Handle>. |
8add82fc |
302 | |
cf7fe8a2 |
303 | C<IO::Socket> only defines methods for those operations which are common to all |
304 | types of socket. Operations which are specified to a socket in a particular |
305 | domain have methods defined in sub classes of C<IO::Socket> |
e713eafe |
306 | |
cf7fe8a2 |
307 | C<IO::Socket> will export all functions (and constants) defined by L<Socket>. |
e713eafe |
308 | |
cf7fe8a2 |
309 | =head1 CONSTRUCTOR |
8add82fc |
310 | |
27d4819a |
311 | =over 4 |
312 | |
cf7fe8a2 |
313 | =item new ( [ARGS] ) |
27d4819a |
314 | |
cf7fe8a2 |
315 | Creates an C<IO::Socket>, which is a reference to a |
316 | newly created symbol (see the C<Symbol> package). C<new> |
317 | optionally takes arguments, these arguments are in key-value pairs. |
318 | C<new> only looks for one key C<Domain> which tells new which domain |
319 | the socket will be in. All other arguments will be passed to the |
320 | configuration method of the package for that domain, See below. |
8add82fc |
321 | |
cf7fe8a2 |
322 | NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE |
323 | |
324 | As of VERSION 1.18 all IO::Socket objects have autoflush turned on |
325 | by default. This was not the case with earlier releases. |
27d4819a |
326 | |
cf7fe8a2 |
327 | NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE |
27d4819a |
328 | |
329 | =back |
8add82fc |
330 | |
cf7fe8a2 |
331 | =head1 METHODS |
8add82fc |
332 | |
cf7fe8a2 |
333 | See L<perlfunc> for complete descriptions of each of the following |
334 | supported C<IO::Socket> methods, which are just front ends for the |
335 | corresponding built-in functions: |
8add82fc |
336 | |
cf7fe8a2 |
337 | socket |
338 | socketpair |
339 | bind |
340 | listen |
341 | accept |
342 | send |
343 | recv |
344 | peername (getpeername) |
345 | sockname (getsockname) |
346 | shutdown |
8add82fc |
347 | |
cf7fe8a2 |
348 | Some methods take slightly different arguments to those defined in L<perlfunc> |
349 | in attempt to make the interface more flexible. These are |
8add82fc |
350 | |
cf7fe8a2 |
351 | =over 4 |
8add82fc |
352 | |
cf7fe8a2 |
353 | =item accept([PKG]) |
8add82fc |
354 | |
cf7fe8a2 |
355 | perform the system call C<accept> on the socket and return a new object. The |
356 | new object will be created in the same class as the listen socket, unless |
357 | C<PKG> is specified. This object can be used to communicate with the client |
358 | that was trying to connect. In a scalar context the new socket is returned, |
359 | or undef upon failure. In an array context a two-element array is returned |
360 | containing the new socket and the peer address, the list will |
361 | be empty upon failure. |
8add82fc |
362 | |
cf7fe8a2 |
363 | Additional methods that are provided are |
8add82fc |
364 | |
cf7fe8a2 |
365 | =item timeout([VAL]) |
8add82fc |
366 | |
cf7fe8a2 |
367 | Set or get the timeout value associated with this socket. If called without |
368 | any arguments then the current setting is returned. If called with an argument |
369 | the current setting is changed and the previous value returned. |
8add82fc |
370 | |
cf7fe8a2 |
371 | =item sockopt(OPT [, VAL]) |
27d4819a |
372 | |
cf7fe8a2 |
373 | Unified method to both set and get options in the SOL_SOCKET level. If called |
374 | with one argument then getsockopt is called, otherwise setsockopt is called. |
8add82fc |
375 | |
cf7fe8a2 |
376 | =item sockdomain |
8add82fc |
377 | |
cf7fe8a2 |
378 | Returns the numerical number for the socket domain type. For example, for |
379 | a AF_INET socket the value of &AF_INET will be returned. |
8add82fc |
380 | |
cf7fe8a2 |
381 | =item socktype |
8add82fc |
382 | |
cf7fe8a2 |
383 | Returns the numerical number for the socket type. For example, for |
384 | a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. |
27d4819a |
385 | |
cf7fe8a2 |
386 | =item protocol |
8add82fc |
387 | |
cf7fe8a2 |
388 | Returns the numerical number for the protocol being used on the socket, if |
389 | known. If the protocol is unknown, as with an AF_UNIX socket, zero |
390 | is returned. |
8add82fc |
391 | |
cf7fe8a2 |
392 | =item connected |
8add82fc |
393 | |
cf7fe8a2 |
394 | If the socket is in a connected state the the peer address is returned. |
395 | If the socket is not in a connected state then undef will be returned. |
27d4819a |
396 | |
397 | =back |
8add82fc |
398 | |
7a4c00b4 |
399 | =head1 SEE ALSO |
8add82fc |
400 | |
cf7fe8a2 |
401 | L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> |
8add82fc |
402 | |
7a4c00b4 |
403 | =head1 AUTHOR |
8add82fc |
404 | |
854822f1 |
405 | Graham Barr. Currently maintained by the Perl Porters. Please report all |
406 | bugs to <perl5-porters@perl.org>. |
760ac839 |
407 | |
8add82fc |
408 | =head1 COPYRIGHT |
409 | |
cf7fe8a2 |
410 | Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. |
411 | This program is free software; you can redistribute it and/or |
412 | modify it under the same terms as Perl itself. |
8add82fc |
413 | |
414 | =cut |