1 files changed, 265 insertions, 125 deletions

diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm
index cbc6efbc6c..93a3088886 100644
--- a/lib/FileHandle.pm
+++ b/lib/FileHandle.pm
@@ -1,25 +1,80 @@
 package FileHandle;
 
-# Note that some additional FileHandle methods are defined in POSIX.pm.
-
 =head1 NAME
 
 FileHandle - supply object methods for filehandles
 
-cacheout - keep more files open than the system permits
-
 =head1 SYNOPSIS
 
     use FileHandle;
-    autoflush STDOUT 1;
 
-    cacheout($path);
-    print $path @data;
+    $fh = new FileHandle;
+    if ($fh->open "< file") {
+        print <$fh>;
+        $fh->close;
+    }
+
+    $fh = new FileHandle "> FOO";
+    if (defined $fh) {
+        print $fh "bar\n";
+        $fh->close;
+    }
+
+    $fh = new FileHandle "file", "r";
+    if (defined $fh) {
+        print <$fh>;
+        undef $fh;       # automatically closes the file
+    }
+
+    $fh = new FileHandle "file", O_WRONLY|O_APPEND;
+    if (defined $fh) {
+        print $fh "corge\n";
+        undef $fh;       # automatically closes the file
+    }
+
+    ($readfh, $writefh) = FileHandle::pipe;
 
+    autoflush STDOUT 1;
+  
 =head1 DESCRIPTION
 
-See L<perlvar> for complete descriptions of each of the following supported C<FileHandle> 
-methods:
+C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
+newly created symbol (see the C<Symbol> package).  If it receives any
+parameters, they are passed to C<FileHandle::open>; if the open fails,
+the C<FileHandle> object is destroyed.  Otherwise, it is returned to
+the caller.
+
+C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
+It requires two parameters, which are passed to C<FileHandle::fdopen>;
+if the fdopen fails, the C<FileHandle> object is destroyed.
+Otherwise, it is returned to the caller.
+
+C<FileHandle::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<FileHandle::fdopen> is like C<open> except that its first parameter
+is not a filename but rather a file handle name, a FileHandle object,
+or a file descriptor number.
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<FileHandle> methods, which are just front ends for the
+corresponding built-in functions:
+  
+    close
+    fileno
+    getc
+    gets
+    eof
+    clearerr
+    seek
+    tell
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<FileHandle> methods:
 
     autoflush
     output_field_separator
@@ -48,9 +103,9 @@ 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.
+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
 
@@ -60,12 +115,6 @@ It will also croak() if accidentally called in a scalar context.
 
 =back
 
-=head2 The cacheout() Library
-
-The cacheout() function will make sure that there's a filehandle
-open for writing available as the pathname you give it.  It automatically
-closes and re-opens files if you exceed your system file descriptor maximum.
-
 =head1 SEE ALSO
 
 L<perlfunc>, 
@@ -74,15 +123,6 @@ L<POSIX/"FileHandle">
 
 =head1 BUGS
 
-F<sys/param.h> lies with its C<NOFILE> define on some systems,
-so you may have to set $cacheout::maxopen yourself.
-
-Some of the methods that set variables (like format_name()) don't
-seem to work.
-
-The POSIX functions that create FileHandle methods should be
-in this module instead.
-
 Due to backwards compatibility, all filehandles resemble objects
 of class C<FileHandle>, or actually classes derived from that class.
 They actually aren't.  Which means you can't derive your own 
@@ -91,12 +131,20 @@ class from C<FileHandle> and inherit those methods.
 =cut
 
 require 5.000;
-use English;
 use Carp;
-use Exporter;
+use Fcntl;
+use Symbol;
+use English;
+use SelectSaver;
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+
+@EXPORT = (@Fcntl::EXPORT,
+	   qw(_IOFBF _IOLBF _IONBF));
 
-@ISA = qw(Exporter);
-@EXPORT = qw(
+@EXPORT_OK = qw(
     autoflush
     output_field_separator
     output_record_separator
@@ -114,173 +162,265 @@ use Exporter;
     printf
     getline
     getlines
-
-    cacheout
 );
 
+
+################################################
+## Interaction with the XS.
+##
+
+bootstrap FileHandle;
+
+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 FileHandle macro";
+    *$AUTOLOAD = sub { $val };
+    goto &$AUTOLOAD;
+}
+
+
+################################################
+## Constructors, destructors.
+##
+
+sub new {
+    @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]';
+    my $class = shift;
+    my $fh = gensym;
+    if (@_) {
+	FileHandle::open($fh, @_)
+	    or return undef;
+    }
+    bless $fh, $class;
+}
+
+sub new_from_fd {
+    @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
+    my $class = shift;
+    my $fh = gensym;
+    FileHandle::fdopen($fh, @_)
+	or return undef;
+    bless $fh, $class;
+}
+
+sub DESTROY {
+    my ($fh) = @_;
+    close($fh);
+}
+
+################################################
+## Open and close.
+##
+
+sub pipe {
+    @_ and croak 'usage: FileHandle::pipe()';
+    my $readfh = new FileHandle;
+    my $writefh = new FileHandle;
+    pipe($readfh, $writefh)
+	or return undef;
+    ($readfh, $writefh);
+}
+
+sub _open_mode_string {
+    my ($mode) = @_;
+    $mode =~ /^\+?(<|>>?)$/
+      or $mode =~ s/^r(\+?)$/$1</
+      or $mode =~ s/^w(\+?)$/$1>/
+      or $mode =~ s/^a(\+?)$/$1>>/
+      or croak "FileHandle: bad open mode: $mode";
+    $mode;
+}
+
+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);
+}
+
+sub fdopen {
+    @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
+    my ($fh, $fd, $mode) = @_;
+    if (ref($fd) =~ /GLOB\(/) {
+	# It's a glob reference; remove the star from its name.
+	($fd = "".$$fd) =~ s/^\*//;
+    } elsif ($fd =~ m#^\d+$#) {
+	# It's an FD number; prefix with "=".
+	$fd = "=$fd";
+    }
+    open($fh, _open_mode_string($mode) . '&' . $fd);
+}
+
+sub close {
+    @_ == 1 or croak 'usage: $fh->close()';
+    close($_[0]);
+}
+
+################################################
+## Normal I/O functions.
+##
+
+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 clearerr {
+    @_ == 1 or croak 'usage: $fh->clearerr()';
+    seek($_[0], 0, 1);
+}
+
+sub seek {
+    @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+    seek($_[0], $_[1], $_[2]);
+}
+
+sub tell {
+    @_ == 1 or croak 'usage: $fh->tell()';
+    tell($_[0]);
+}
+
 sub print {
-    local($this) = shift;
+    @_ or croak 'usage: $fh->print([ARGS])';
+    my $this = shift;
     print $this @_;
 }
 
 sub printf {
-    local($this) = shift;
+    @_ or croak 'usage: $fh->printf([ARGS])';
+    my $this = shift;
     printf $this @_;
 }
 
 sub getline {
-    local($this) = shift;
-    croak "usage: FileHandle::getline()" if @_;
+    @_ == 1 or croak 'usage: $fh->getline';
+    my $this = shift;
     return scalar <$this>;
 } 
 
 sub getlines {
-    local($this) = shift;
-    croak "usage: FileHandle::getline()" if @_;
-    croak "can't call FileHandle::getlines in a scalar context" if wantarray;
+    @_ == 1 or croak 'usage: $fh->getline()';
+    my $this = shift;
+    wantarray or croak "Can't call FileHandle::getlines in a scalar context";
     return <$this>;
-} 
+}
+
+################################################
+## State modification functions.
+##
 
 sub autoflush {
-    local($old) = select($_[0]);
-    local($prev) = $OUTPUT_AUTOFLUSH;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $OUTPUT_AUTOFLUSH;
     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
-    select($old);
     $prev;
 }
 
 sub output_field_separator {
-    local($old) = select($_[0]);
-    local($prev) = $OUTPUT_FIELD_SEPARATOR;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $OUTPUT_FIELD_SEPARATOR;
     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub output_record_separator {
-    local($old) = select($_[0]);
-    local($prev) = $OUTPUT_RECORD_SEPARATOR;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $OUTPUT_RECORD_SEPARATOR;
     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub input_record_separator {
-    local($old) = select($_[0]);
-    local($prev) = $INPUT_RECORD_SEPARATOR;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $INPUT_RECORD_SEPARATOR;
     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub input_line_number {
-    local($old) = select($_[0]);
-    local($prev) = $INPUT_LINE_NUMBER;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $INPUT_LINE_NUMBER;
     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub format_page_number {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_PAGE_NUMBER;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_PAGE_NUMBER;
     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub format_lines_per_page {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_LINES_PER_PAGE;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_LINES_PER_PAGE;
     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub format_lines_left {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_LINES_LEFT;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_LINES_LEFT;
     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub format_name {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_NAME;
-    $FORMAT_NAME = $_[1] if @_ > 1;
-    select($old);
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_NAME;
+    $FORMAT_NAME = qualify($_[1], caller) if @_ > 1;
     $prev;
 }
 
 sub format_top_name {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_TOP_NAME;
-    $FORMAT_TOP_NAME = $_[1] if @_ > 1;
-    select($old);
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_TOP_NAME;
+    $FORMAT_TOP_NAME = qualify($_[1], caller) if @_ > 1;
     $prev;
 }
 
 sub format_line_break_characters {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_LINE_BREAK_CHARACTERS;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
 sub format_formfeed {
-    local($old) = select($_[0]);
-    local($prev) = $FORMAT_FORMFEED;
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $FORMAT_FORMFEED;
     $FORMAT_FORMFEED = $_[1] if @_ > 1;
-    select($old);
     $prev;
 }
 
-
-# --- cacheout functions ---
-
-# Open in their package.
-
-sub cacheout_open {
-    my $pack = caller(1);
-    open(*{$pack . '::' . $_[0]}, $_[1]);
-}
-
-sub cacheout_close {
-    my $pack = caller(1);
-    close(*{$pack . '::' . $_[0]});
-}
-
-# But only this sub name is visible to them.
-
-sub cacheout {
-    ($file) = @_;
-    if (!$cacheout_maxopen){
-	if (open(PARAM,'/usr/include/sys/param.h')) {
-	    local($.);
-	    while (<PARAM>) {
-		$cacheout_maxopen = $1 - 4
-		    if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
-	    }
-	    close PARAM;
-	}
-	$cacheout_maxopen = 16 unless $cacheout_maxopen;
-    }
-    if (!$isopen{$file}) {
-	if (++$cacheout_numopen > $cacheout_maxopen) {
-	    local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
-	    splice(@lru, $cacheout_maxopen / 3);
-	    $cacheout_numopen -= @lru;
-	    for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
-	}
-	&cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
-	    || croak("Can't create $file: $!");
-    }
-    $isopen{$file} = ++$cacheout_seq;
-}
-
-$cacheout_seq = 0;
-$cacheout_numopen = 0;
-
 1;