--- /dev/null
+#
+
+package IO;
+
+use IO::Handle;
+use IO::Seekable;
+use IO::File;
+use IO::Pipe;
+use IO::Socket;
+
+1;
+
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+
+typedef int SysRet;
+typedef FILE * InputStream;
+typedef FILE * OutputStream;
+
+static int
+not_here(s)
+char *s;
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static bool
+constant(name, pval)
+char *name;
+IV *pval;
+{
+ switch (*name) {
+ case '_':
+ if (strEQ(name, "_IOFBF"))
+#ifdef _IOFBF
+ { *pval = _IOFBF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "_IOLBF"))
+#ifdef _IOLBF
+ { *pval = _IOLBF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "_IONBF"))
+#ifdef _IONBF
+ { *pval = _IONBF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ break;
+ case 'S':
+ if (strEQ(name, "SEEK_SET"))
+#ifdef SEEK_SET
+ { *pval = SEEK_SET; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "SEEK_CUR"))
+#ifdef SEEK_CUR
+ { *pval = SEEK_CUR; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "SEEK_END"))
+#ifdef SEEK_END
+ { *pval = SEEK_END; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "SEEK_EOF"))
+#ifdef SEEK_EOF
+ { *pval = SEEK_EOF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ break;
+ }
+
+ return FALSE;
+}
+
+
+MODULE = IO PACKAGE = IO::Seekable PREFIX = f
+
+SV *
+fgetpos(handle)
+ InputStream handle
+ CODE:
+#ifdef HAS_FGETPOS
+ if (handle) {
+ Fpos_t pos;
+ fgetpos(handle, &pos);
+ ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
+ }
+ else {
+ ST(0) = &sv_undef;
+ errno = EINVAL;
+ }
+#else
+ ST(0) = (SV *) not_here("IO::Seekable::fgetpos");
+#endif
+
+SysRet
+fsetpos(handle, pos)
+ InputStream handle
+ SV * pos
+ CODE:
+#ifdef HAS_FSETPOS
+ if (handle)
+ RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos));
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+#else
+ RETVAL = (SysRet) not_here("IO::Seekable::fsetpos");
+#endif
+ OUTPUT:
+ RETVAL
+
+MODULE = IO PACKAGE = IO::File PREFIX = f
+
+OutputStream
+new_tmpfile(packname = "IO::File")
+ char * packname
+ CODE:
+ RETVAL = tmpfile();
+ OUTPUT:
+ RETVAL
+
+MODULE = IO PACKAGE = IO::Handle PREFIX = f
+
+SV *
+constant(name)
+ char * name
+ CODE:
+ IV i;
+ if (constant(name, &i))
+ ST(0) = sv_2mortal(newSViv(i));
+ else
+ ST(0) = &sv_undef;
+
+int
+ungetc(handle, c)
+ InputStream handle
+ int c
+ CODE:
+ if (handle)
+ RETVAL = ungetc(c, handle);
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+ferror(handle)
+ InputStream handle
+ CODE:
+ if (handle)
+ RETVAL = ferror(handle);
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+SysRet
+fflush(handle)
+ OutputStream handle
+ CODE:
+ if (handle)
+ RETVAL = Fflush(handle);
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+void
+setbuf(handle, buf)
+ OutputStream handle
+ char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
+ CODE:
+ if (handle)
+ setbuf(handle, buf);
+
+
+
+SysRet
+setvbuf(handle, buf, type, size)
+ OutputStream handle
+ char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+ int type
+ int size
+ CODE:
+#ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */
+ if (handle)
+ RETVAL = setvbuf(handle, buf, type, size);
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+#else
+ RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
+#endif /* _IOFBF */
+ OUTPUT:
+ RETVAL
+
+
--- /dev/null
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'IO',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'lib/IO/Handle.pm',
+);
--- /dev/null
+#
+
+package IO::File;
+
+=head1 NAME
+
+IO::File - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+ use IO::File;
+
+ $fh = new IO::File;
+ if ($fh->open "< file") {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new IO::File "> FOO";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new IO::File "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new IO::File "file", O_WRONLY|O_APPEND;
+ if (defined $fh) {
+ print $fh "corge\n";
+ undef $fh; # automatically closes the file
+ }
+
+ $pos = $fh->getpos;
+ $fh->setpos $pos;
+
+ $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::File::new> creates a C<IO::File>, which is a reference to a
+newly created symbol (see the C<Symbol> package). If it receives any
+parameters, they are passed to C<IO::File::open>; if the open fails,
+the C<IO::File> object is destroyed. Otherwise, it is returned to
+the caller.
+
+C<IO::File::open> accepts one parameter or two. With one parameter,
+it is just a front end for the built-in C<open> function. With two
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode in either Perl form (">", "+<", etc.) or POSIX form
+("w", "r+", etc.).
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<"IO::Handle">
+L<"IO::Seekable">
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.3 $
+
+=cut
+
+require 5.000;
+use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+use Symbol;
+use English;
+use SelectSaver;
+use IO::Handle qw(_open_mode_string);
+use IO::Seekable;
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);
+
+@EXPORT = @IO::Seekable::EXPORT;
+
+################################################
+## If the Fcntl extension is available,
+## export its constants.
+##
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ Exporter::export $pkg, $callpkg;
+ eval {
+ require Fcntl;
+ Exporter::export 'Fcntl', $callpkg;
+ };
+};
+
+
+################################################
+## Constructor
+##
+
+sub new {
+ @_ >= 1 && @_ <= 3 or croak 'usage: new IO::File [FILENAME [,MODE]]';
+ my $class = shift;
+ my $fh = $class->SUPER::new();
+ if (@_) {
+ $fh->open(@_)
+ or return undef;
+ }
+ $fh;
+}
+
+################################################
+## Open
+##
+
+sub open {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
+ my ($fh, $file) = @_;
+ if (@_ > 2) {
+ my ($mode, $perms) = @_[2, 3];
+ if ($mode =~ /^\d+$/) {
+ defined $perms or $perms = 0666;
+ return sysopen($fh, $file, $mode, $perms);
+ }
+ $file = "./" . $file unless $file =~ m#^/#;
+ $file = _open_mode_string($mode) . " $file\0";
+ }
+ open($fh, $file);
+}
+
+1;
--- /dev/null
+#
+
+package IO::Handle;
+
+=head1 NAME
+
+IO::Handle - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+ use IO::Handle;
+
+ $fh = new IO::Handle;
+ if ($fh->open "< file") {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new IO::Handle "> FOO";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new IO::Handle "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new IO::Handle "file", O_WRONLY|O_APPEND;
+ if (defined $fh) {
+ print $fh "corge\n";
+ undef $fh; # automatically closes the file
+ }
+
+ $pos = $fh->getpos;
+ $fh->setpos $pos;
+
+ $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::Handle::new> creates a C<IO::Handle>, which is a reference to a
+newly created symbol (see the C<Symbol> package). If it receives any
+parameters, they are passed to C<IO::Handle::open>; if the open fails,
+the C<IO::Handle> object is destroyed. Otherwise, it is returned to
+the caller.
+
+C<IO::Handle::new_from_fd> creates a C<IO::Handle> like C<new> does.
+It requires two parameters, which are passed to C<IO::Handle::fdopen>;
+if the fdopen fails, the C<IO::Handle> object is destroyed.
+Otherwise, it is returned to the caller.
+
+C<IO::Handle::open> accepts one parameter or two. With one parameter,
+it is just a front end for the built-in C<open> function. With two
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode in either Perl form (">", "+<", etc.) or POSIX form
+("w", "r+", etc.).
+
+C<IO::Handle::fdopen> is like C<open> except that its first parameter
+is not a filename but rather a file handle name, a IO::Handle object,
+or a file descriptor number.
+
+C<IO::Handle::write> is like C<write> found in C, that is it is the
+opposite of read. The wrapper for the perl C<write> function is
+called C<format_write>.
+
+C<IO::Handle::opened> returns true if the object is currently a valid
+file descriptor.
+
+If the C functions fgetpos() and fsetpos() are available, then
+C<IO::Handle::getpos> returns an opaque value that represents the
+current position of the IO::Handle, and C<IO::Handle::setpos> uses
+that value to return to a previously visited position.
+
+If the C function setvbuf() is available, then C<IO::Handle::setvbuf>
+sets the buffering policy for the IO::Handle. The calling sequence
+for the Perl function is the same as its C counterpart, including the
+macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
+parameter specifies a scalar variable to use as a buffer. WARNING: A
+variable used as a buffer by C<IO::Handle::setvbuf> must not be
+modified in any way until the IO::Handle is closed or until
+C<IO::Handle::setvbuf> is called again, or memory corruption may
+result!
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Handle> methods, which are just front ends for the
+corresponding built-in functions:
+
+ close
+ fileno
+ getc
+ gets
+ eof
+ read
+ truncate
+ stat
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<IO::Handle> methods:
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+Furthermore, for doing normal I/O you might need these:
+
+=over
+
+=item $fh->print
+
+See L<perlfunc/print>.
+
+=item $fh->printf
+
+See L<perlfunc/printf>.
+
+=item $fh->getline
+
+This works like <$fh> described in L<perlop/"I/O Operators">
+except that it's more readable and can be safely called in an
+array context but still returns just one line.
+
+=item $fh->getlines
+
+This works like <$fh> when called in an array context to
+read all the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=back
+
+=head1
+
+The reference returned from new is a GLOB reference. Some modules that
+inherit from C<IO::Handle> may want to keep object related variables
+in the hash table part of the GLOB. In an attempt to prevent modules
+trampling on each other I propose the that any such module should prefix
+its variables with its own name separated by _'s. For example the IO::Socket
+module keeps a C<timeout> variable in 'io_socket_timeout'.
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<POSIX/"FileHandle">
+
+=head1 BUGS
+
+Due to backwards compatibility, all filehandles resemble objects
+of class C<IO::Handle>, or actually classes derived from that class.
+They actually aren't. Which means you can't derive your own
+class from C<IO::Handle> and inherit those methods.
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+
+=cut
+
+require 5.000;
+use vars qw($VERSION @EXPORT_OK $AUTOLOAD);
+use Carp;
+use Symbol;
+use SelectSaver;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+##
+## TEMPORARY workaround as perl expects handles to be <FileHandle> objects
+##
+@FileHandle::ISA = qw(IO::Handle);
+
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/);
+
+@EXPORT_OK = qw(
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+ print
+ printf
+ getline
+ getlines
+
+ SEEK_SET
+ SEEK_CUR
+ SEEK_END
+ _IOFBF
+ _IOLBF
+ _IONBF
+
+ _open_mode_string
+);
+
+
+################################################
+## Interaction with the XS.
+##
+
+require DynaLoader;
+@IO::ISA = qw(DynaLoader);
+bootstrap IO $VERSION;
+
+sub AUTOLOAD {
+ if ($AUTOLOAD =~ /::(_?[a-z])/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD
+ }
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ my $val = constant($constname);
+ defined $val or croak "$constname is not a valid IO::Handle macro";
+ *$AUTOLOAD = sub { $val };
+ goto &$AUTOLOAD;
+}
+
+
+################################################
+## Constructors, destructors.
+##
+
+sub new {
+ @_ == 1 or croak 'usage: new IO::Handle';
+ my $class = ref($_[0]) || $_[0];
+ my $fh = gensym;
+ bless $fh, $class;
+}
+
+sub new_from_fd {
+ @_ == 3 or croak 'usage: new_from_fd IO::Handle FD, MODE';
+ my $class = shift;
+ my $fh = gensym;
+ IO::Handle::fdopen($fh, @_)
+ or return undef;
+ bless $fh, $class;
+ $fh->_ref_fd;
+ $fh;
+}
+
+# FileHandle::DESTROY use to call close(). This creates a problem
+# if 2 Handle objects have the same fd. sv_clear will call io close
+# when the refcount in the xpvio becomes zero.
+#
+# It is defined as empty to stop AUTOLOAD being called :-)
+
+sub DESTROY { }
+
+################################################
+## Open and close.
+##
+
+sub _open_mode_string {
+ my ($mode) = @_;
+ $mode =~ /^\+?(<|>>?)$/
+ or $mode =~ s/^r(\+?)$/$1</
+ or $mode =~ s/^w(\+?)$/$1>/
+ or $mode =~ s/^a(\+?)$/$1>>/
+ or croak "IO::Handle: bad open mode: $mode";
+ $mode;
+}
+
+sub fdopen {
+ @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
+ my ($fh, $fd, $mode) = @_;
+ local(*GLOB);
+
+ if (ref($fd) && "".$fd =~ /GLOB\(/o) {
+ # It's a glob reference; Alias it as we cannot get name of anon GLOBs
+ my $n = qualify(*GLOB);
+ *GLOB = *{*$fd};
+ $fd = $n;
+ } elsif ($fd =~ m#^\d+$#) {
+ # It's an FD number; prefix with "=".
+ $fd = "=$fd";
+ }
+
+ open($fh, _open_mode_string($mode) . '&' . $fd)
+ ? $fh : undef;
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $fh->close()';
+ my($fh) = @_;
+ my $r = close($fh);
+
+ # This may seem as though it should be in IO::Pipe, but the
+ # object gets blessed out of IO::Pipe when reader/writer is called
+ waitpid(${*$fh}{'io_pipe_pid'},0)
+ if(defined ${*$fh}{'io_pipe_pid'});
+
+ $r;
+}
+
+################################################
+## Normal I/O functions.
+##
+
+# fcntl
+# flock
+# ioctl
+# select
+# sysread
+# syswrite
+
+sub opened {
+ @_ == 1 or croak 'usage: $fh->opened()';
+ defined fileno($_[0]);
+}
+
+sub fileno {
+ @_ == 1 or croak 'usage: $fh->fileno()';
+ fileno($_[0]);
+}
+
+sub getc {
+ @_ == 1 or croak 'usage: $fh->getc()';
+ getc($_[0]);
+}
+
+sub gets {
+ @_ == 1 or croak 'usage: $fh->gets()';
+ my ($handle) = @_;
+ scalar <$handle>;
+}
+
+sub eof {
+ @_ == 1 or croak 'usage: $fh->eof()';
+ eof($_[0]);
+}
+
+sub print {
+ @_ or croak 'usage: $fh->print([ARGS])';
+ my $this = shift;
+ print $this @_;
+}
+
+sub printf {
+ @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+ my $this = shift;
+ printf $this @_;
+}
+
+sub getline {
+ @_ == 1 or croak 'usage: $fh->getline';
+ my $this = shift;
+ return scalar <$this>;
+}
+
+sub getlines {
+ @_ == 1 or croak 'usage: $fh->getline()';
+ my $this = shift;
+ wantarray or
+ croak "Can't call IO::Handle::getlines in a scalar context, use IO::Handle::getline";
+ return <$this>;
+}
+
+sub truncate {
+ @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+ truncate($_[0], $_[1]);
+}
+
+sub read {
+ @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+ read($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub write {
+ @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+ local($\) = "";
+ print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
+}
+
+sub stat {
+ @_ == 1 or croak 'usage: $fh->stat()';
+ stat($_[0]);
+}
+
+################################################
+## State modification functions.
+##
+
+sub autoflush {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $|;
+ $| = @_ > 1 ? $_[1] : 1;
+ $prev;
+}
+
+sub output_field_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $,;
+ $, = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub output_record_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $\;
+ $\ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_record_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $/;
+ $/ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_line_number {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $.;
+ $. = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_page_number {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $%;
+ $% = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_per_page {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $=;
+ $= = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_left {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $-;
+ $- = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_name {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $~;
+ $~ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_top_name {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $^;
+ $^ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_line_break_characters {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $:;
+ $: = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_formfeed {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $^L;
+ $^L = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub formline {
+ my $fh = shift;
+ my $picture = shift;
+ local($^A) = $^A;
+ local($\) = "";
+ formline($picture, @_);
+ print $fh $^A;
+}
+
+sub format_write {
+ @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+ if (@_ == 2) {
+ my ($fh, $fmt) = @_;
+ my $oldfmt = $fh->format_name($fmt);
+ write($fh);
+ $fh->format_name($oldfmt);
+ } else {
+ write($_[0]);
+ }
+}
+
+
+1;
--- /dev/null
+#
+
+package IO::Pipe;
+
+=head1 NAME
+
+IO::pipe - supply object methods for pipes
+
+=head1 SYNOPSIS
+
+ use IO::Pipe;
+
+ $pipe = new IO::Pipe;
+
+ if($pid = fork()) { # Parent
+ $pipe->reader();
+
+ while(<$pipe> {
+ ....
+ }
+
+ }
+ elsif(defined $pid) { # Child
+ $pipe->writer();
+
+ print $pipe ....
+ }
+
+ or
+
+ $pipe = new IO::Pipe;
+
+ $pipe->reader(qw(ls -l));
+
+ while(<$pipe>) {
+ ....
+ }
+
+=head1 DESCRIPTION
+
+C<IO::Pipe::new> creates a C<IO::Pipe>, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<IO::Pipe::new>
+optionally takes two arguments, which should be objects blessed into
+C<IO::Handle>, or a subclass thereof. These two objects will be used
+for the system call to C<pipe>. If no arguments are given then then
+method C<handles> is called on the new C<IO::Pipe> object.
+
+These two handles are held in the array part of the GLOB untill either
+C<reader> or C<writer> is called.
+
+=over
+
+=item $fh->reader([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item $fh->writer([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item $fh->handles
+
+This method is called during construction by C<IO::Pipe::new>
+on the newly created C<IO::Pipe> object. It returns an array of two objects
+blessed into C<IO::Handle>, or a subclass thereof.
+
+=back
+
+=head1 SEE ALSO
+
+L<IO::Handle>
+
+=head1 AUTHOR
+
+Graham Barr <bodg@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.4 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+require 5.000;
+use vars qw($VERSION);
+use Carp;
+use Symbol;
+require IO::Handle;
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+
+sub new {
+ @_ == 1 || @_ == 3 or croak 'usage: new IO::Pipe([$READFH, $WRITEFH])';
+
+ my $me = bless gensym(), shift;
+
+ my($readfh,$writefh) = @_ ? @_ : $me->handles;
+
+ pipe($readfh, $writefh)
+ or return undef;
+
+ @{*$me} = ($readfh, $writefh);
+
+ $me;
+}
+
+sub handles {
+ @_ == 1 or croak 'usage: $pipe->handles()';
+ (IO::Handle->new(), IO::Handle->new());
+}
+
+sub _doit {
+ my $me = shift;
+ my $rw = shift;
+
+ my $pid = fork();
+
+ if($pid) { # Parent
+ return $pid;
+ }
+ elsif(defined $pid) { # Child
+ my $fh = $rw ? $me->reader() : $me->writer();
+ my $io = $rw ? \*STDIN : \*STDOUT;
+
+ bless $io, "IO::Handle";
+ $io->fdopen($fh, $rw ? "r" : "w");
+ exec @_ or
+ croak "IO::Pipe: Cannot exec: $!";
+ }
+ else {
+ croak "IO::Pipe: Cannot fork: $!";
+ }
+
+ # NOT Reached
+}
+
+sub reader {
+ @_ >= 1 or croak 'usage: $pipe->reader()';
+ my $me = shift;
+ my $fh = ${*$me}[0];
+ my $pid = $me->_doit(0,@_)
+ if(@_);
+
+ bless $me, ref($fh);
+ *{*$me} = *{*$fh}; # Alias self to handle
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+}
+
+sub writer {
+ @_ >= 1 or croak 'usage: $pipe->writer()';
+ my $me = shift;
+ my $fh = ${*$me}[1];
+ my $pid = $me->_doit(1,@_)
+ if(@_);
+
+ bless $me, ref($fh);
+ *{*$me} = *{*$fh}; # Alias self to handle
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+}
+
+1;
+
--- /dev/null
+#
+
+package IO::Seekable;
+
+=head1 NAME
+
+IO::Seekable - supply seek based methods for I/O objects
+
+=head1 DESCRIPTION
+
+C<IO::Seekable> does not have a constuctor of its own as is intended to
+be inherited by other C<IO::Handle> based objects. It provides methods
+which allow seeking of the file descriptors.
+
+If the C functions fgetpos() and fsetpos() are available, then
+C<IO::File::getpos> returns an opaque value that represents the
+current position of the IO::File, and C<IO::File::setpos> uses
+that value to return to a previously visited position.
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Seekable> methods, which are just front ends for the
+corresponding built-in functions:
+
+ clearerr
+ seek
+ tell
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<"IO::Handle">
+L<"IO::File">
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.4 $
+
+=cut
+
+require 5.000;
+use Carp;
+use vars qw($VERSION @EXPORT @ISA);
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+require Exporter;
+
+@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
+@ISA = qw(Exporter);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+
+sub clearerr {
+ @_ == 1 or croak 'usage: $fh->clearerr()';
+ seek($_[0], 0, SEEK_CUR);
+}
+
+sub seek {
+ @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+ seek($_[0], $_[1], $_[2]);
+}
+
+sub tell {
+ @_ == 1 or croak 'usage: $fh->tell()';
+ tell($_[0]);
+}
+
+1;
--- /dev/null
+# IO::Select.pm
+
+package IO::Select;
+
+=head1 NAME
+
+IO::Select - OO interface to the system select call
+
+=head1 SYNOPSYS
+
+ use IO::Select;
+
+ $s = IO::Select->new();
+
+ $s->add(\*STDIN);
+ $s->add($some_handle);
+
+ @ready = $s->can_read($timeout);
+
+ @ready = IO::Select->new(@handles)->read(0);
+
+=head1 DESCRIPTION
+
+The C<IO::Select> package implements an object approach to the system C<select>
+function call. It allows the user to see what IO handles, see L<IO::Handle>,
+are ready for reading, writing or have an error condition pending.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HANDLES ] )
+
+The constructor create a new object and optionally initialises it with a set
+of handles.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item add ( HANDLES )
+
+Add the list of handles to the C<IO::Select> object. It is these values that
+will be returned when an event occurs. C<IO::Select> keeps these values in a
+cache which is indexed by the C<fileno> of the handle, so if more than one
+handle with the same C<fileno> is specified then only the last one is cached.
+
+=item remove ( HANDLES )
+
+Remove all the given handles from the object.
+
+=item can_read ( [ TIMEOUT ] )
+
+Return an array of handles that are ready for reading. C<TIMEOUT> is the maximum
+amount of time to wait before returning an empty list. If C<TIMEOUT> is
+not given then the call will block.
+
+=item can_write ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that can be written to.
+
+=item has_error ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that have an error condition, for
+example EOF.
+
+=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
+
+C<select> is a static method, that is you call it with the package name
+like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> or
+C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
+before.
+
+The result will be an array of 3 elements, each a reference to an array
+which will hold the handles that are ready for reading, writing and have
+error conditions respectively. Upon error an empty array is returned.
+
+=back
+
+=head1 EXAMPLE
+
+Here is a short example which shows how C<IO::Select> could be used
+to write a server which communicates with several sockets while also
+listening for more connections on a listen socket
+
+ use IO::Select;
+ use IO::Socket;
+
+ $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+ $sel = new IO::Select( $lsn );
+
+ while(@ready = $sel->can_read) {
+ foreach $fh (@ready) {
+ if($fh == $lsn) {
+ # Create a new socket
+ $new = $lsn->accept;
+ $sel->add($new);
+ }
+ else {
+ # Process socket
+
+ # Maybe we have finished with the socket
+ $sel->remove($fh);
+ $fh->close;
+ }
+ }
+ }
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.2 $
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use strict;
+use vars qw($VERSION @ISA);
+require Exporter;
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
+
+@ISA = qw(Exporter); # This is only so we can do version checking
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+
+ my $vec = bless [''], $type;
+
+ $vec->add(@_)
+ if @_;
+
+ $vec;
+}
+
+sub add
+{
+ my $vec = shift;
+ my $f;
+
+ foreach $f (@_)
+ {
+ my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
+ next
+ unless defined $fn;
+ vec($vec->[0],$fn++,1) = 1;
+ $vec->[$fn] = $f;
+ }
+}
+
+sub remove
+{
+ my $vec = shift;
+ my $f;
+
+ foreach $f (@_)
+ {
+ my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
+ next
+ unless defined $fn;
+ vec($vec->[0],$fn++,1) = 0;
+ $vec->[$fn] = undef;
+ }
+}
+
+sub can_read
+{
+ my $vec = shift;
+ my $timeout = shift;
+
+ my $r = $vec->[0];
+
+ select($r,undef,undef,$timeout) > 0
+ ? _handles($vec, $r)
+ : ();
+}
+
+sub can_write
+{
+ my $vec = shift;
+ my $timeout = shift;
+
+ my $w = $vec->[0];
+
+ select(undef,$w,undef,$timeout) > 0
+ ? _handles($vec, $w)
+ : ();
+}
+
+sub has_error
+{
+ my $vec = shift;
+ my $timeout = shift;
+
+ my $e = $vec->[0];
+
+ select(undef,undef,$e,$timeout) > 0
+ ? _handles($vec, $e)
+ : ();
+}
+
+sub _max
+{
+ my($a,$b,$c) = @_;
+ $a > $b
+ ? $a > $c
+ ? $a
+ : $c
+ : $b > $c
+ ? $b
+ : $c;
+}
+
+sub select
+{
+ shift
+ if defined $_[0] && !ref($_[0]);
+
+ my($r,$w,$e,$t) = @_;
+ my @result = ();
+
+ my $rb = defined $r ? $r->[0] : undef;
+ my $wb = defined $w ? $e->[0] : undef;
+ my $eb = defined $e ? $w->[0] : undef;
+
+ if(select($rb,$wb,$eb,$t) > 0)
+ {
+ my @r = ();
+ my @w = ();
+ my @e = ();
+ my $i = _max(defined $r ? scalar(@$r) : 0,
+ defined $w ? scalar(@$w) : 0,
+ defined $e ? scalar(@$e) : 0);
+
+ for( ; $i > 0 ; $i--)
+ {
+ my $j = $i - 1;
+ push(@r, $r->[$i])
+ if defined $r->[$i] && vec($rb, $j, 1);
+ push(@w, $w->[$i])
+ if defined $w->[$i] && vec($wb, $j, 1);
+ push(@e, $e->[$i])
+ if defined $e->[$i] && vec($eb, $j, 1);
+ }
+
+ @result = (\@r, \@w, \@e);
+ }
+ @result;
+}
+
+sub _handles
+{
+ my $vec = shift;
+ my $bits = shift;
+ my @h = ();
+ my $i;
+
+ for($i = scalar(@$vec) - 1 ; $i > 0 ; $i--)
+ {
+ next unless defined $vec->[$i];
+ push(@h, $vec->[$i])
+ if vec($bits,$i - 1,1);
+ }
+
+ @h;
+}
+
+1;
--- /dev/null
+#
+
+package IO::Socket;
+
+=head1 NAME
+
+IO::Socket - supply object methods for sockets
+
+=head1 SYNOPSIS
+
+ use IO::Socket;
+
+=head1 DESCRIPTION
+
+C<IO::Socket> provides an object interface to creating and using sockets. It
+is built upon the L<IO::Handle> interface and inherits all the methods defined
+by L<IO::Handle>.
+
+C<IO::Socket> only defines methods for those operations which are common to all
+types of socket. Operations which are specified to a socket in a particular
+domain have methods defined in sub classes of C<IO::Socket>
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Seekable> methods, which are just front ends for the
+corresponding built-in functions:
+
+ socket
+ socketpair
+ bind
+ listen
+ accept
+ send
+ recv
+ peername (getpeername)
+ sockname (getsockname)
+
+Some methods take slightly different arguments to those defined in L<perlfunc>
+in attempt to make the interface more flexible. These are
+
+=item accept([PKG])
+
+perform the system call C<accept> on the socket and return a new object. The
+new object will be created in the same class as the listen socket, unless
+C<PKG> is specified. This object can be used to communicate with the client
+that was trying to connect. In a scalar context the new socket is returned,
+or undef upon failure. In an array context a two-element array is returned
+containing the new socket and the peer address, the list will
+be empty upon failure.
+
+Additional methods that are provided are
+
+=item timeout([VAL])
+
+Set or get the timeout value associated with this socket. If called without
+any arguments then the current setting is returned. If called with an argument
+the current setting is changed and the previous value returned.
+
+=item sockopt(OPT [, VAL])
+
+Unified method to both set and get options in the SOL_SOCKET level. If called
+with one argument then getsockopt is called, otherwise setsockopt is called
+
+=cut
+
+
+require 5.000;
+
+use Config;
+use IO::Handle;
+use Socket 1.3;
+use Carp;
+use strict;
+use vars qw(@ISA @EXPORT_OK $VERSION);
+use Exporter;
+
+@ISA = qw(IO::Handle);
+
+# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
+$VERSION = do{my @r=(q$Revision: 1.8$=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ Exporter::export 'Socket', $callpkg, @_;
+}
+
+sub new {
+ my($class,%arg) = @_;
+ my $fh = $class->SUPER::new();
+
+ ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+
+ return scalar(%arg) ? $fh->configure(\%arg)
+ : $fh;
+}
+
+sub configure {
+ croak 'IO::Socket: Cannot configure a generic socket';
+}
+
+sub socket {
+ @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
+ my($fh,$domain,$type,$protocol) = @_;
+
+ socket($fh,$domain,$type,$protocol) or
+ return undef;
+
+ ${*$fh}{'io_socket_type'} = $type;
+ $fh;
+}
+
+sub socketpair {
+ @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
+ my($class,$domain,$type,$protocol) = @_;
+ my $fh1 = $class->new();
+ my $fh2 = $class->new();
+
+ socketpair($fh1,$fh1,$domain,$type,$protocol) or
+ return ();
+
+ ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
+
+ ($fh1,$fh2);
+}
+
+sub connect {
+ @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
+ my $fh = shift;
+ my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+ my $timeout = ${*$fh}{'io_socket_timeout'};
+ local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
+ : $SIG{ALRM} || 'DEFAULT';
+
+ eval {
+ croak 'connect: Bad address'
+ if(@_ == 2 && !defined $_[1]);
+
+ if($timeout) {
+ defined $Config{d_alarm} && defined alarm($timeout) or
+ $timeout = 0;
+ }
+
+ my $ok = eval { connect($fh, $addr) };
+
+ alarm(0)
+ if($timeout);
+
+ croak "connect: timeout"
+ unless defined $fh;
+
+ undef $fh unless $ok;
+
+ };
+ $fh;
+}
+
+sub bind {
+ @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
+ my $fh = shift;
+ my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+
+ return bind($fh, $addr) ? $fh
+ : undef;
+}
+
+sub listen {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
+ my($fh,$queue) = @_;
+ $queue = 5
+ unless $queue && $queue > 0;
+
+ return listen($fh, $queue) ? $fh
+ : undef;
+}
+
+sub accept {
+ @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
+ my $fh = shift;
+ my $pkg = shift || $fh;
+ my $timeout = ${*$fh}{'io_socket_timeout'};
+ my $new = $pkg->new(Timeout => $timeout);
+ my $peer = undef;
+
+ eval {
+ if($timeout) {
+ my $fdset = "";
+ vec($fdset, $fh->fileno,1) = 1;
+ croak "accept: timeout"
+ unless select($fdset,undef,undef,$timeout);
+ }
+ $peer = accept($new,$fh);
+ };
+
+ return wantarray ? defined $peer ? ($new, $peer)
+ : ()
+ : defined $peer ? $new
+ : undef;
+}
+
+sub sockname {
+ @_ == 1 or croak 'usage: $fh->sockname()';
+ getsockname($_[0]);
+}
+
+sub peername {
+ @_ == 1 or croak 'usage: $fh->peername()';
+ my($fh) = @_;
+ getpeername($fh)
+ || ${*$fh}{'io_socket_peername'}
+ || undef;
+}
+
+sub send {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
+ my $fh = $_[0];
+ my $flags = $_[2] || 0;
+ my $peer = $_[3] || $fh->peername;
+
+ croak 'send: Cannot determine peer address'
+ unless($peer);
+
+ my $r = send($fh, $_[1], $flags, $peer);
+
+ # remember who we send to, if it was sucessful
+ ${*$fh}{'io_socket_peername'} = $peer
+ if(@_ == 4 && defined $r);
+
+ $r;
+}
+
+sub recv {
+ @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+ my $sock = $_[0];
+ my $len = $_[2];
+ my $flags = $_[3] || 0;
+
+ # remember who we recv'd from
+ ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
+}
+
+
+sub setsockopt {
+ @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+ setsockopt($_[0],$_[1],$_[2],$_[3]);
+}
+
+my $intsize = length(pack("i",0));
+
+sub getsockopt {
+ @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+ my $r = getsockopt($_[0],$_[1],$_[2]);
+ # Just a guess
+ $r = unpack("i", $r)
+ if(defined $r && length($r) == $intsize);
+ $r;
+}
+
+sub sockopt {
+ my $fh = shift;
+ @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
+ : $fh->setsockopt(SOL_SOCKET,@_);
+}
+
+sub timeout {
+ @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
+ my($fh,$val) = @_;
+ my $r = ${*$fh}{'io_socket_timeout'} || undef;
+
+ ${*$fh}{'io_socket_timeout'} = 0 + $val
+ if(@_ == 2);
+
+ $r;
+}
+
+sub socktype {
+ @_ == 1 or croak '$fh->socktype()';
+ ${*{$_[0]}}{'io_socket_type'} || undef;
+}
+
+=head1 SUB-CLASSES
+
+=cut
+
+##
+## AF_INET
+##
+
+package IO::Socket::INET;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+
+my %socket_type = ( tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ );
+
+=head2 IO::Socket::INET
+
+C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
+and some related methods. The constructor can take the following options
+
+ PeerAddr Remote host address
+ PeerPort Remote port or service
+ LocalPort Local host bind port
+ LocalAddr Local host bind address
+ Proto Protocol name (eg tcp udp etc)
+ Type Socket type (SOCK_STREAM etc)
+ Listen Queue size for listen
+ Timeout Timeout value for various operations
+
+If Listen is defined then a listen socket is created, else if the socket
+type, which is derived from the protocol, is SOCK_STREAM then a connect
+is called
+
+Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
+from the other.
+
+=head2 METHODS
+
+=item sockaddr()
+
+Return the address part of the sockaddr structure for the socket
+
+=item sockport()
+
+Return the port number that the socket is using on the local host
+
+=item sockhost()
+
+Return the address part of the sockaddr structure for the socket in a
+text form xx.xx.xx.xx
+
+=item peeraddr(), peerport(), peerhost()
+
+Same as for the sock* functions, but returns the data about the peer
+host instead of the local host.
+
+=cut
+
+
+sub _sock_info {
+ my($addr,$port,$proto) = @_;
+ my @proto = ();
+ my @serv = ();
+
+ $port = $1
+ if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+ if(defined $proto) {
+ @proto = $proto =~ m,\D, ? getprotobyname($proto)
+ : getprotobynumber($proto);
+
+ $proto = $proto[2] || undef;
+ }
+
+ if(defined $port) {
+ $port =~ s,\((\d+)\)$,,;
+
+ my $defport = $1 || undef;
+ my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+ @serv= getservbyname($port, $proto[0] || "")
+ if($port =~ m,\D,);
+
+ $port = $pnum || $serv[2] || $defport || undef;
+
+ $proto = (getprotobyname($serv[3]))[2] || undef
+ if @serv && !$proto;
+ }
+
+ return ($addr || undef,
+ $port || undef,
+ $proto || undef
+ );
+}
+
+sub configure {
+ my($fh,$arg) = @_;
+ my($lport,$rport,$laddr,$raddr,$proto,$type);
+
+
+ ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
+ $arg->{LocalPort},
+ $arg->{Proto});
+
+ $laddr = defined $laddr ? inet_aton($laddr)
+ : INADDR_ANY;
+
+ unless(exists $arg->{Listen}) {
+ ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
+ $arg->{PeerPort},
+ $proto);
+ }
+
+ croak 'IO::Socket: Cannot determine protocol'
+ unless($proto);
+
+ my $pname = (getprotobynumber($proto))[0];
+ $type = $arg->{Type} || $socket_type{$pname};
+
+ $fh->socket(AF_INET, $type, $proto) or
+ return undef;
+
+ $fh->bind($lport || 0, $laddr) or
+ return undef;
+
+ if(exists $arg->{Listen}) {
+ $fh->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ else {
+ croak "IO::Socket: Cannot determine remote port"
+ unless($rport || $type == SOCK_DGRAM);
+
+ if($type == SOCK_STREAM || defined $raddr) {
+ croak "IO::Socket: Bad peer address"
+ unless defined $raddr;
+
+ $fh->connect($rport,inet_aton($raddr)) or
+ return undef;
+ }
+ }
+
+ $fh;
+}
+
+sub sockaddr {
+ @_ == 1 or croak 'usage: $fh->sockaddr()';
+ my($fh) = @_;
+ (sockaddr_in($fh->sockname))[1];
+}
+
+sub sockport {
+ @_ == 1 or croak 'usage: $fh->sockport()';
+ my($fh) = @_;
+ (sockaddr_in($fh->sockname))[0];
+}
+
+sub sockhost {
+ @_ == 1 or croak 'usage: $fh->sockhost()';
+ my($fh) = @_;
+ inet_ntoa($fh->sockaddr);
+}
+
+sub peeraddr {
+ @_ == 1 or croak 'usage: $fh->peeraddr()';
+ my($fh) = @_;
+ (sockaddr_in($fh->peername))[1];
+}
+
+sub peerport {
+ @_ == 1 or croak 'usage: $fh->peerport()';
+ my($fh) = @_;
+ (sockaddr_in($fh->peername))[0];
+}
+
+sub peerhost {
+ @_ == 1 or croak 'usage: $fh->peerhost()';
+ my($fh) = @_;
+ inet_ntoa($fh->peeraddr);
+}
+
+##
+## AF_UNIX
+##
+
+package IO::Socket::UNIX;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+
+=head2 IO::Socket::UNIX
+
+C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
+and some related methods. The constructor can take the following options
+
+ Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
+ Local Path to local fifo
+ Peer Path to peer fifo
+ Listen Create a listen socket
+
+=head2 METHODS
+
+=item hostpath()
+
+Returns the pathname to the fifo at the local end
+
+=item peerpath()
+
+Returns the pathanme to the fifo at the peer end
+
+=cut
+
+sub configure {
+ my($fh,$arg) = @_;
+ my($bport,$cport);
+
+ my $type = $arg->{Type} || SOCK_STREAM;
+
+ $fh->socket(AF_UNIX, $type, 0) or
+ return undef;
+
+ if(exists $arg->{Local}) {
+ my $addr = sockaddr_un($arg->{Local});
+ $fh->bind($addr) or
+ return undef;
+ }
+ if(exists $arg->{Listen}) {
+ $fh->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ elsif(exists $arg->{Peer}) {
+ my $addr = sockaddr_un($arg->{Peer});
+ $fh->connect($addr) or
+ return undef;
+ }
+
+ $fh;
+}
+
+sub hostpath {
+ @_ == 1 or croak 'usage: $fh->hostpath()';
+ (sockaddr_un($_[0]->hostname))[0];
+}
+
+sub peerpath {
+ @_ == 1 or croak 'usage: $fh->peerpath()';
+ (sockaddr_un($_[0]->peername))[0];
+}
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.8 $
+
+The VERSION is derived from the revision turning each number after the
+first dot into a 2 digit number so
+
+ Revision 1.8 => VERSION 1.08
+ Revision 1.2.3 => VERSION 1.0203
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+1; # Keep require happy
projects / p5sagit/p5-mst-13.2.git / commitdiff