[inseparable changes from match from perl-5.003_97b to perl-5.003_97c]
[perl.git] / ext / IO / lib / IO / Socket.pm
1 # IO::Socket.pm
2 #
3 # Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
4 # reserved. 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 =head1 NAME
10
11 IO::Socket - Object interface to socket communications
12
13 =head1 SYNOPSIS
14
15     use IO::Socket;
16
17 =head1 DESCRIPTION
18
19 C<IO::Socket> provides an object interface to creating and using sockets. It
20 is built upon the L<IO::Handle> interface and inherits all the methods defined
21 by L<IO::Handle>.
22
23 C<IO::Socket> only defines methods for those operations which are common to all
24 types of socket. Operations which are specified to a socket in a particular 
25 domain have methods defined in sub classes of C<IO::Socket>
26
27 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
28
29 =head1 CONSTRUCTOR
30
31 =over 4
32
33 =item new ( [ARGS] )
34
35 Creates an C<IO::Socket>, which is a reference to a
36 newly created symbol (see the C<Symbol> package). C<new>
37 optionally takes arguments, these arguments are in key-value pairs.
38 C<new> only looks for one key C<Domain> which tells new which domain
39 the socket will be in. All other arguments will be passed to the
40 configuration method of the package for that domain, See below.
41
42 =back
43
44 =head1 METHODS
45
46 See L<perlfunc> for complete descriptions of each of the following
47 supported C<IO::Socket> methods, which are just front ends for the
48 corresponding built-in functions:
49
50     socket
51     socketpair
52     bind
53     listen
54     accept
55     send
56     recv
57     peername (getpeername)
58     sockname (getsockname)
59
60 Some methods take slightly different arguments to those defined in L<perlfunc>
61 in attempt to make the interface more flexible. These are
62
63 =over 4
64
65 =item accept([PKG])
66
67 perform the system call C<accept> on the socket and return a new object. The
68 new object will be created in the same class as the listen socket, unless
69 C<PKG> is specified. This object can be used to communicate with the client
70 that was trying to connect. In a scalar context the new socket is returned,
71 or undef upon failure. In an array context a two-element array is returned
72 containing the new socket and the peer address, the list will
73 be empty upon failure.
74
75 Additional methods that are provided are
76
77 =item timeout([VAL])
78
79 Set or get the timeout value associated with this socket. If called without
80 any arguments then the current setting is returned. If called with an argument
81 the current setting is changed and the previous value returned.
82
83 =item sockopt(OPT [, VAL])
84
85 Unified method to both set and get options in the SOL_SOCKET level. If called
86 with one argument then getsockopt is called, otherwise setsockopt is called.
87
88 =item sockdomain
89
90 Returns the numerical number for the socket domain type. For example, for
91 a AF_INET socket the value of &AF_INET will be returned.
92
93 =item socktype
94
95 Returns the numerical number for the socket type. For example, for
96 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
97
98 =item protocol
99
100 Returns the numerical number for the protocol being used on the socket, if
101 known. If the protocol is unknown, as with an AF_UNIX socket, zero
102 is returned.
103
104 =back
105
106 =cut
107
108
109 require 5.000;
110
111 use Config;
112 use IO::Handle;
113 use Socket 1.3;
114 use Carp;
115 use strict;
116 use vars qw(@ISA $VERSION);
117 use Exporter;
118
119 @ISA = qw(IO::Handle);
120
121 $VERSION = "1.1602";
122
123 sub import {
124     my $pkg = shift;
125     my $callpkg = caller;
126     Exporter::export 'Socket', $callpkg, @_;
127 }
128
129 sub new {
130     my($class,%arg) = @_;
131     my $fh = $class->SUPER::new();
132
133     ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
134
135     return scalar(%arg) ? $fh->configure(\%arg)
136                         : $fh;
137 }
138
139 my @domain2pkg = ();
140
141 sub register_domain {
142     my($p,$d) = @_;
143     $domain2pkg[$d] = $p;
144 }
145
146 sub configure {
147     my($fh,$arg) = @_;
148     my $domain = delete $arg->{Domain};
149
150     croak 'IO::Socket: Cannot configure a generic socket'
151         unless defined $domain;
152
153     croak "IO::Socket: Unsupported socket domain"
154         unless defined $domain2pkg[$domain];
155
156     croak "IO::Socket: Cannot configure socket in domain '$domain'"
157         unless ref($fh) eq "IO::Socket";
158
159     bless($fh, $domain2pkg[$domain]);
160     $fh->configure($arg);
161 }
162
163 sub socket {
164     @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
165     my($fh,$domain,$type,$protocol) = @_;
166
167     socket($fh,$domain,$type,$protocol) or
168         return undef;
169
170     ${*$fh}{'io_socket_domain'} = $domain;
171     ${*$fh}{'io_socket_type'}   = $type;
172     ${*$fh}{'io_socket_proto'}  = $protocol;
173
174     $fh;
175 }
176
177 sub socketpair {
178     @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
179     my($class,$domain,$type,$protocol) = @_;
180     my $fh1 = $class->new();
181     my $fh2 = $class->new();
182
183     socketpair($fh1,$fh1,$domain,$type,$protocol) or
184         return ();
185
186     ${*$fh1}{'io_socket_type'}  = ${*$fh2}{'io_socket_type'}  = $type;
187     ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
188
189     ($fh1,$fh2);
190 }
191
192 sub connect {
193     @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
194     my $fh = shift;
195     my $addr = @_ == 1 ? shift : sockaddr_in(@_);
196     my $timeout = ${*$fh}{'io_socket_timeout'};
197     local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
198                                  : $SIG{ALRM} || 'DEFAULT';
199
200      eval {
201         croak 'connect: Bad address'
202             if(@_ == 2 && !defined $_[1]);
203
204         if($timeout) {
205             defined $Config{d_alarm} && defined alarm($timeout) or
206                 $timeout = 0;
207         }
208
209         my $ok = connect($fh, $addr);
210
211         alarm(0)
212             if($timeout);
213
214         croak "connect: timeout"
215             unless defined $fh;
216
217         undef $fh unless $ok;
218     };
219
220     $fh;
221 }
222
223 sub bind {
224     @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
225     my $fh = shift;
226     my $addr = @_ == 1 ? shift : sockaddr_in(@_);
227
228     return bind($fh, $addr) ? $fh
229                             : undef;
230 }
231
232 sub listen {
233     @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
234     my($fh,$queue) = @_;
235     $queue = 5
236         unless $queue && $queue > 0;
237
238     return listen($fh, $queue) ? $fh
239                                : undef;
240 }
241
242 sub accept {
243     @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
244     my $fh = shift;
245     my $pkg = shift || $fh;
246     my $timeout = ${*$fh}{'io_socket_timeout'};
247     my $new = $pkg->new(Timeout => $timeout);
248     my $peer = undef;
249
250     eval {
251         if($timeout) {
252             my $fdset = "";
253             vec($fdset, $fh->fileno,1) = 1;
254             croak "accept: timeout"
255                 unless select($fdset,undef,undef,$timeout);
256         }
257         $peer = accept($new,$fh);
258     };
259
260     return wantarray ? defined $peer ? ($new, $peer)
261                                      : () 
262                      : defined $peer ? $new
263                                      : undef;
264 }
265
266 sub sockname {
267     @_ == 1 or croak 'usage: $fh->sockname()';
268     getsockname($_[0]);
269 }
270
271 sub peername {
272     @_ == 1 or croak 'usage: $fh->peername()';
273     my($fh) = @_;
274     getpeername($fh)
275       || ${*$fh}{'io_socket_peername'}
276       || undef;
277 }
278
279 sub send {
280     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
281     my $fh    = $_[0];
282     my $flags = $_[2] || 0;
283     my $peer  = $_[3] || $fh->peername;
284
285     croak 'send: Cannot determine peer address'
286          unless($peer);
287
288     my $r = defined(getpeername($fh))
289         ? send($fh, $_[1], $flags)
290         : send($fh, $_[1], $flags, $peer);
291
292     # remember who we send to, if it was sucessful
293     ${*$fh}{'io_socket_peername'} = $peer
294         if(@_ == 4 && defined $r);
295
296     $r;
297 }
298
299 sub recv {
300     @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
301     my $sock  = $_[0];
302     my $len   = $_[2];
303     my $flags = $_[3] || 0;
304
305     # remember who we recv'd from
306     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
307 }
308
309
310 sub setsockopt {
311     @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
312     setsockopt($_[0],$_[1],$_[2],$_[3]);
313 }
314
315 my $intsize = length(pack("i",0));
316
317 sub getsockopt {
318     @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
319     my $r = getsockopt($_[0],$_[1],$_[2]);
320     # Just a guess
321     $r = unpack("i", $r)
322         if(defined $r && length($r) == $intsize);
323     $r;
324 }
325
326 sub sockopt {
327     my $fh = shift;
328     @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
329             : $fh->setsockopt(SOL_SOCKET,@_);
330 }
331
332 sub timeout {
333     @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
334     my($fh,$val) = @_;
335     my $r = ${*$fh}{'io_socket_timeout'} || undef;
336
337     ${*$fh}{'io_socket_timeout'} = 0 + $val
338         if(@_ == 2);
339
340     $r;
341 }
342
343 sub sockdomain {
344     @_ == 1 or croak 'usage: $fh->sockdomain()';
345     my $fh = shift;
346     ${*$fh}{'io_socket_domain'};
347 }
348
349 sub socktype {
350     @_ == 1 or croak 'usage: $fh->socktype()';
351     my $fh = shift;
352     ${*$fh}{'io_socket_type'}
353 }
354
355 sub protocol {
356     @_ == 1 or croak 'usage: $fh->protocol()';
357     my($fh) = @_;
358     ${*$fh}{'io_socket_protocol'};
359 }
360
361 =head1 SUB-CLASSES
362
363 =cut
364
365 ##
366 ## AF_INET
367 ##
368
369 package IO::Socket::INET;
370
371 use strict;
372 use vars qw(@ISA);
373 use Socket;
374 use Carp;
375 use Exporter;
376
377 @ISA = qw(IO::Socket);
378
379 IO::Socket::INET->register_domain( AF_INET );
380
381 my %socket_type = ( tcp => SOCK_STREAM,
382                     udp => SOCK_DGRAM,
383                   );
384
385 =head2 IO::Socket::INET
386
387 C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
388 and some related methods. The constructor can take the following options
389
390     PeerAddr    Remote host address          <hostname>[:<port>]
391     PeerPort    Remote port or service       <service>[(<no>)] | <no>
392     LocalAddr   Local host bind address      hostname[:port]
393     LocalPort   Local host bind port         <service>[(<no>)] | <no>
394     Proto       Protocol name                "tcp" | "udp" | ...
395     Type        Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
396     Listen      Queue size for listen
397     Reuse       Set SO_REUSEADDR before binding
398     Timeout     Timeout value for various operations
399
400
401 If C<Listen> is defined then a listen socket is created, else if the
402 socket type, which is derived from the protocol, is SOCK_STREAM then
403 connect() is called.
404
405 The C<PeerAddr> can be a hostname or the IP-address on the
406 "xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
407 service name.  The service name might be followed by a number in
408 parenthesis which is used if the service is not known by the system.
409 The C<PeerPort> specification can also be embedded in the C<PeerAddr>
410 by preceding it with a ":".
411
412 Only one of C<Type> or C<Proto> needs to be specified, one will be
413 assumed from the other.  If you specify a symbolic C<PeerPort> port,
414 then the constructor will try to derive C<Type> and C<Proto> from
415 the service name.
416
417 Examples:
418
419    $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
420                                  PeerPort => 'http(80)',
421                                  Proto    => 'tcp');
422
423    $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
424
425    $sock = IO::Socket::INET->new(Listen    => 5,
426                                  LocalAddr => 'localhost',
427                                  LocalPort => 9000,
428                                  Proto     => 'tcp');
429
430 =head2 METHODS
431
432 =over 4
433
434 =item sockaddr ()
435
436 Return the address part of the sockaddr structure for the socket
437
438 =item sockport ()
439
440 Return the port number that the socket is using on the local host
441
442 =item sockhost ()
443
444 Return the address part of the sockaddr structure for the socket in a
445 text form xx.xx.xx.xx
446
447 =item peeraddr ()
448
449 Return the address part of the sockaddr structure for the socket on
450 the peer host
451
452 =item peerport ()
453
454 Return the port number for the socket on the peer host.
455
456 =item peerhost ()
457
458 Return the address part of the sockaddr structure for the socket on the
459 peer host in a text form xx.xx.xx.xx
460
461 =back
462
463 =cut
464
465 sub _sock_info {
466   my($addr,$port,$proto) = @_;
467   my @proto = ();
468   my @serv = ();
469
470   $port = $1
471         if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
472
473   if(defined $proto) {
474     @proto = $proto =~ m,\D, ? getprotobyname($proto)
475                              : getprotobynumber($proto);
476
477     $proto = $proto[2] || undef;
478   }
479
480   if(defined $port) {
481     $port =~ s,\((\d+)\)$,,;
482
483     my $defport = $1 || undef;
484     my $pnum = ($port =~ m,^(\d+)$,)[0];
485
486     @serv= getservbyname($port, $proto[0] || "")
487         if($port =~ m,\D,);
488
489     $port = $pnum || $serv[2] || $defport || undef;
490
491     $proto = (getprotobyname($serv[3]))[2] || undef
492         if @serv && !$proto;
493   }
494
495  return ($addr || undef,
496          $port || undef,
497          $proto || undef
498         );
499 }
500
501 sub _error {
502     my $fh = shift;
503     $@ = join("",ref($fh),": ",@_);
504     carp $@ if $^W;
505     close($fh)
506         if(defined fileno($fh));
507     return undef;
508 }
509
510 sub configure {
511     my($fh,$arg) = @_;
512     my($lport,$rport,$laddr,$raddr,$proto,$type);
513
514
515     ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
516                                         $arg->{LocalPort},
517                                         $arg->{Proto});
518
519     $laddr = defined $laddr ? inet_aton($laddr)
520                             : INADDR_ANY;
521
522     return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
523         unless(defined $laddr);
524
525     unless(exists $arg->{Listen}) {
526         ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
527                                             $arg->{PeerPort},
528                                             $proto);
529     }
530
531     if(defined $raddr) {
532         $raddr = inet_aton($raddr);
533         return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
534                 unless(defined $raddr);
535     }
536
537     return _error($fh,'Cannot determine protocol')
538         unless($proto);
539
540     my $pname = (getprotobynumber($proto))[0];
541     $type = $arg->{Type} || $socket_type{$pname};
542
543     $fh->socket(AF_INET, $type, $proto) or
544         return _error($fh,"$!");
545
546     if ($arg->{Reuse}) {
547         $fh->sockopt(SO_REUSEADDR,1) or
548                 return _error($fh);
549     }
550
551     $fh->bind($lport || 0, $laddr) or
552         return _error($fh,"$!");
553
554     if(exists $arg->{Listen}) {
555         $fh->listen($arg->{Listen} || 5) or
556             return _error($fh,"$!");
557     }
558     else {
559         return _error($fh,'Cannot determine remote port')
560                 unless($rport || $type == SOCK_DGRAM);
561
562         if($type == SOCK_STREAM || defined $raddr) {
563             return _error($fh,'Bad peer address')
564                 unless(defined $raddr);
565
566             $fh->connect($rport,$raddr) or
567                 return _error($fh,"$!");
568         }
569     }
570
571     $fh;
572 }
573
574 sub sockaddr {
575     @_ == 1 or croak 'usage: $fh->sockaddr()';
576     my($fh) = @_;
577     (sockaddr_in($fh->sockname))[1];
578 }
579
580 sub sockport {
581     @_ == 1 or croak 'usage: $fh->sockport()';
582     my($fh) = @_;
583     (sockaddr_in($fh->sockname))[0];
584 }
585
586 sub sockhost {
587     @_ == 1 or croak 'usage: $fh->sockhost()';
588     my($fh) = @_;
589     inet_ntoa($fh->sockaddr);
590 }
591
592 sub peeraddr {
593     @_ == 1 or croak 'usage: $fh->peeraddr()';
594     my($fh) = @_;
595     (sockaddr_in($fh->peername))[1];
596 }
597
598 sub peerport {
599     @_ == 1 or croak 'usage: $fh->peerport()';
600     my($fh) = @_;
601     (sockaddr_in($fh->peername))[0];
602 }
603
604 sub peerhost {
605     @_ == 1 or croak 'usage: $fh->peerhost()';
606     my($fh) = @_;
607     inet_ntoa($fh->peeraddr);
608 }
609
610 ##
611 ## AF_UNIX
612 ##
613
614 package IO::Socket::UNIX;
615
616 use strict;
617 use vars qw(@ISA $VERSION);
618 use Socket;
619 use Carp;
620 use Exporter;
621
622 @ISA = qw(IO::Socket);
623
624 IO::Socket::UNIX->register_domain( AF_UNIX );
625
626 =head2 IO::Socket::UNIX
627
628 C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
629 and some related methods. The constructor can take the following options
630
631     Type        Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
632     Local       Path to local fifo
633     Peer        Path to peer fifo
634     Listen      Create a listen socket
635
636 =head2 METHODS
637
638 =over 4
639
640 =item hostpath()
641
642 Returns the pathname to the fifo at the local end
643
644 =item peerpath()
645
646 Returns the pathanme to the fifo at the peer end
647
648 =back
649
650 =cut
651
652 sub configure {
653     my($fh,$arg) = @_;
654     my($bport,$cport);
655
656     my $type = $arg->{Type} || SOCK_STREAM;
657
658     $fh->socket(AF_UNIX, $type, 0) or
659         return undef;
660
661     if(exists $arg->{Local}) {
662         my $addr = sockaddr_un($arg->{Local});
663         $fh->bind($addr) or
664             return undef;
665     }
666     if(exists $arg->{Listen}) {
667         $fh->listen($arg->{Listen} || 5) or
668             return undef;
669     }
670     elsif(exists $arg->{Peer}) {
671         my $addr = sockaddr_un($arg->{Peer});
672         $fh->connect($addr) or
673             return undef;
674     }
675
676     $fh;
677 }
678
679 sub hostpath {
680     @_ == 1 or croak 'usage: $fh->hostpath()';
681     my $n = $_[0]->sockname || return undef;
682     (sockaddr_un($n))[0];
683 }
684
685 sub peerpath {
686     @_ == 1 or croak 'usage: $fh->peerpath()';
687     my $n = $_[0]->peername || return undef;
688     (sockaddr_un($n))[0];
689 }
690
691 =head1 SEE ALSO
692
693 L<Socket>, L<IO::Handle>
694
695 =head1 AUTHOR
696
697 Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
698
699 =head1 COPYRIGHT
700
701 Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
702 software; you can redistribute it and/or modify it under the same terms
703 as Perl itself.
704
705 =cut
706
707 1; # Keep require happy