lib/FileHandle.pm

   1 package FileHandle;
   2
   3 =head1 NAME
   4
   5 FileHandle - supply object methods for filehandles
   6
   7 =head1 SYNOPSIS
   8
   9     use FileHandle;
  10
  11     $fh = new FileHandle;
  12     if ($fh->open "< file") {
  13         print <$fh>;
  14         $fh->close;
  15     }
  16
  17     $fh = new FileHandle "> FOO";
  18     if (defined $fh) {
  19         print $fh "bar\n";
  20         $fh->close;
  21     }
  22
  23     $fh = new FileHandle "file", "r";
  24     if (defined $fh) {
  25         print <$fh>;
  26         undef $fh;       # automatically closes the file
  27     }
  28
  29     $fh = new FileHandle "file", O_WRONLY|O_APPEND;
  30     if (defined $fh) {
  31         print $fh "corge\n";
  32         undef $fh;       # automatically closes the file
  33     }
  34
  35     ($readfh, $writefh) = FileHandle::pipe;
  36
  37     autoflush STDOUT 1;
  38
  39 =head1 DESCRIPTION
  40
  41 C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
  42 newly created symbol (see the C<Symbol> package).  If it receives any
  43 parameters, they are passed to C<FileHandle::open>; if the open fails,
  44 the C<FileHandle> object is destroyed.  Otherwise, it is returned to
  45 the caller.
  46
  47 C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
  48 It requires two parameters, which are passed to C<FileHandle::fdopen>;
  49 if the fdopen fails, the C<FileHandle> object is destroyed.
  50 Otherwise, it is returned to the caller.
  51
  52 C<FileHandle::open> accepts one parameter or two.  With one parameter,
  53 it is just a front end for the built-in C<open> function.  With two
  54 parameters, the first parameter is a filename that may include
  55 whitespace or other special characters, and the second parameter is
  56 the open mode in either Perl form (">", "+<", etc.) or POSIX form
  57 ("w", "r+", etc.).
  58
  59 C<FileHandle::fdopen> is like C<open> except that its first parameter
  60 is not a filename but rather a file handle name, a FileHandle object,
  61 or a file descriptor number.
  62
  63 See L<perlfunc> for complete descriptions of each of the following
  64 supported C<FileHandle> methods, which are just front ends for the
  65 corresponding built-in functions:
  66
  67     close
  68     fileno
  69     getc
  70     gets
  71     eof
  72     clearerr
  73     seek
  74     tell
  75
  76 See L<perlvar> for complete descriptions of each of the following
  77 supported C<FileHandle> methods:
  78
  79     autoflush
  80     output_field_separator
  81     output_record_separator
  82     input_record_separator
  83     input_line_number
  84     format_page_number
  85     format_lines_per_page
  86     format_lines_left
  87     format_name
  88     format_top_name
  89     format_line_break_characters
  90     format_formfeed
  91
  92 Furthermore, for doing normal I/O you might need these:
  93
  94 =over
  95
  96 =item $fh->print
  97
  98 See L<perlfunc/print>.
  99
 100 =item $fh->printf
 101
 102 See L<perlfunc/printf>.
 103
 104 =item $fh->getline
 105
 106 This works like <$fh> described in L<perlop/"I/O Operators">
 107 except that it's more readable and can be safely called in an
 108 array context but still returns just one line.
 109
 110 =item $fh->getlines
 111
 112 This works like <$fh> when called in an array context to
 113 read all the remaining lines in a file, except that it's more readable.
 114 It will also croak() if accidentally called in a scalar context.
 115
 116 =back
 117
 118 =head1 SEE ALSO
 119
 120 L<perlfunc>,
 121 L<perlop/"I/O Operators">,
 122 L<POSIX/"FileHandle">
 123
 124 =head1 BUGS
 125
 126 Due to backwards compatibility, all filehandles resemble objects
 127 of class C<FileHandle>, or actually classes derived from that class.
 128 They actually aren't.  Which means you can't derive your own
 129 class from C<FileHandle> and inherit those methods.
 130
 131 =cut
 132
 133 require 5.000;
 134 use Carp;
 135 use Fcntl;
 136 use Symbol;
 137 use English;
 138 use SelectSaver;
 139
 140 require Exporter;
 141 require DynaLoader;
 142 @ISA = qw(Exporter DynaLoader);
 143
 144 @EXPORT = (@Fcntl::EXPORT,
 145            qw(_IOFBF _IOLBF _IONBF));
 146
 147 @EXPORT_OK = qw(
 148     autoflush
 149     output_field_separator
 150     output_record_separator
 151     input_record_separator
 152     input_line_number
 153     format_page_number
 154     format_lines_per_page
 155     format_lines_left
 156     format_name
 157     format_top_name
 158     format_line_break_characters
 159     format_formfeed
 160
 161     print
 162     printf
 163     getline
 164     getlines
 165 );
 166
 167
 168 ################################################
 169 ## Interaction with the XS.
 170 ##
 171
 172 bootstrap FileHandle;
 173
 174 sub AUTOLOAD {
 175     if ($AUTOLOAD =~ /::(_?[a-z])/) {
 176         $AutoLoader::AUTOLOAD = $AUTOLOAD;
 177         goto &AutoLoader::AUTOLOAD
 178     }
 179     my $constname = $AUTOLOAD;
 180     $constname =~ s/.*:://;
 181     my $val = constant($constname);
 182     defined $val or croak "$constname is not a valid FileHandle macro";
 183     *$AUTOLOAD = sub { $val };
 184     goto &$AUTOLOAD;
 185 }
 186
 187
 188 ################################################
 189 ## Constructors, destructors.
 190 ##
 191
 192 sub new {
 193     @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]';
 194     my $class = shift;
 195     my $fh = gensym;
 196     if (@_) {
 197         FileHandle::open($fh, @_)
 198             or return undef;
 199     }
 200     bless $fh, $class;
 201 }
 202
 203 sub new_from_fd {
 204     @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
 205     my $class = shift;
 206     my $fh = gensym;
 207     FileHandle::fdopen($fh, @_)
 208         or return undef;
 209     bless $fh, $class;
 210 }
 211
 212 sub DESTROY {
 213     my ($fh) = @_;
 214     close($fh);
 215 }
 216
 217 ################################################
 218 ## Open and close.
 219 ##
 220
 221 sub pipe {
 222     @_ and croak 'usage: FileHandle::pipe()';
 223     my $readfh = new FileHandle;
 224     my $writefh = new FileHandle;
 225     pipe($readfh, $writefh)
 226         or return undef;
 227     ($readfh, $writefh);
 228 }
 229
 230 sub _open_mode_string {
 231     my ($mode) = @_;
 232     $mode =~ /^\+?(<|>>?)$/
 233       or $mode =~ s/^r(\+?)$/$1</
 234       or $mode =~ s/^w(\+?)$/$1>/
 235       or $mode =~ s/^a(\+?)$/$1>>/
 236       or croak "FileHandle: bad open mode: $mode";
 237     $mode;
 238 }
 239
 240 sub open {
 241     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
 242     my ($fh, $file) = @_;
 243     if (@_ > 2) {
 244         my ($mode, $perms) = @_[2, 3];
 245         if ($mode =~ /^\d+$/) {
 246             defined $perms or $perms = 0666;
 247             return sysopen($fh, $file, $mode, $perms);
 248         }
 249         $file = "./" . $file unless $file =~ m#^/#;
 250         $file = _open_mode_string($mode) . " $file\0";
 251     }
 252     open($fh, $file);
 253 }
 254
 255 sub fdopen {
 256     @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
 257     my ($fh, $fd, $mode) = @_;
 258     if (ref($fd) =~ /GLOB\(/) {
 259         # It's a glob reference; remove the star from its name.
 260         ($fd = "".$$fd) =~ s/^\*//;
 261     } elsif ($fd =~ m#^\d+$#) {
 262         # It's an FD number; prefix with "=".
 263         $fd = "=$fd";
 264     }
 265     open($fh, _open_mode_string($mode) . '&' . $fd);
 266 }
 267
 268 sub close {
 269     @_ == 1 or croak 'usage: $fh->close()';
 270     close($_[0]);
 271 }
 272
 273 ################################################
 274 ## Normal I/O functions.
 275 ##
 276
 277 sub fileno {
 278     @_ == 1 or croak 'usage: $fh->fileno()';
 279     fileno($_[0]);
 280 }
 281
 282 sub getc {
 283     @_ == 1 or croak 'usage: $fh->getc()';
 284     getc($_[0]);
 285 }
 286
 287 sub gets {
 288     @_ == 1 or croak 'usage: $fh->gets()';
 289     my ($handle) = @_;
 290     scalar <$handle>;
 291 }
 292
 293 sub eof {
 294     @_ == 1 or croak 'usage: $fh->eof()';
 295     eof($_[0]);
 296 }
 297
 298 sub clearerr {
 299     @_ == 1 or croak 'usage: $fh->clearerr()';
 300     seek($_[0], 0, 1);
 301 }
 302
 303 sub seek {
 304     @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
 305     seek($_[0], $_[1], $_[2]);
 306 }
 307
 308 sub tell {
 309     @_ == 1 or croak 'usage: $fh->tell()';
 310     tell($_[0]);
 311 }
 312
 313 sub print {
 314     @_ or croak 'usage: $fh->print([ARGS])';
 315     my $this = shift;
 316     print $this @_;
 317 }
 318
 319 sub printf {
 320     @_ or croak 'usage: $fh->printf([ARGS])';
 321     my $this = shift;
 322     printf $this @_;
 323 }
 324
 325 sub getline {
 326     @_ == 1 or croak 'usage: $fh->getline';
 327     my $this = shift;
 328     return scalar <$this>;
 329 }
 330
 331 sub getlines {
 332     @_ == 1 or croak 'usage: $fh->getline()';
 333     my $this = shift;
 334     wantarray or croak "Can't call FileHandle::getlines in a scalar context";
 335     return <$this>;
 336 }
 337
 338 ################################################
 339 ## State modification functions.
 340 ##
 341
 342 sub autoflush {
 343     my $old = new SelectSaver qualify($_[0], caller);
 344     my $prev = $OUTPUT_AUTOFLUSH;
 345     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
 346     $prev;
 347 }
 348
 349 sub output_field_separator {
 350     my $old = new SelectSaver qualify($_[0], caller);
 351     my $prev = $OUTPUT_FIELD_SEPARATOR;
 352     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
 353     $prev;
 354 }
 355
 356 sub output_record_separator {
 357     my $old = new SelectSaver qualify($_[0], caller);
 358     my $prev = $OUTPUT_RECORD_SEPARATOR;
 359     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
 360     $prev;
 361 }
 362
 363 sub input_record_separator {
 364     my $old = new SelectSaver qualify($_[0], caller);
 365     my $prev = $INPUT_RECORD_SEPARATOR;
 366     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
 367     $prev;
 368 }
 369
 370 sub input_line_number {
 371     my $old = new SelectSaver qualify($_[0], caller);
 372     my $prev = $INPUT_LINE_NUMBER;
 373     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
 374     $prev;
 375 }
 376
 377 sub format_page_number {
 378     my $old = new SelectSaver qualify($_[0], caller);
 379     my $prev = $FORMAT_PAGE_NUMBER;
 380     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
 381     $prev;
 382 }
 383
 384 sub format_lines_per_page {
 385     my $old = new SelectSaver qualify($_[0], caller);
 386     my $prev = $FORMAT_LINES_PER_PAGE;
 387     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
 388     $prev;
 389 }
 390
 391 sub format_lines_left {
 392     my $old = new SelectSaver qualify($_[0], caller);
 393     my $prev = $FORMAT_LINES_LEFT;
 394     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
 395     $prev;
 396 }
 397
 398 sub format_name {
 399     my $old = new SelectSaver qualify($_[0], caller);
 400     my $prev = $FORMAT_NAME;
 401     $FORMAT_NAME = qualify($_[1], caller) if @_ > 1;
 402     $prev;
 403 }
 404
 405 sub format_top_name {
 406     my $old = new SelectSaver qualify($_[0], caller);
 407     my $prev = $FORMAT_TOP_NAME;
 408     $FORMAT_TOP_NAME = qualify($_[1], caller) if @_ > 1;
 409     $prev;
 410 }
 411
 412 sub format_line_break_characters {
 413     my $old = new SelectSaver qualify($_[0], caller);
 414     my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
 415     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
 416     $prev;
 417 }
 418
 419 sub format_formfeed {
 420     my $old = new SelectSaver qualify($_[0], caller);
 421     my $prev = $FORMAT_FORMFEED;
 422     $FORMAT_FORMFEED = $_[1] if @_ > 1;
 423     $prev;
 424 }
 425
 426 1;