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