Mailing List Archive

FileHandle 0.03, Modifications:

POSIX:
Extract gensym, FileHandle, DirHandle methods into separate modules.
Use "my" wherever possible.

FileHandle:
Insert new and new_from_fd methods from POSIX.
The new and open methods support three forms:
new FileHandle; # no open
new FileHandle ">FOO"; # Perl-style open
new FileHandle "FOO", ">"; # Perl-style open, filename-safe
new FileHandle "FOO", "w"; # POSIX-style open
The new_from_fd and fdopen methods support two forms:
new_from_fd FileHandle $fh->fileno, ">"; # Perl-style mode
new_from_fd FileHandle $fh->fileno, "w"; # POSIX-style mode
New function FileHandle::pipe.

Index: ext/POSIX/POSIX.pm
***************
*** 62,65 ****
--- 62,66 ----
require DynaLoader;
require Config;
+ use Symbol;
@ISA = qw(Exporter DynaLoader);

***************
*** 236,240 ****
goto &AutoLoader::AUTOLOAD
}
! local $constname = $AUTOLOAD;
$constname =~ s/.*:://;
$val = constant($constname, $_[0]);
--- 237,241 ----
goto &AutoLoader::AUTOLOAD
}
! my $constname = $AUTOLOAD;
$constname =~ s/.*:://;
$val = constant($constname, $_[0]);
***************
*** 258,288 ****

sub usage {
! local ($mess) = @_;
croak "Usage: POSIX::$mess";
}

sub redef {
! local ($mess) = @_;
! croak "Use method $mess instead";
}

sub unimpl {
! local ($mess) = @_;
$mess =~ s/xxx//;
croak "Unimplemented: POSIX::$mess";
}

- $gensym = "SYM000";
-
- sub gensym {
- *{"POSIX::" . $gensym++};
- }
-
- sub ungensym {
- local($x) = shift;
- $x =~ s/.*:://;
- delete $POSIX::{$x};
- }
-
############################
package POSIX::SigAction;
--- 259,277 ----

sub usage {
! my ($mess) = @_;
croak "Usage: POSIX::$mess";
}

sub redef {
! my ($mess) = @_;
! croak "Instead of this, use ";
}

sub unimpl {
! my ($mess) = @_;
$mess =~ s/xxx//;
croak "Unimplemented: POSIX::$mess";
}

############################
package POSIX::SigAction;
***************
*** 293,367 ****

############################
! package FileHandle;
!
! sub new {
! POSIX::usage "FileHandle->new(filename, posixmode)" if @_ != 3;
! local($class,$filename,$mode) = @_;
! local($glob) = &POSIX::gensym;
! $mode =~ s/a.*/>>/ ||
! $mode =~ s/w.*/>/ ||
! ($mode = '<');
! open($glob, "$mode $filename") and
! bless \$glob;
! }
!
! sub new_from_fd {
! POSIX::usage "FileHandle->new_from_fd(fd,mode)" if @_ != 3;
! local($class,$fd,$mode) = @_;
! local($glob) = &POSIX::gensym;
! $mode =~ s/a.*/>>/ ||
! $mode =~ s/w.*/>/ ||
! ($mode = '<');
! open($glob, "$mode&=$fd") and
! bless \$glob;
! }
!
! sub clearerr {
! POSIX::usage "clearerr(filehandle)" if @_ != 1;
! seek($_[0], 0, 1);
! }
!
! sub close {
! POSIX::usage "close(filehandle)" if @_ != 1;
! close($_[0]);
! }
!
! sub DESTROY {
! close($_[0]);
! ungensym($_[0]);
! }
!
! sub eof {
! POSIX::usage "eof(filehandle)" if @_ != 1;
! eof($_[0]);
! }
!
! sub getc {
! POSIX::usage "getc(filehandle)" if @_ != 1;
! getc($_[0]);
! }
!
! sub gets {
! POSIX::usage "gets(filehandle)" if @_ != 1;
! local($handle) = @_;
! scalar <$handle>;
! }
!
! sub fileno {
! POSIX::usage "fileno(filehandle)" if @_ != 1;
! fileno($_[0]);
! }
!
! sub seek {
! POSIX::usage "seek(filehandle,pos,whence)" if @_ != 3;
! seek($_[0], $_[1], $_[2]);
! }
!
! sub tell {
! POSIX::usage "tell(filehandle)" if @_ != 1;
! tell($_[0]);
! }
! ############################
! package POSIX; # return to package POSIX so AutoSplit is happy
1;
__END__
--- 282,286 ----

############################
! package POSIX;
1;
__END__
***************
*** 384,399 ****
}

sub closedir {
usage "closedir(dirhandle)" if @_ != 1;
closedir($_[0]);
- ungensym($_[0]);
- }
-
- sub opendir {
- usage "opendir(directory)" if @_ != 1;
- local($dirhandle) = &gensym;
- opendir($dirhandle, $_[0])
- ? $dirhandle
- : (ungensym($dirhandle), undef);
}

--- 303,315 ----
}

+ sub opendir {
+ usage "opendir(directory)" if @_ != 1;
+ my $sym = Symbol::generate;
+ opendir($sym, $_[0]) and $sym;
+ }
+
sub closedir {
usage "closedir(dirhandle)" if @_ != 1;
closedir($_[0]);
}

***************
*** 510,546 ****

sub offsetof {
! unimpl "offsetof() is C-specific, stopped";
}

sub clearerr {
! redef "$filehandle->clearerr(filehandle)";
}

sub fclose {
! redef "$filehandle->fclose(filehandle)";
}

sub fdopen {
! redef "FileHandle->new_from_fd(fd,mode)";
}

sub feof {
! redef "$filehandle->eof()";
}

sub fgetc {
! redef "$filehandle->getc()";
}

sub fgets {
! redef "$filehandle->gets()";
}

sub fileno {
! redef "$filehandle->fileno()";
}

sub fopen {
! redef "FileHandle->open()";
}

--- 426,462 ----

sub offsetof {
! unimpl "offsetof() is C-specific";
}

sub clearerr {
! redef '$fh->clearerr';
}

sub fclose {
! redef '$fh->close';
}

sub fdopen {
! redef 'new_from_fd FileHandle fd, mode';
}

sub feof {
! redef '$fh->eof';
}

sub fgetc {
! redef '$fh->getc';
}

sub fgets {
! redef '$fh->gets';
}

sub fileno {
! redef '$fh->fileno'
}

sub fopen {
! redef 'new FileHandle [filename [,mode]]';
}

***************
*** 570,594 ****

sub fseek {
! redef "$filehandle->seek(pos,whence)";
}

sub ferror {
! redef "$filehandle->error()";
}

sub fflush {
! redef "$filehandle->flush()";
}

sub fgetpos {
! redef "$filehandle->getpos()";
}

sub fsetpos {
! redef "$filehandle->setpos(pos)";
}

sub ftell {
! redef "$filehandle->tell()";
}

--- 486,510 ----

sub fseek {
! redef '$fh->seek(pos, whence)';
}

sub ferror {
! unimpl "ferror() is C-specific";
}

sub fflush {
! redef '$fh->flush()';
}

sub fgetpos {
! redef '$fh->tell()';
}

sub fsetpos {
! redef '$fh->seek(pos, 0)';
}

sub ftell {
! redef '$fh->tell()';
}

***************
*** 598,603 ****

sub getc {
! usage "getc(handle)" if @_ != 1;
! getc($_[0]);
}

--- 514,518 ----

sub getc {
! redef '$fh->getc';
}

***************
*** 663,671 ****

sub tmpfile {
! redef "FileHandle->new_tmpfile()";
}

sub ungetc {
! redef "$filehandle->ungetc(char)";
}

--- 578,586 ----

sub tmpfile {
! unimpl "tmpfile() hasn't been done yet";
}

sub ungetc {
! unimpl "ungetc() is C-specific";
}

***************
*** 692,704 ****

sub atof {
! unimpl "atof() is C-specific, stopped";
}

sub atoi {
! unimpl "atoi() is C-specific, stopped";
}

sub atol {
! unimpl "atol() is C-specific, stopped";
}

--- 607,619 ----

sub atof {
! unimpl "atof() is C-specific";
}

sub atoi {
! unimpl "atoi() is C-specific";
}

sub atol {
! unimpl "atol() is C-specific";
}

***************
*** 866,874 ****
sub fstat {
usage "fstat(fd)" if @_ != 1;
! local(*TMP);
open(TMP, "<&$_[0]"); # Gross.
! local(@l) = stat(TMP);
close(TMP);
! @l;
}

--- 781,789 ----
sub fstat {
usage "fstat(fd)" if @_ != 1;
! local *TMP;
open(TMP, "<&$_[0]"); # Gross.
! my @s = stat(TMP);
close(TMP);
! @s;
}

***************
*** 895,899 ****
sub wait {
usage "wait(statusvariable)" if @_ != 1;
! local $result = wait();
$_[0] = $?;
$result;
--- 810,814 ----
sub wait {
usage "wait(statusvariable)" if @_ != 1;
! my $result = wait();
$_[0] = $?;
$result;
***************
*** 902,906 ****
sub waitpid {
usage "waitpid(pid, statusvariable, options)" if @_ != 3;
! local $result = waitpid($_[0], $_[2]);
$_[1] = $?;
$result;
--- 817,821 ----
sub waitpid {
usage "waitpid(pid, statusvariable, options)" if @_ != 3;
! my $result = waitpid($_[0], $_[2]);
$_[1] = $?;
$result;
***************
*** 996,1000 ****
sub getgroups {
usage "getgroups()" if @_ != 0;
! local(%seen) = ();
grep(!$seen{$_}++, split(' ', $) ));
}
--- 911,915 ----
sub getgroups {
usage "getgroups()" if @_ != 0;
! my %seen;
grep(!$seen{$_}++, split(' ', $) ));
}

Index: lib/FileHandle.pm
***************
*** 1,26 ****
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;

=head1 DESCRIPTION

! See L<perlvar> for complete descriptions of each of the following supported C<FileHandle>
! methods:

print
autoflush
output_field_separator
--- 1,75 ----
package FileHandle;

=head1 NAME

FileHandle - supply object methods for filehandles

=head1 SYNOPSIS

use FileHandle;

! $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
! }
!
! ($readfh, $writefh) = FileHandle::pipe;
!
! autoflush STDOUT 1;

=head1 DESCRIPTION

! 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
print
+ 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
***************
*** 36,48 ****
format_formfeed

- 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 BUGS

- F<sys/param.h> lies with its C<NOFILE> define on some systems,
- so you may have to set $cacheout::maxopen yourself.
-
Due to backwards compatibility, all filehandles resemble objects
of class C<FileHandle>, or actually classes derived from that class.
--- 85,90 ----
***************
*** 53,62 ****

require 5.000;
use English;
use Exporter;

@ISA = qw(Exporter);
! @EXPORT = qw(
! print
autoflush
output_field_separator
--- 95,106 ----

require 5.000;
+ use Symbol;
+ use SelectSaver;
use English;
+ use Carp;
use Exporter;

@ISA = qw(Exporter);
! @EXPORT_OK = qw(
autoflush
output_field_separator
***************
*** 71,223 ****
format_line_break_characters
format_formfeed
- cacheout
);

sub print {
! local($this) = shift;
! print $this @_;
}

sub autoflush {
! local($old) = select($_[0]);
! local($prev) = $OUTPUT_AUTOFLUSH;
$OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
- select($old);
$prev;
}

sub output_field_separator {
! local($old) = select($_[0]);
! local($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;
$OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
- select($old);
$prev;
}

sub input_record_separator {
! local($old) = select($_[0]);
! local($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;
$INPUT_LINE_NUMBER = $_[1] if @_ > 1;
- select($old);
$prev;
}

sub format_page_number {
! local($old) = select($_[0]);
! local($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;
$FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
- select($old);
$prev;
}

sub format_lines_left {
! local($old) = select($_[0]);
! local($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);
$prev;
}

sub format_top_name {
! local($old) = select($_[0]);
! local($prev) = $FORMAT_TOP_NAME;
$FORMAT_TOP_NAME = $_[1] if @_ > 1;
- select($old);
$prev;
}

sub format_line_break_characters {
! local($old) = select($_[0]);
! local($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;
$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;
--- 115,321 ----
format_line_break_characters
format_formfeed
);

+ sub usage {
+ my ($msg) = @_;
+ croak "Usage: $msg";
+ }
+
+ sub new {
+ usage 'new FileHandle [FILENAME [,MODE]]' unless @_ && @_ <= 3;
+ my $fh = Symbol::generate;
+ if (@_ > 1) {
+ FileHandle::open($fh, @_[1 .. $#_])
+ or return undef;
+ }
+ bless $fh;
+ }
+
+ sub new_from_fd {
+ usage 'new_from_fd FileHandle FD, MODE' unless @_ == 3;
+ my $fh = Symbol::generate;
+ FileHandle::fdopen($fh, @_[1, 2])
+ or return undef;
+ bless $fh;
+ }
+
+ sub DESTROY {
+ my ($fh) = @_;
+ if (Symbol::isa $fh) {
+ close $fh;
+ }
+ }
+
+ sub pipe {
+ usage 'FileHandle::pipe()' unless @_ == 0;
+ 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 {
+ usage '$fh->open(FILENAME [,MODE])' unless @_ >= 2 && @_ <= 3;
+ my ($fh, $file) = @_;
+ if (@_ > 2) {
+ $file = "./" . $file unless $file =~ m#^/#;
+ $file = _open_mode_string($_[2]) . " $file\0";
+ }
+ open($fh, $file);
+ }
+
+ sub fdopen {
+ usage '$fh->fdopen(FD, MODE)' unless @_ == 3;
+ my ($fh, $fd, $mode) = @_;
+ if (ref($fd) =~ /GLOB\(/) {
+ ($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 {
+ usage '$fh->close()' unless @_ == 1;
+ close($_[0]);
+ }
+
+ sub fileno {
+ usage '$fh->fileno()' unless @_ == 1;
+ fileno($_[0]);
+ }
+
sub print {
! usage '$fh->print(ARGS)' unless @_;
! my $fh = shift;
! print $fh @_;
! }
!
! sub getc {
! usage '$fh->getc()' unless @_ == 1;
! getc($_[0]);
! }
!
! sub gets {
! usage '$fh->gets()' unless @_ == 1;
! my ($handle) = @_;
! scalar <$handle>;
! }
!
! sub eof {
! usage '$fh->eof()' unless @_ == 1;
! eof($_[0]);
! }
!
! sub clearerr {
! usage '$fh->clearerr()' unless @_ == 1;
! seek($_[0], 0, 1);
! }
!
! sub seek {
! usage '$fh->seek(POS, WHENCE)' if @_ != 3;
! seek($_[0], $_[1], $_[2]);
! }
!
! sub tell {
! usage '$fh->tell()' unless @_ == 1;
! tell($_[0]);
}

sub autoflush {
! my $selsave = new SelectSaver $_[0];
! my $prev = $OUTPUT_AUTOFLUSH;
$OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
$prev;
}

sub output_field_separator {
! my $selsave = new SelectSaver $_[0];
! my $prev = $OUTPUT_FIELD_SEPARATOR;
$OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
$prev;
}

sub output_record_separator {
! my $selsave = new SelectSaver $_[0];
! my $prev = $OUTPUT_RECORD_SEPARATOR;
$OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
$prev;
}

sub input_record_separator {
! my $selsave = new SelectSaver $_[0];
! my $prev = $INPUT_RECORD_SEPARATOR;
$INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
$prev;
}

sub input_line_number {
! my $selsave = new SelectSaver $_[0];
! my $prev = $INPUT_LINE_NUMBER;
$INPUT_LINE_NUMBER = $_[1] if @_ > 1;
$prev;
}

sub format_page_number {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_PAGE_NUMBER;
$FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
$prev;
}

sub format_lines_per_page {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_LINES_PER_PAGE;
$FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
$prev;
}

sub format_lines_left {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_LINES_LEFT;
$FORMAT_LINES_LEFT = $_[1] if @_ > 1;
$prev;
}

sub format_name {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_NAME;
$FORMAT_NAME = $_[1] if @_ > 1;
$prev;
}

sub format_top_name {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_TOP_NAME;
$FORMAT_TOP_NAME = $_[1] if @_ > 1;
$prev;
}

sub format_line_break_characters {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
$FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
$prev;
}

sub format_formfeed {
! my $selsave = new SelectSaver $_[0];
! my $prev = $FORMAT_FORMFEED;
$FORMAT_FORMFEED = $_[1] if @_ > 1;
$prev;
}

1;