X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFileHandle.pm;h=cd80d1902496910aeef574e8e49bb328e503a834;hb=a062834f6b91f994c046043f1bbf3218aea18281;hp=93a30888862d9a457fdfb4623c37ea79c9368b22;hpb=c07a80fdfe3926b5eb0585b674aa5d1f57b32ade;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm
index 93a3088..cd80d19 100644
--- a/lib/FileHandle.pm
+++ b/lib/FileHandle.pm
@@ -1,5 +1,108 @@
 package FileHandle;
 
+use 5.005_64;
+use strict;
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
+
+$VERSION = "2.00";
+
+require IO::File;
+@ISA = qw(IO::File);
+
+@EXPORT = qw(_IOFBF _IOLBF _IONBF);
+
+@EXPORT_OK = qw(
+    pipe
+
+    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
+
+    print
+    printf
+    getline
+    getlines
+);
+
+#
+# Everything we're willing to export, we must first import.
+#
+import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK;
+
+#
+# Some people call "FileHandle::function", so all the functions
+# that were in the old FileHandle class must be imported, too.
+#
+{
+    no strict 'refs';
+
+    my %import = (
+	'IO::Handle' =>
+	    [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
+		eof flush error clearerr setbuf setvbuf _open_mode_string)],
+	'IO::Seekable' =>
+	    [qw(seek tell getpos setpos)],
+	'IO::File' =>
+	    [qw(new new_tmpfile open)]
+    );
+    for my $pkg (keys %import) {
+	for my $func (@{$import{$pkg}}) {
+	    my $c = *{"${pkg}::$func"}{CODE}
+		or die "${pkg}::$func missing";
+	    *$func = $c;
+	}
+    }
+}
+
+#
+# Specialized importer for Fcntl magic.
+#
+sub import {
+    my $pkg = shift;
+    my $callpkg = caller;
+    require Exporter;
+    Exporter::export($pkg, $callpkg, @_);
+
+    #
+    # If the Fcntl extension is available,
+    #  export its constants.
+    #
+    eval {
+	require Fcntl;
+	Exporter::export('Fcntl', $callpkg);
+    };
+}
+
+################################################
+# This is the only exported function we define;
+# the rest come from other classes.
+#
+
+sub pipe {
+    my $r = new IO::Handle;
+    my $w = new IO::Handle;
+    CORE::pipe($r, $w) or return undef;
+    ($r, $w);
+}
+
+# Rebless standard file handles
+bless *STDIN{IO},  "FileHandle" if ref *STDIN{IO}  eq "IO::Handle";
+bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
+bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
+
+1;
+
+__END__
+
 =head1 NAME
 
 FileHandle - supply object methods for filehandles
@@ -9,7 +112,7 @@ FileHandle - supply object methods for filehandles
     use FileHandle;
 
     $fh = new FileHandle;
-    if ($fh->open "< file") {
+    if ($fh->open("< file")) {
         print <$fh>;
         $fh->close;
     }
@@ -32,12 +135,19 @@ FileHandle - supply object methods for filehandles
         undef $fh;       # automatically closes the file
     }
 
+    $pos = $fh->getpos;
+    $fh->setpos($pos);
+
+    $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
     ($readfh, $writefh) = FileHandle::pipe;
 
     autoflush STDOUT 1;
-  
+
 =head1 DESCRIPTION
 
+NOTE: This class is now a front-end to the IO::* classes.
+
 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,
@@ -53,17 +163,41 @@ 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.).
+the open mode, optionally followed by a file permission value.
+
+If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
+or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator.
+
+If C<FileHandle::open> is given a numeric mode, it passes that mode
+and the optional permissions value to the Perl C<sysopen> operator.
+For convenience, C<FileHandle::import> tries to import the O_XXX
+constants from the Fcntl module.  If dynamic loading is not available,
+this may fail, but the rest of FileHandle will still work.
 
 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.
 
+If the C functions fgetpos() and fsetpos() are available, then
+C<FileHandle::getpos> returns an opaque value that represents the
+current position of the FileHandle, and C<FileHandle::setpos> uses
+that value to return to a previously visited position.
+
+If the C function setvbuf() is available, then C<FileHandle::setvbuf>
+sets the buffering policy for the FileHandle.  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<FileHandle::setvbuf> must not be
+modified in any way until the FileHandle is closed or until
+C<FileHandle::setvbuf> is called again, or memory corruption may
+result!
+
 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
@@ -91,7 +225,7 @@ supported C<FileHandle> methods:
 
 Furthermore, for doing normal I/O you might need these:
 
-=over 
+=over 4
 
 =item $fh->print
 
@@ -104,323 +238,25 @@ 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.
+except that it's more readable and can be safely called in a
+list context but still returns just one line.
 
 =item $fh->getlines
 
-This works like <$fh> when called in an array context to
+This works like <$fh> when called in a list 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
 
+There are many other functions available since FileHandle is descended
+from IO::File, IO::Seekable, and IO::Handle.  Please see those
+respective pages for documentation on more functions.
+
 =head1 SEE ALSO
 
+The B<IO> extension,
 L<perlfunc>, 
-L<perlop/"I/O Operators">,
-L<POSIX/"FileHandle">
-
-=head1 BUGS
-
-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 
-class from C<FileHandle> and inherit those methods.
+L<perlop/"I/O Operators">.
 
 =cut
-
-require 5.000;
-use Carp;
-use Fcntl;
-use Symbol;
-use English;
-use SelectSaver;
-
-require Exporter;
-require DynaLoader;
-@ISA = qw(Exporter DynaLoader);
-
-@EXPORT = (@Fcntl::EXPORT,
-	   qw(_IOFBF _IOLBF _IONBF));
-
-@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
-
-    print
-    printf
-    getline
-    getlines
-);
-
-
-################################################
-## 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 {
-    @_ or croak 'usage: $fh->print([ARGS])';
-    my $this = shift;
-    print $this @_;
-}
-
-sub printf {
-    @_ or croak 'usage: $fh->printf([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 FileHandle::getlines in a scalar context";
-    return <$this>;
-}
-
-################################################
-## State modification functions.
-##
-
-sub autoflush {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $OUTPUT_AUTOFLUSH;
-    $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
-    $prev;
-}
-
-sub output_field_separator {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $OUTPUT_FIELD_SEPARATOR;
-    $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub output_record_separator {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $OUTPUT_RECORD_SEPARATOR;
-    $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub input_record_separator {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $INPUT_RECORD_SEPARATOR;
-    $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub input_line_number {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $INPUT_LINE_NUMBER;
-    $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub format_page_number {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $FORMAT_PAGE_NUMBER;
-    $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub format_lines_per_page {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $FORMAT_LINES_PER_PAGE;
-    $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub format_lines_left {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $FORMAT_LINES_LEFT;
-    $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub format_name {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $FORMAT_NAME;
-    $FORMAT_NAME = qualify($_[1], caller) if @_ > 1;
-    $prev;
-}
-
-sub format_top_name {
-    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 {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
-    $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
-    $prev;
-}
-
-sub format_formfeed {
-    my $old = new SelectSaver qualify($_[0], caller);
-    my $prev = $FORMAT_FORMFEED;
-    $FORMAT_FORMFEED = $_[1] if @_ > 1;
-    $prev;
-}
-
-1;