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