This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated to IO-1.12.
[perl5.git] / ext / IO / lib / IO / Socket.pm
CommitLineData
8add82fc
PP
1#
2
3package IO::Socket;
4
5=head1 NAME
6
7IO::Socket - supply object methods for sockets
8
9=head1 SYNOPSIS
10
11 use IO::Socket;
12
13=head1 DESCRIPTION
14
15C<IO::Socket> provides an object interface to creating and using sockets. It
16is built upon the L<IO::Handle> interface and inherits all the methods defined
17by L<IO::Handle>.
18
19C<IO::Socket> only defines methods for those operations which are common to all
20types of socket. Operations which are specified to a socket in a particular
21domain have methods defined in sub classes of C<IO::Socket>
22
23See L<perlfunc> for complete descriptions of each of the following
24supported C<IO::Seekable> methods, which are just front ends for the
25corresponding 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
37Some methods take slightly different arguments to those defined in L<perlfunc>
38in attempt to make the interface more flexible. These are
39
40=item accept([PKG])
41
42perform the system call C<accept> on the socket and return a new object. The
43new object will be created in the same class as the listen socket, unless
44C<PKG> is specified. This object can be used to communicate with the client
45that was trying to connect. In a scalar context the new socket is returned,
46or undef upon failure. In an array context a two-element array is returned
47containing the new socket and the peer address, the list will
48be empty upon failure.
49
50Additional methods that are provided are
51
52=item timeout([VAL])
53
54Set or get the timeout value associated with this socket. If called without
55any arguments then the current setting is returned. If called with an argument
56the current setting is changed and the previous value returned.
57
58=item sockopt(OPT [, VAL])
59
60Unified method to both set and get options in the SOL_SOCKET level. If called
61with one argument then getsockopt is called, otherwise setsockopt is called
62
63=cut
64
65
66require 5.000;
67
68use Config;
69use IO::Handle;
70use Socket 1.3;
71use Carp;
72use strict;
73use vars qw(@ISA @EXPORT_OK $VERSION);
74use 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
LW
79
80$VERSION = do{my @r=(q$Revision: 1.9 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
8add82fc
PP
81
82sub import {
83 my $pkg = shift;
84 my $callpkg = caller;
85 Exporter::export 'Socket', $callpkg, @_;
86}
87
88sub 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
98sub configure {
99 croak 'IO::Socket: Cannot configure a generic socket';
100}
101
102sub 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
113sub 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
127sub 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
PP
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
PP
145
146 alarm(0)
147 if($timeout);
148
760ac839
LW
149 croak "connect: timeout"
150 unless defined $fh;
8add82fc 151
760ac839 152 undef $fh unless $ok;
8add82fc 153 };
760ac839 154
8add82fc
PP
155 $fh;
156}
157
158sub 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
167sub 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
177sub 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
201sub sockname {
202 @_ == 1 or croak 'usage: $fh->sockname()';
203 getsockname($_[0]);
204}
205
206sub peername {
207 @_ == 1 or croak 'usage: $fh->peername()';
208 my($fh) = @_;
209 getpeername($fh)
210 || ${*$fh}{'io_socket_peername'}
211 || undef;
212}
213
214sub 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
232sub 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
243sub setsockopt {
244 @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
245 setsockopt($_[0],$_[1],$_[2],$_[3]);
246}
247
248my $intsize = length(pack("i",0));
249
250sub 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
259sub sockopt {
260 my $fh = shift;
261 @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
262 : $fh->setsockopt(SOL_SOCKET,@_);
263}
264
265sub 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
276sub 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
289package IO::Socket::INET;
290
291use strict;
292use vars qw(@ISA $VERSION);
293use Socket;
294use Carp;
295use Exporter;
296
297@ISA = qw(IO::Socket);
298
299my %socket_type = ( tcp => SOCK_STREAM,
300 udp => SOCK_DGRAM,
301 );
302
303=head2 IO::Socket::INET
304
305C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
306and 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
317If Listen is defined then a listen socket is created, else if the socket
318type, which is derived from the protocol, is SOCK_STREAM then a connect
319is called
320
321Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
322from the other.
323
324=head2 METHODS
325
326=item sockaddr()
327
328Return the address part of the sockaddr structure for the socket
329
330=item sockport()
331
332Return the port number that the socket is using on the local host
333
334=item sockhost()
335
336Return the address part of the sockaddr structure for the socket in a
337text form xx.xx.xx.xx
338
339=item peeraddr(), peerport(), peerhost()
340
341Same as for the sock* functions, but returns the data about the peer
342host instead of the local host.
343
344=cut
345
346
347sub _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
383sub 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
433sub sockaddr {
434 @_ == 1 or croak 'usage: $fh->sockaddr()';
435 my($fh) = @_;
436 (sockaddr_in($fh->sockname))[1];
437}
438
439sub sockport {
440 @_ == 1 or croak 'usage: $fh->sockport()';
441 my($fh) = @_;
442 (sockaddr_in($fh->sockname))[0];
443}
444
445sub sockhost {
446 @_ == 1 or croak 'usage: $fh->sockhost()';
447 my($fh) = @_;
448 inet_ntoa($fh->sockaddr);
449}
450
451sub peeraddr {
452 @_ == 1 or croak 'usage: $fh->peeraddr()';
453 my($fh) = @_;
454 (sockaddr_in($fh->peername))[1];
455}
456
457sub peerport {
458 @_ == 1 or croak 'usage: $fh->peerport()';
459 my($fh) = @_;
460 (sockaddr_in($fh->peername))[0];
461}
462
463sub peerhost {
464 @_ == 1 or croak 'usage: $fh->peerhost()';
465 my($fh) = @_;
466 inet_ntoa($fh->peeraddr);
467}
468
469##
470## AF_UNIX
471##
472
473package IO::Socket::UNIX;
474
475use strict;
476use vars qw(@ISA $VERSION);
477use Socket;
478use Carp;
479use Exporter;
480
481@ISA = qw(IO::Socket);
482
483=head2 IO::Socket::UNIX
484
485C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
486and 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
497Returns the pathname to the fifo at the local end
498
499=item peerpath()
500
501Returns the pathanme to the fifo at the peer end
502
503=cut
504
505sub 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
532sub hostpath {
533 @_ == 1 or croak 'usage: $fh->hostpath()';
534 (sockaddr_un($_[0]->hostname))[0];
535}
536
537sub peerpath {
538 @_ == 1 or croak 'usage: $fh->peerpath()';
539 (sockaddr_un($_[0]->peername))[0];
540}
541
542=head1 AUTHOR
543
544Graham Barr <Graham.Barr@tiuk.ti.com>
545
546=head1 REVISION
547
760ac839 548$Revision: 1.9 $
8add82fc
PP
549
550The VERSION is derived from the revision turning each number after the
551first dot into a 2 digit number so
552
760ac839
LW
553 Revision 1.8 => VERSION 1.08
554 Revision 1.2.3 => VERSION 1.0203
555
8add82fc
PP
556=head1 COPYRIGHT
557
558Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
559software; you can redistribute it and/or modify it under the same terms
560as Perl itself.
561
562=cut
563
5641; # Keep require happy