Commit | Line | Data |
774d564b |
1 | # IO::Socket.pm |
8add82fc |
2 | # |
774d564b |
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 |
6 | |
7 | package IO::Socket; |
8 | |
9 | =head1 NAME |
10 | |
27d4819a |
11 | IO::Socket - Object interface to socket communications |
8add82fc |
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 | |
7a4c00b4 |
27 | C<IO::Socket> will export all functions (and constants) defined by L<Socket>. |
28 | |
27d4819a |
29 | =head1 CONSTRUCTOR |
30 | |
31 | =over 4 |
32 | |
33 | =item new ( [ARGS] ) |
34 | |
2085bf88 |
35 | Creates an C<IO::Socket>, which is a reference to a |
27d4819a |
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 |
2085bf88 |
39 | the socket will be in. All other arguments will be passed to the |
27d4819a |
40 | configuration method of the package for that domain, See below. |
41 | |
e713eafe |
42 | C<IO::Socket>s will be in autoflush mode after creation. Note that |
43 | versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04) |
44 | did not do this. So if you need backward compatibility, you should |
45 | set autoflush explicitly. |
46 | |
27d4819a |
47 | =back |
48 | |
49 | =head1 METHODS |
50 | |
8add82fc |
51 | See L<perlfunc> for complete descriptions of each of the following |
2085bf88 |
52 | supported C<IO::Socket> methods, which are just front ends for the |
8add82fc |
53 | corresponding 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 | |
65 | Some methods take slightly different arguments to those defined in L<perlfunc> |
66 | in attempt to make the interface more flexible. These are |
67 | |
27d4819a |
68 | =over 4 |
69 | |
8add82fc |
70 | =item accept([PKG]) |
71 | |
72 | perform the system call C<accept> on the socket and return a new object. The |
73 | new object will be created in the same class as the listen socket, unless |
74 | C<PKG> is specified. This object can be used to communicate with the client |
75 | that was trying to connect. In a scalar context the new socket is returned, |
76 | or undef upon failure. In an array context a two-element array is returned |
77 | containing the new socket and the peer address, the list will |
78 | be empty upon failure. |
79 | |
80 | Additional methods that are provided are |
81 | |
82 | =item timeout([VAL]) |
83 | |
84 | Set or get the timeout value associated with this socket. If called without |
85 | any arguments then the current setting is returned. If called with an argument |
86 | the current setting is changed and the previous value returned. |
87 | |
88 | =item sockopt(OPT [, VAL]) |
89 | |
90 | Unified method to both set and get options in the SOL_SOCKET level. If called |
27d4819a |
91 | with one argument then getsockopt is called, otherwise setsockopt is called. |
92 | |
93 | =item sockdomain |
94 | |
7a4c00b4 |
95 | Returns the numerical number for the socket domain type. For example, for |
27d4819a |
96 | a AF_INET socket the value of &AF_INET will be returned. |
97 | |
98 | =item socktype |
99 | |
7a4c00b4 |
100 | Returns the numerical number for the socket type. For example, for |
27d4819a |
101 | a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. |
102 | |
103 | =item protocol |
104 | |
105 | Returns the numerical number for the protocol being used on the socket, if |
106 | known. If the protocol is unknown, as with an AF_UNIX socket, zero |
107 | is returned. |
108 | |
109 | =back |
8add82fc |
110 | |
111 | =cut |
112 | |
113 | |
114 | require 5.000; |
115 | |
116 | use Config; |
117 | use IO::Handle; |
118 | use Socket 1.3; |
119 | use Carp; |
120 | use strict; |
7a4c00b4 |
121 | use vars qw(@ISA $VERSION); |
8add82fc |
122 | use Exporter; |
123 | |
124 | @ISA = qw(IO::Handle); |
125 | |
e713eafe |
126 | $VERSION = "1.1603"; |
8add82fc |
127 | |
128 | sub import { |
129 | my $pkg = shift; |
130 | my $callpkg = caller; |
131 | Exporter::export 'Socket', $callpkg, @_; |
132 | } |
133 | |
134 | sub new { |
135 | my($class,%arg) = @_; |
136 | my $fh = $class->SUPER::new(); |
e713eafe |
137 | $fh->autoflush; |
8add82fc |
138 | |
139 | ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; |
140 | |
141 | return scalar(%arg) ? $fh->configure(\%arg) |
142 | : $fh; |
143 | } |
144 | |
27d4819a |
145 | my @domain2pkg = (); |
146 | |
147 | sub register_domain { |
148 | my($p,$d) = @_; |
774d564b |
149 | $domain2pkg[$d] = $p; |
27d4819a |
150 | } |
151 | |
8add82fc |
152 | sub configure { |
27d4819a |
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 |
159 | croak "IO::Socket: Unsupported socket domain" |
160 | unless defined $domain2pkg[$domain]; |
27d4819a |
161 | |
7a4c00b4 |
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 |
167 | } |
168 | |
169 | sub 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 |
176 | ${*$fh}{'io_socket_domain'} = $domain; |
177 | ${*$fh}{'io_socket_type'} = $type; |
178 | ${*$fh}{'io_socket_proto'} = $protocol; |
179 | |
8add82fc |
180 | $fh; |
181 | } |
182 | |
183 | sub 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 |
190 | return (); |
191 | |
27d4819a |
192 | ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; |
193 | ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; |
8add82fc |
194 | |
195 | ($fh1,$fh2); |
196 | } |
197 | |
198 | sub 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 |
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 |
216 | |
217 | alarm(0) |
218 | if($timeout); |
219 | |
760ac839 |
220 | croak "connect: timeout" |
221 | unless defined $fh; |
8add82fc |
222 | |
760ac839 |
223 | undef $fh unless $ok; |
8add82fc |
224 | }; |
760ac839 |
225 | |
8add82fc |
226 | $fh; |
227 | } |
228 | |
229 | sub 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 | |
238 | sub 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 | |
248 | sub 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 | |
272 | sub sockname { |
273 | @_ == 1 or croak 'usage: $fh->sockname()'; |
274 | getsockname($_[0]); |
275 | } |
276 | |
277 | sub peername { |
278 | @_ == 1 or croak 'usage: $fh->peername()'; |
279 | my($fh) = @_; |
280 | getpeername($fh) |
281 | || ${*$fh}{'io_socket_peername'} |
282 | || undef; |
283 | } |
284 | |
285 | sub 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 |
294 | my $r = defined(getpeername($fh)) |
295 | ? send($fh, $_[1], $flags) |
296 | : send($fh, $_[1], $flags, $peer); |
8add82fc |
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 | |
305 | sub 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 | |
316 | sub setsockopt { |
317 | @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; |
318 | setsockopt($_[0],$_[1],$_[2],$_[3]); |
319 | } |
320 | |
321 | my $intsize = length(pack("i",0)); |
322 | |
323 | sub 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 | |
332 | sub sockopt { |
333 | my $fh = shift; |
334 | @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) |
335 | : $fh->setsockopt(SOL_SOCKET,@_); |
336 | } |
337 | |
338 | sub 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 |
349 | sub sockdomain { |
350 | @_ == 1 or croak 'usage: $fh->sockdomain()'; |
351 | my $fh = shift; |
774d564b |
352 | ${*$fh}{'io_socket_domain'}; |
27d4819a |
353 | } |
354 | |
8add82fc |
355 | sub socktype { |
27d4819a |
356 | @_ == 1 or croak 'usage: $fh->socktype()'; |
357 | my $fh = shift; |
358 | ${*$fh}{'io_socket_type'} |
8add82fc |
359 | } |
360 | |
27d4819a |
361 | sub protocol { |
362 | @_ == 1 or croak 'usage: $fh->protocol()'; |
363 | my($fh) = @_; |
364 | ${*$fh}{'io_socket_protocol'}; |
365 | } |
366 | |
8add82fc |
367 | =head1 SUB-CLASSES |
368 | |
369 | =cut |
370 | |
371 | ## |
372 | ## AF_INET |
373 | ## |
374 | |
375 | package IO::Socket::INET; |
376 | |
377 | use strict; |
7a4c00b4 |
378 | use vars qw(@ISA); |
8add82fc |
379 | use Socket; |
380 | use Carp; |
381 | use Exporter; |
382 | |
383 | @ISA = qw(IO::Socket); |
384 | |
27d4819a |
385 | IO::Socket::INET->register_domain( AF_INET ); |
386 | |
8add82fc |
387 | my %socket_type = ( tcp => SOCK_STREAM, |
388 | udp => SOCK_DGRAM, |
8251ff82 |
389 | icmp => SOCK_RAW, |
8add82fc |
390 | ); |
391 | |
392 | =head2 IO::Socket::INET |
393 | |
394 | C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket |
395 | and some related methods. The constructor can take the following options |
396 | |
2085bf88 |
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 |
405 | Timeout Timeout value for various operations |
406 | |
27d4819a |
407 | |
7a4c00b4 |
408 | If C<Listen> is defined then a listen socket is created, else if the |
409 | socket type, which is derived from the protocol, is SOCK_STREAM then |
410 | connect() is called. |
411 | |
412 | The 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 |
414 | service name. The service name might be followed by a number in |
415 | parenthesis which is used if the service is not known by the system. |
416 | The C<PeerPort> specification can also be embedded in the C<PeerAddr> |
417 | by preceding it with a ":". |
418 | |
e713eafe |
419 | If C<Proto> is not given and you specify a symbolic C<PeerPort> port, |
420 | then the constructor will try to derive C<Proto> from the service |
421 | name. As a last resort C<Proto> "tcp" is assumed. The C<Type> |
422 | parameter will be deduced from C<Proto> if not specified. |
423 | |
424 | If the constructor is only passed a single argument, it is assumed to |
425 | be a C<PeerAddr> specification. |
8add82fc |
426 | |
7a4c00b4 |
427 | Examples: |
428 | |
429 | $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', |
8cc95fdb |
430 | PeerPort => 'http(80)', |
7a4c00b4 |
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 |
440 | $sock = IO::Socket::INET->new('127.0.0.1:25'); |
441 | |
442 | |
8add82fc |
443 | =head2 METHODS |
444 | |
27d4819a |
445 | =over 4 |
446 | |
447 | =item sockaddr () |
8add82fc |
448 | |
449 | Return the address part of the sockaddr structure for the socket |
450 | |
27d4819a |
451 | =item sockport () |
8add82fc |
452 | |
453 | Return the port number that the socket is using on the local host |
454 | |
27d4819a |
455 | =item sockhost () |
8add82fc |
456 | |
457 | Return the address part of the sockaddr structure for the socket in a |
458 | text form xx.xx.xx.xx |
459 | |
27d4819a |
460 | =item peeraddr () |
461 | |
462 | Return the address part of the sockaddr structure for the socket on |
463 | the peer host |
464 | |
465 | =item peerport () |
466 | |
467 | Return the port number for the socket on the peer host. |
8add82fc |
468 | |
27d4819a |
469 | =item peerhost () |
470 | |
471 | Return the address part of the sockaddr structure for the socket on the |
472 | peer host in a text form xx.xx.xx.xx |
473 | |
474 | =back |
8add82fc |
475 | |
476 | =cut |
477 | |
e713eafe |
478 | sub new |
479 | { |
480 | my $class = shift; |
481 | unshift(@_, "PeerAddr") if @_ == 1; |
482 | return $class->SUPER::new(@_); |
483 | } |
484 | |
8add82fc |
485 | sub _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 |
521 | sub _error { |
522 | my $fh = shift; |
7a4c00b4 |
523 | $@ = join("",ref($fh),": ",@_); |
524 | carp $@ if $^W; |
27d4819a |
525 | close($fh) |
526 | if(defined fileno($fh)); |
527 | return undef; |
528 | } |
529 | |
8add82fc |
530 | sub 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 |
542 | return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'") |
543 | unless(defined $laddr); |
544 | |
8add82fc |
545 | unless(exists $arg->{Listen}) { |
546 | ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, |
547 | $arg->{PeerPort}, |
548 | $proto); |
549 | } |
550 | |
27d4819a |
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 |
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 |
565 | return _error($fh,"$!"); |
566 | |
567 | if ($arg->{Reuse}) { |
568 | $fh->sockopt(SO_REUSEADDR,1) or |
569 | return _error($fh); |
570 | } |
8add82fc |
571 | |
572 | $fh->bind($lport || 0, $laddr) or |
7a4c00b4 |
573 | return _error($fh,"$!"); |
8add82fc |
574 | |
575 | if(exists $arg->{Listen}) { |
576 | $fh->listen($arg->{Listen} || 5) or |
7a4c00b4 |
577 | return _error($fh,"$!"); |
8add82fc |
578 | } |
579 | else { |
27d4819a |
580 | return _error($fh,'Cannot determine remote port') |
8251ff82 |
581 | unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); |
8add82fc |
582 | |
583 | if($type == SOCK_STREAM || defined $raddr) { |
27d4819a |
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 |
589 | } |
590 | } |
591 | |
592 | $fh; |
593 | } |
594 | |
595 | sub sockaddr { |
596 | @_ == 1 or croak 'usage: $fh->sockaddr()'; |
597 | my($fh) = @_; |
598 | (sockaddr_in($fh->sockname))[1]; |
599 | } |
600 | |
601 | sub sockport { |
602 | @_ == 1 or croak 'usage: $fh->sockport()'; |
603 | my($fh) = @_; |
604 | (sockaddr_in($fh->sockname))[0]; |
605 | } |
606 | |
607 | sub sockhost { |
608 | @_ == 1 or croak 'usage: $fh->sockhost()'; |
609 | my($fh) = @_; |
610 | inet_ntoa($fh->sockaddr); |
611 | } |
612 | |
613 | sub peeraddr { |
614 | @_ == 1 or croak 'usage: $fh->peeraddr()'; |
615 | my($fh) = @_; |
616 | (sockaddr_in($fh->peername))[1]; |
617 | } |
618 | |
619 | sub peerport { |
620 | @_ == 1 or croak 'usage: $fh->peerport()'; |
621 | my($fh) = @_; |
622 | (sockaddr_in($fh->peername))[0]; |
623 | } |
624 | |
625 | sub peerhost { |
626 | @_ == 1 or croak 'usage: $fh->peerhost()'; |
627 | my($fh) = @_; |
628 | inet_ntoa($fh->peeraddr); |
629 | } |
630 | |
631 | ## |
632 | ## AF_UNIX |
633 | ## |
634 | |
635 | package IO::Socket::UNIX; |
636 | |
637 | use strict; |
638 | use vars qw(@ISA $VERSION); |
639 | use Socket; |
640 | use Carp; |
641 | use Exporter; |
642 | |
643 | @ISA = qw(IO::Socket); |
644 | |
27d4819a |
645 | IO::Socket::UNIX->register_domain( AF_UNIX ); |
646 | |
8add82fc |
647 | =head2 IO::Socket::UNIX |
648 | |
649 | C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket |
650 | and 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 |
659 | =over 4 |
660 | |
8add82fc |
661 | =item hostpath() |
662 | |
7a4c00b4 |
663 | Returns the pathname to the fifo at the local end |
8add82fc |
664 | |
665 | =item peerpath() |
666 | |
7a4c00b4 |
667 | Returns the pathanme to the fifo at the peer end |
27d4819a |
668 | |
669 | =back |
8add82fc |
670 | |
671 | =cut |
672 | |
673 | sub 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 | |
700 | sub hostpath { |
701 | @_ == 1 or croak 'usage: $fh->hostpath()'; |
27d4819a |
702 | my $n = $_[0]->sockname || return undef; |
27d4819a |
703 | (sockaddr_un($n))[0]; |
8add82fc |
704 | } |
705 | |
706 | sub peerpath { |
707 | @_ == 1 or croak 'usage: $fh->peerpath()'; |
27d4819a |
708 | my $n = $_[0]->peername || return undef; |
27d4819a |
709 | (sockaddr_un($n))[0]; |
8add82fc |
710 | } |
711 | |
7a4c00b4 |
712 | =head1 SEE ALSO |
8add82fc |
713 | |
7a4c00b4 |
714 | L<Socket>, L<IO::Handle> |
8add82fc |
715 | |
7a4c00b4 |
716 | =head1 AUTHOR |
8add82fc |
717 | |
7a4c00b4 |
718 | Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> |
760ac839 |
719 | |
8add82fc |
720 | =head1 COPYRIGHT |
721 | |
774d564b |
722 | Copyright (c) 1996 Graham Barr. All rights reserved. This program is free |
8add82fc |
723 | software; you can redistribute it and/or modify it under the same terms |
724 | as Perl itself. |
725 | |
726 | =cut |
727 | |
728 | 1; # Keep require happy |