Commit | Line | Data |
8add82fc |
1 | # |
2 | |
3 | package IO::Socket; |
4 | |
5 | =head1 NAME |
6 | |
7 | IO::Socket - supply object methods for sockets |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | use IO::Socket; |
12 | |
13 | =head1 DESCRIPTION |
14 | |
15 | C<IO::Socket> provides an object interface to creating and using sockets. It |
16 | is built upon the L<IO::Handle> interface and inherits all the methods defined |
17 | by L<IO::Handle>. |
18 | |
19 | C<IO::Socket> only defines methods for those operations which are common to all |
20 | types of socket. Operations which are specified to a socket in a particular |
21 | domain have methods defined in sub classes of C<IO::Socket> |
22 | |
23 | See L<perlfunc> for complete descriptions of each of the following |
24 | supported C<IO::Seekable> methods, which are just front ends for the |
25 | corresponding built-in functions: |
26 | |
27 | socket |
28 | socketpair |
29 | bind |
30 | listen |
31 | accept |
32 | send |
33 | recv |
34 | peername (getpeername) |
35 | sockname (getsockname) |
36 | |
37 | Some methods take slightly different arguments to those defined in L<perlfunc> |
38 | in attempt to make the interface more flexible. These are |
39 | |
40 | =item accept([PKG]) |
41 | |
42 | perform the system call C<accept> on the socket and return a new object. The |
43 | new object will be created in the same class as the listen socket, unless |
44 | C<PKG> is specified. This object can be used to communicate with the client |
45 | that was trying to connect. In a scalar context the new socket is returned, |
46 | or undef upon failure. In an array context a two-element array is returned |
47 | containing the new socket and the peer address, the list will |
48 | be empty upon failure. |
49 | |
50 | Additional methods that are provided are |
51 | |
52 | =item timeout([VAL]) |
53 | |
54 | Set or get the timeout value associated with this socket. If called without |
55 | any arguments then the current setting is returned. If called with an argument |
56 | the current setting is changed and the previous value returned. |
57 | |
58 | =item sockopt(OPT [, VAL]) |
59 | |
60 | Unified method to both set and get options in the SOL_SOCKET level. If called |
61 | with one argument then getsockopt is called, otherwise setsockopt is called |
62 | |
63 | =cut |
64 | |
65 | |
66 | require 5.000; |
67 | |
68 | use Config; |
69 | use IO::Handle; |
70 | use Socket 1.3; |
71 | use Carp; |
72 | use strict; |
73 | use vars qw(@ISA @EXPORT_OK $VERSION); |
74 | use Exporter; |
75 | |
76 | @ISA = qw(IO::Handle); |
77 | |
78 | # This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ... |
760ac839 |
79 | |
80 | $VERSION = do{my @r=(q$Revision: 1.9 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; |
8add82fc |
81 | |
82 | sub import { |
83 | my $pkg = shift; |
84 | my $callpkg = caller; |
85 | Exporter::export 'Socket', $callpkg, @_; |
86 | } |
87 | |
88 | sub new { |
89 | my($class,%arg) = @_; |
90 | my $fh = $class->SUPER::new(); |
91 | |
92 | ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; |
93 | |
94 | return scalar(%arg) ? $fh->configure(\%arg) |
95 | : $fh; |
96 | } |
97 | |
98 | sub configure { |
99 | croak 'IO::Socket: Cannot configure a generic socket'; |
100 | } |
101 | |
102 | sub socket { |
103 | @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; |
104 | my($fh,$domain,$type,$protocol) = @_; |
105 | |
106 | socket($fh,$domain,$type,$protocol) or |
107 | return undef; |
108 | |
109 | ${*$fh}{'io_socket_type'} = $type; |
110 | $fh; |
111 | } |
112 | |
113 | sub socketpair { |
114 | @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; |
115 | my($class,$domain,$type,$protocol) = @_; |
116 | my $fh1 = $class->new(); |
117 | my $fh2 = $class->new(); |
118 | |
119 | socketpair($fh1,$fh1,$domain,$type,$protocol) or |
120 | return (); |
121 | |
122 | ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; |
123 | |
124 | ($fh1,$fh2); |
125 | } |
126 | |
127 | sub connect { |
128 | @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)'; |
129 | my $fh = shift; |
130 | my $addr = @_ == 1 ? shift : sockaddr_in(@_); |
131 | my $timeout = ${*$fh}{'io_socket_timeout'}; |
132 | local($SIG{ALRM}) = $timeout ? sub { undef $fh; } |
133 | : $SIG{ALRM} || 'DEFAULT'; |
134 | |
760ac839 |
135 | eval { |
8add82fc |
136 | croak 'connect: Bad address' |
137 | if(@_ == 2 && !defined $_[1]); |
138 | |
139 | if($timeout) { |
140 | defined $Config{d_alarm} && defined alarm($timeout) or |
141 | $timeout = 0; |
142 | } |
143 | |
760ac839 |
144 | my $ok = connect($fh, $addr); |
8add82fc |
145 | |
146 | alarm(0) |
147 | if($timeout); |
148 | |
760ac839 |
149 | croak "connect: timeout" |
150 | unless defined $fh; |
8add82fc |
151 | |
760ac839 |
152 | undef $fh unless $ok; |
8add82fc |
153 | }; |
760ac839 |
154 | |
8add82fc |
155 | $fh; |
156 | } |
157 | |
158 | sub bind { |
159 | @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; |
160 | my $fh = shift; |
161 | my $addr = @_ == 1 ? shift : sockaddr_in(@_); |
162 | |
163 | return bind($fh, $addr) ? $fh |
164 | : undef; |
165 | } |
166 | |
167 | sub listen { |
168 | @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; |
169 | my($fh,$queue) = @_; |
170 | $queue = 5 |
171 | unless $queue && $queue > 0; |
172 | |
173 | return listen($fh, $queue) ? $fh |
174 | : undef; |
175 | } |
176 | |
177 | sub accept { |
178 | @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; |
179 | my $fh = shift; |
180 | my $pkg = shift || $fh; |
181 | my $timeout = ${*$fh}{'io_socket_timeout'}; |
182 | my $new = $pkg->new(Timeout => $timeout); |
183 | my $peer = undef; |
184 | |
185 | eval { |
186 | if($timeout) { |
187 | my $fdset = ""; |
188 | vec($fdset, $fh->fileno,1) = 1; |
189 | croak "accept: timeout" |
190 | unless select($fdset,undef,undef,$timeout); |
191 | } |
192 | $peer = accept($new,$fh); |
193 | }; |
194 | |
195 | return wantarray ? defined $peer ? ($new, $peer) |
196 | : () |
197 | : defined $peer ? $new |
198 | : undef; |
199 | } |
200 | |
201 | sub sockname { |
202 | @_ == 1 or croak 'usage: $fh->sockname()'; |
203 | getsockname($_[0]); |
204 | } |
205 | |
206 | sub peername { |
207 | @_ == 1 or croak 'usage: $fh->peername()'; |
208 | my($fh) = @_; |
209 | getpeername($fh) |
210 | || ${*$fh}{'io_socket_peername'} |
211 | || undef; |
212 | } |
213 | |
214 | sub send { |
215 | @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; |
216 | my $fh = $_[0]; |
217 | my $flags = $_[2] || 0; |
218 | my $peer = $_[3] || $fh->peername; |
219 | |
220 | croak 'send: Cannot determine peer address' |
221 | unless($peer); |
222 | |
223 | my $r = send($fh, $_[1], $flags, $peer); |
224 | |
225 | # remember who we send to, if it was sucessful |
226 | ${*$fh}{'io_socket_peername'} = $peer |
227 | if(@_ == 4 && defined $r); |
228 | |
229 | $r; |
230 | } |
231 | |
232 | sub recv { |
233 | @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; |
234 | my $sock = $_[0]; |
235 | my $len = $_[2]; |
236 | my $flags = $_[3] || 0; |
237 | |
238 | # remember who we recv'd from |
239 | ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); |
240 | } |
241 | |
242 | |
243 | sub setsockopt { |
244 | @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; |
245 | setsockopt($_[0],$_[1],$_[2],$_[3]); |
246 | } |
247 | |
248 | my $intsize = length(pack("i",0)); |
249 | |
250 | sub getsockopt { |
251 | @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; |
252 | my $r = getsockopt($_[0],$_[1],$_[2]); |
253 | # Just a guess |
254 | $r = unpack("i", $r) |
255 | if(defined $r && length($r) == $intsize); |
256 | $r; |
257 | } |
258 | |
259 | sub sockopt { |
260 | my $fh = shift; |
261 | @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) |
262 | : $fh->setsockopt(SOL_SOCKET,@_); |
263 | } |
264 | |
265 | sub timeout { |
266 | @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; |
267 | my($fh,$val) = @_; |
268 | my $r = ${*$fh}{'io_socket_timeout'} || undef; |
269 | |
270 | ${*$fh}{'io_socket_timeout'} = 0 + $val |
271 | if(@_ == 2); |
272 | |
273 | $r; |
274 | } |
275 | |
276 | sub socktype { |
277 | @_ == 1 or croak '$fh->socktype()'; |
278 | ${*{$_[0]}}{'io_socket_type'} || undef; |
279 | } |
280 | |
281 | =head1 SUB-CLASSES |
282 | |
283 | =cut |
284 | |
285 | ## |
286 | ## AF_INET |
287 | ## |
288 | |
289 | package IO::Socket::INET; |
290 | |
291 | use strict; |
292 | use vars qw(@ISA $VERSION); |
293 | use Socket; |
294 | use Carp; |
295 | use Exporter; |
296 | |
297 | @ISA = qw(IO::Socket); |
298 | |
299 | my %socket_type = ( tcp => SOCK_STREAM, |
300 | udp => SOCK_DGRAM, |
301 | ); |
302 | |
303 | =head2 IO::Socket::INET |
304 | |
305 | C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket |
306 | and some related methods. The constructor can take the following options |
307 | |
308 | PeerAddr Remote host address |
309 | PeerPort Remote port or service |
310 | LocalPort Local host bind port |
311 | LocalAddr Local host bind address |
312 | Proto Protocol name (eg tcp udp etc) |
313 | Type Socket type (SOCK_STREAM etc) |
314 | Listen Queue size for listen |
315 | Timeout Timeout value for various operations |
316 | |
317 | If Listen is defined then a listen socket is created, else if the socket |
318 | type, which is derived from the protocol, is SOCK_STREAM then a connect |
319 | is called |
320 | |
321 | Only one of C<Type> or C<Proto> needs to be specified, one will be assumed |
322 | from the other. |
323 | |
324 | =head2 METHODS |
325 | |
326 | =item sockaddr() |
327 | |
328 | Return the address part of the sockaddr structure for the socket |
329 | |
330 | =item sockport() |
331 | |
332 | Return the port number that the socket is using on the local host |
333 | |
334 | =item sockhost() |
335 | |
336 | Return the address part of the sockaddr structure for the socket in a |
337 | text form xx.xx.xx.xx |
338 | |
339 | =item peeraddr(), peerport(), peerhost() |
340 | |
341 | Same as for the sock* functions, but returns the data about the peer |
342 | host instead of the local host. |
343 | |
344 | =cut |
345 | |
346 | |
347 | sub _sock_info { |
348 | my($addr,$port,$proto) = @_; |
349 | my @proto = (); |
350 | my @serv = (); |
351 | |
352 | $port = $1 |
353 | if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); |
354 | |
355 | if(defined $proto) { |
356 | @proto = $proto =~ m,\D, ? getprotobyname($proto) |
357 | : getprotobynumber($proto); |
358 | |
359 | $proto = $proto[2] || undef; |
360 | } |
361 | |
362 | if(defined $port) { |
363 | $port =~ s,\((\d+)\)$,,; |
364 | |
365 | my $defport = $1 || undef; |
366 | my $pnum = ($port =~ m,^(\d+)$,)[0]; |
367 | |
368 | @serv= getservbyname($port, $proto[0] || "") |
369 | if($port =~ m,\D,); |
370 | |
371 | $port = $pnum || $serv[2] || $defport || undef; |
372 | |
373 | $proto = (getprotobyname($serv[3]))[2] || undef |
374 | if @serv && !$proto; |
375 | } |
376 | |
377 | return ($addr || undef, |
378 | $port || undef, |
379 | $proto || undef |
380 | ); |
381 | } |
382 | |
383 | sub configure { |
384 | my($fh,$arg) = @_; |
385 | my($lport,$rport,$laddr,$raddr,$proto,$type); |
386 | |
387 | |
388 | ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, |
389 | $arg->{LocalPort}, |
390 | $arg->{Proto}); |
391 | |
392 | $laddr = defined $laddr ? inet_aton($laddr) |
393 | : INADDR_ANY; |
394 | |
395 | unless(exists $arg->{Listen}) { |
396 | ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, |
397 | $arg->{PeerPort}, |
398 | $proto); |
399 | } |
400 | |
401 | croak 'IO::Socket: Cannot determine protocol' |
402 | unless($proto); |
403 | |
404 | my $pname = (getprotobynumber($proto))[0]; |
405 | $type = $arg->{Type} || $socket_type{$pname}; |
406 | |
407 | $fh->socket(AF_INET, $type, $proto) or |
408 | return undef; |
409 | |
410 | $fh->bind($lport || 0, $laddr) or |
411 | return undef; |
412 | |
413 | if(exists $arg->{Listen}) { |
414 | $fh->listen($arg->{Listen} || 5) or |
415 | return undef; |
416 | } |
417 | else { |
418 | croak "IO::Socket: Cannot determine remote port" |
419 | unless($rport || $type == SOCK_DGRAM); |
420 | |
421 | if($type == SOCK_STREAM || defined $raddr) { |
422 | croak "IO::Socket: Bad peer address" |
423 | unless defined $raddr; |
424 | |
425 | $fh->connect($rport,inet_aton($raddr)) or |
426 | return undef; |
427 | } |
428 | } |
429 | |
430 | $fh; |
431 | } |
432 | |
433 | sub sockaddr { |
434 | @_ == 1 or croak 'usage: $fh->sockaddr()'; |
435 | my($fh) = @_; |
436 | (sockaddr_in($fh->sockname))[1]; |
437 | } |
438 | |
439 | sub sockport { |
440 | @_ == 1 or croak 'usage: $fh->sockport()'; |
441 | my($fh) = @_; |
442 | (sockaddr_in($fh->sockname))[0]; |
443 | } |
444 | |
445 | sub sockhost { |
446 | @_ == 1 or croak 'usage: $fh->sockhost()'; |
447 | my($fh) = @_; |
448 | inet_ntoa($fh->sockaddr); |
449 | } |
450 | |
451 | sub peeraddr { |
452 | @_ == 1 or croak 'usage: $fh->peeraddr()'; |
453 | my($fh) = @_; |
454 | (sockaddr_in($fh->peername))[1]; |
455 | } |
456 | |
457 | sub peerport { |
458 | @_ == 1 or croak 'usage: $fh->peerport()'; |
459 | my($fh) = @_; |
460 | (sockaddr_in($fh->peername))[0]; |
461 | } |
462 | |
463 | sub peerhost { |
464 | @_ == 1 or croak 'usage: $fh->peerhost()'; |
465 | my($fh) = @_; |
466 | inet_ntoa($fh->peeraddr); |
467 | } |
468 | |
469 | ## |
470 | ## AF_UNIX |
471 | ## |
472 | |
473 | package IO::Socket::UNIX; |
474 | |
475 | use strict; |
476 | use vars qw(@ISA $VERSION); |
477 | use Socket; |
478 | use Carp; |
479 | use Exporter; |
480 | |
481 | @ISA = qw(IO::Socket); |
482 | |
483 | =head2 IO::Socket::UNIX |
484 | |
485 | C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket |
486 | and some related methods. The constructor can take the following options |
487 | |
488 | Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) |
489 | Local Path to local fifo |
490 | Peer Path to peer fifo |
491 | Listen Create a listen socket |
492 | |
493 | =head2 METHODS |
494 | |
495 | =item hostpath() |
496 | |
497 | Returns the pathname to the fifo at the local end |
498 | |
499 | =item peerpath() |
500 | |
501 | Returns the pathanme to the fifo at the peer end |
502 | |
503 | =cut |
504 | |
505 | sub configure { |
506 | my($fh,$arg) = @_; |
507 | my($bport,$cport); |
508 | |
509 | my $type = $arg->{Type} || SOCK_STREAM; |
510 | |
511 | $fh->socket(AF_UNIX, $type, 0) or |
512 | return undef; |
513 | |
514 | if(exists $arg->{Local}) { |
515 | my $addr = sockaddr_un($arg->{Local}); |
516 | $fh->bind($addr) or |
517 | return undef; |
518 | } |
519 | if(exists $arg->{Listen}) { |
520 | $fh->listen($arg->{Listen} || 5) or |
521 | return undef; |
522 | } |
523 | elsif(exists $arg->{Peer}) { |
524 | my $addr = sockaddr_un($arg->{Peer}); |
525 | $fh->connect($addr) or |
526 | return undef; |
527 | } |
528 | |
529 | $fh; |
530 | } |
531 | |
532 | sub hostpath { |
533 | @_ == 1 or croak 'usage: $fh->hostpath()'; |
534 | (sockaddr_un($_[0]->hostname))[0]; |
535 | } |
536 | |
537 | sub peerpath { |
538 | @_ == 1 or croak 'usage: $fh->peerpath()'; |
539 | (sockaddr_un($_[0]->peername))[0]; |
540 | } |
541 | |
542 | =head1 AUTHOR |
543 | |
544 | Graham Barr <Graham.Barr@tiuk.ti.com> |
545 | |
546 | =head1 REVISION |
547 | |
760ac839 |
548 | $Revision: 1.9 $ |
8add82fc |
549 | |
550 | The VERSION is derived from the revision turning each number after the |
551 | first dot into a 2 digit number so |
552 | |
760ac839 |
553 | Revision 1.8 => VERSION 1.08 |
554 | Revision 1.2.3 => VERSION 1.0203 |
555 | |
8add82fc |
556 | =head1 COPYRIGHT |
557 | |
558 | Copyright (c) 1995 Graham Barr. All rights reserved. This program is free |
559 | software; you can redistribute it and/or modify it under the same terms |
560 | as Perl itself. |
561 | |
562 | =cut |
563 | |
564 | 1; # Keep require happy |