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
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 ...
79$VERSION = do{my @r=(q$Revision: 1.8$=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
80
81sub import {
82 my $pkg = shift;
83 my $callpkg = caller;
84 Exporter::export 'Socket', $callpkg, @_;
85}
86
87sub 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
97sub configure {
98 croak 'IO::Socket: Cannot configure a generic socket';
99}
100
101sub 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
112sub 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
126sub 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
157sub 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
166sub 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
176sub 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
200sub sockname {
201 @_ == 1 or croak 'usage: $fh->sockname()';
202 getsockname($_[0]);
203}
204
205sub peername {
206 @_ == 1 or croak 'usage: $fh->peername()';
207 my($fh) = @_;
208 getpeername($fh)
209 || ${*$fh}{'io_socket_peername'}
210 || undef;
211}
212
213sub 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
231sub 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
242sub setsockopt {
243 @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
244 setsockopt($_[0],$_[1],$_[2],$_[3]);
245}
246
247my $intsize = length(pack("i",0));
248
249sub 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
258sub sockopt {
259 my $fh = shift;
260 @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
261 : $fh->setsockopt(SOL_SOCKET,@_);
262}
263
264sub 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
275sub 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
288package IO::Socket::INET;
289
290use strict;
291use vars qw(@ISA $VERSION);
292use Socket;
293use Carp;
294use Exporter;
295
296@ISA = qw(IO::Socket);
297
298my %socket_type = ( tcp => SOCK_STREAM,
299 udp => SOCK_DGRAM,
300 );
301
302=head2 IO::Socket::INET
303
304C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
305and 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
316If Listen is defined then a listen socket is created, else if the socket
317type, which is derived from the protocol, is SOCK_STREAM then a connect
318is called
319
320Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
321from the other.
322
323=head2 METHODS
324
325=item sockaddr()
326
327Return the address part of the sockaddr structure for the socket
328
329=item sockport()
330
331Return the port number that the socket is using on the local host
332
333=item sockhost()
334
335Return the address part of the sockaddr structure for the socket in a
336text form xx.xx.xx.xx
337
338=item peeraddr(), peerport(), peerhost()
339
340Same as for the sock* functions, but returns the data about the peer
341host instead of the local host.
342
343=cut
344
345
346sub _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
382sub 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
432sub sockaddr {
433 @_ == 1 or croak 'usage: $fh->sockaddr()';
434 my($fh) = @_;
435 (sockaddr_in($fh->sockname))[1];
436}
437
438sub sockport {
439 @_ == 1 or croak 'usage: $fh->sockport()';
440 my($fh) = @_;
441 (sockaddr_in($fh->sockname))[0];
442}
443
444sub sockhost {
445 @_ == 1 or croak 'usage: $fh->sockhost()';
446 my($fh) = @_;
447 inet_ntoa($fh->sockaddr);
448}
449
450sub peeraddr {
451 @_ == 1 or croak 'usage: $fh->peeraddr()';
452 my($fh) = @_;
453 (sockaddr_in($fh->peername))[1];
454}
455
456sub peerport {
457 @_ == 1 or croak 'usage: $fh->peerport()';
458 my($fh) = @_;
459 (sockaddr_in($fh->peername))[0];
460}
461
462sub peerhost {
463 @_ == 1 or croak 'usage: $fh->peerhost()';
464 my($fh) = @_;
465 inet_ntoa($fh->peeraddr);
466}
467
468##
469## AF_UNIX
470##
471
472package IO::Socket::UNIX;
473
474use strict;
475use vars qw(@ISA $VERSION);
476use Socket;
477use Carp;
478use Exporter;
479
480@ISA = qw(IO::Socket);
481
482=head2 IO::Socket::UNIX
483
484C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
485and 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
496Returns the pathname to the fifo at the local end
497
498=item peerpath()
499
500Returns the pathanme to the fifo at the peer end
501
502=cut
503
504sub 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
531sub hostpath {
532 @_ == 1 or croak 'usage: $fh->hostpath()';
533 (sockaddr_un($_[0]->hostname))[0];
534}
535
536sub peerpath {
537 @_ == 1 or croak 'usage: $fh->peerpath()';
538 (sockaddr_un($_[0]->peername))[0];
539}
540
541=head1 AUTHOR
542
543Graham Barr <Graham.Barr@tiuk.ti.com>
544
545=head1 REVISION
546
547$Revision: 1.8 $
548
549The VERSION is derived from the revision turning each number after the
550first 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
557Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
558software; you can redistribute it and/or modify it under the same terms
559as Perl itself.
560
561=cut
562
5631; # Keep require happy