ext/FileHandle/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     $pos = $fh->getpos;
  36     $fh->setpos $pos;
  37
  38     $fh->setvbuf($buffer_var, _IOLBF, 1024);
  39
  40     ($readfh, $writefh) = FileHandle::pipe;
  41
  42     autoflush STDOUT 1;
  43
  44 =head1 DESCRIPTION
  45
  46 C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
  47 newly created symbol (see the C<Symbol> package).  If it receives any
  48 parameters, they are passed to C<FileHandle::open>; if the open fails,
  49 the C<FileHandle> object is destroyed.  Otherwise, it is returned to
  50 the caller.
  51
  52 C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
  53 It requires two parameters, which are passed to C<FileHandle::fdopen>;
  54 if the fdopen fails, the C<FileHandle> object is destroyed.
  55 Otherwise, it is returned to the caller.
  56
  57 C<FileHandle::open> accepts one parameter or two.  With one parameter,
  58 it is just a front end for the built-in C<open> function.  With two
  59 parameters, the first parameter is a filename that may include
  60 whitespace or other special characters, and the second parameter is
  61 the open mode, optionally followed by a file permission value.
  62
  63 If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
  64 or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
  65 Perl C<open> operator.
  66
  67 If C<FileHandle::open> is given a numeric mode, it passes that mode
  68 and the optional permissions value to the Perl C<sysopen> operator.
  69 For convenience, C<FileHandle::import> tries to import the O_XXX
  70 constants from the Fcntl module.  If dynamic loading is not available,
  71 this may fail, but the rest of FileHandle will still work.
  72
  73 C<FileHandle::fdopen> is like C<open> except that its first parameter
  74 is not a filename but rather a file handle name, a FileHandle object,
  75 or a file descriptor number.
  76
  77 If the C functions fgetpos() and fsetpos() are available, then
  78 C<FileHandle::getpos> returns an opaque value that represents the
  79 current position of the FileHandle, and C<FileHandle::setpos> uses
  80 that value to return to a previously visited position.
  81
  82 If the C function setvbuf() is available, then C<FileHandle::setvbuf>
  83 sets the buffering policy for the FileHandle.  The calling sequence
  84 for the Perl function is the same as its C counterpart, including the
  85 macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
  86 parameter specifies a scalar variable to use as a buffer.  WARNING: A
  87 variable used as a buffer by C<FileHandle::setvbuf> must not be
  88 modified in any way until the FileHandle is closed or until
  89 C<FileHandle::setvbuf> is called again, or memory corruption may
  90 result!
  91
  92 See L<perlfunc> for complete descriptions of each of the following
  93 supported C<FileHandle> methods, which are just front ends for the
  94 corresponding built-in functions:
  95
  96     close
  97     fileno
  98     getc
  99     gets
 100     eof
 101     clearerr
 102     seek
 103     tell
 104
 105 See L<perlvar> for complete descriptions of each of the following
 106 supported C<FileHandle> methods:
 107
 108     autoflush
 109     output_field_separator
 110     output_record_separator
 111     input_record_separator
 112     input_line_number
 113     format_page_number
 114     format_lines_per_page
 115     format_lines_left
 116     format_name
 117     format_top_name
 118     format_line_break_characters
 119     format_formfeed
 120
 121 Furthermore, for doing normal I/O you might need these:
 122
 123 =over
 124
 125 =item $fh->print
 126
 127 See L<perlfunc/print>.
 128
 129 =item $fh->printf
 130
 131 See L<perlfunc/printf>.
 132
 133 =item $fh->getline
 134
 135 This works like <$fh> described in L<perlop/"I/O Operators">
 136 except that it's more readable and can be safely called in an
 137 array context but still returns just one line.
 138
 139 =item $fh->getlines
 140
 141 This works like <$fh> when called in an array context to
 142 read all the remaining lines in a file, except that it's more readable.
 143 It will also croak() if accidentally called in a scalar context.
 144
 145 =back
 146
 147 =head1 SEE ALSO
 148
 149 L<perlfunc>,
 150 L<perlop/"I/O Operators">,
 151 L<POSIX/"FileHandle">
 152
 153 =head1 BUGS
 154
 155 Due to backwards compatibility, all filehandles resemble objects
 156 of class C<FileHandle>, or actually classes derived from that class.
 157 They actually aren't.  Which means you can't derive your own
 158 class from C<FileHandle> and inherit those methods.
 159
 160 =cut
 161
 162 require 5.000;
 163 use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
 164 use Carp;
 165 use Symbol;
 166 use SelectSaver;
 167
 168 require Exporter;
 169 require DynaLoader;
 170 @ISA = qw(Exporter DynaLoader);
 171
 172 $VERSION = "1.00" ;
 173
 174 @EXPORT = qw(_IOFBF _IOLBF _IONBF);
 175
 176 @EXPORT_OK = qw(
 177     autoflush
 178     output_field_separator
 179     output_record_separator
 180     input_record_separator
 181     input_line_number
 182     format_page_number
 183     format_lines_per_page
 184     format_lines_left
 185     format_name
 186     format_top_name
 187     format_line_break_characters
 188     format_formfeed
 189
 190     print
 191     printf
 192     getline
 193     getlines
 194 );
 195
 196
 197 ################################################
 198 ## If the Fcntl extension is available,
 199 ##  export its constants.
 200 ##
 201
 202 sub import {
 203     my $pkg = shift;
 204     my $callpkg = caller;
 205     Exporter::export $pkg, $callpkg;
 206     eval {
 207         require Fcntl;
 208         Exporter::export 'Fcntl', $callpkg;
 209     };
 210 };
 211
 212
 213 ################################################
 214 ## Interaction with the XS.
 215 ##
 216
 217 eval {
 218     bootstrap FileHandle;
 219 };
 220 if ($@) {
 221     *constant = sub { undef };
 222 }
 223
 224 sub AUTOLOAD {
 225     if ($AUTOLOAD =~ /::(_?[a-z])/) {
 226         $AutoLoader::AUTOLOAD = $AUTOLOAD;
 227         goto &AutoLoader::AUTOLOAD
 228     }
 229     my $constname = $AUTOLOAD;
 230     $constname =~ s/.*:://;
 231     my $val = constant($constname);
 232     defined $val or croak "$constname is not a valid FileHandle macro";
 233     *$AUTOLOAD = sub { $val };
 234     goto &$AUTOLOAD;
 235 }
 236
 237
 238 ################################################
 239 ## Constructors, destructors.
 240 ##
 241
 242 sub new {
 243     @_ >= 1 && @_ <= 4
 244         or croak 'usage: new FileHandle [FILENAME [,MODE [,PERMS]]]';
 245     my $class = shift;
 246     my $fh = gensym;
 247     if (@_) {
 248         FileHandle::open($fh, @_)
 249             or return undef;
 250     }
 251     bless $fh, $class;
 252 }
 253
 254 sub new_from_fd {
 255     @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
 256     my $class = shift;
 257     my $fh = gensym;
 258     FileHandle::fdopen($fh, @_)
 259         or return undef;
 260     bless $fh, $class;
 261 }
 262
 263 sub DESTROY {
 264     my ($fh) = @_;
 265
 266    # During global object destruction, this function may be called
 267    # on FILEHANDLEs as well as on the GLOBs that contains them.
 268    # Thus the following trickery.  If only the CORE file operators
 269    # could deal with FILEHANDLEs, it wouldn't be necessary...
 270
 271    if ($fh =~ /=FILEHANDLE\(/) {
 272      local *TMP = $fh;
 273      close(TMP) if defined fileno(TMP);
 274    }
 275    else {
 276      close($fh) if defined fileno($fh);
 277    }
 278 }
 279
 280 ################################################
 281 ## Open and close.
 282 ##
 283
 284 sub pipe {
 285     @_ and croak 'usage: FileHandle::pipe()';
 286     my $readfh = new FileHandle;
 287     my $writefh = new FileHandle;
 288     pipe($readfh, $writefh)
 289         or return undef;
 290     ($readfh, $writefh);
 291 }
 292
 293 sub _open_mode_string {
 294     my ($mode) = @_;
 295     $mode =~ /^\+?(<|>>?)$/
 296       or $mode =~ s/^r(\+?)$/$1</
 297       or $mode =~ s/^w(\+?)$/$1>/
 298       or $mode =~ s/^a(\+?)$/$1>>/
 299       or croak "FileHandle: bad open mode: $mode";
 300     $mode;
 301 }
 302
 303 sub open {
 304     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
 305     my ($fh, $file) = @_;
 306     if (@_ > 2) {
 307         my ($mode, $perms) = @_[2, 3];
 308         if ($mode =~ /^\d+$/) {
 309             defined $perms or $perms = 0666;
 310             return sysopen($fh, $file, $mode, $perms);
 311         }
 312         $file = "./" . $file unless $file =~ m#^/#;
 313         $file = _open_mode_string($mode) . " $file\0";
 314     }
 315     open($fh, $file);
 316 }
 317
 318 sub fdopen {
 319     @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
 320     my ($fh, $fd, $mode) = @_;
 321     if (ref($fd) =~ /GLOB\(/) {
 322         # It's a glob reference; remove the star from its name.
 323         ($fd = "".$$fd) =~ s/^\*//;
 324     } elsif ($fd =~ m#^\d+$#) {
 325         # It's an FD number; prefix with "=".
 326         $fd = "=$fd";
 327     }
 328     open($fh, _open_mode_string($mode) . '&' . $fd);
 329 }
 330
 331 sub close {
 332     @_ == 1 or croak 'usage: $fh->close()';
 333     close($_[0]);
 334 }
 335
 336 ################################################
 337 ## Normal I/O functions.
 338 ##
 339
 340 sub fileno {
 341     @_ == 1 or croak 'usage: $fh->fileno()';
 342     fileno($_[0]);
 343 }
 344
 345 sub getc {
 346     @_ == 1 or croak 'usage: $fh->getc()';
 347     getc($_[0]);
 348 }
 349
 350 sub gets {
 351     @_ == 1 or croak 'usage: $fh->gets()';
 352     my ($handle) = @_;
 353     scalar <$handle>;
 354 }
 355
 356 sub eof {
 357     @_ == 1 or croak 'usage: $fh->eof()';
 358     eof($_[0]);
 359 }
 360
 361 sub clearerr {
 362     @_ == 1 or croak 'usage: $fh->clearerr()';
 363     seek($_[0], 0, 1);
 364 }
 365
 366 sub seek {
 367     @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
 368     seek($_[0], $_[1], $_[2]);
 369 }
 370
 371 sub tell {
 372     @_ == 1 or croak 'usage: $fh->tell()';
 373     tell($_[0]);
 374 }
 375
 376 sub print {
 377     @_ or croak 'usage: $fh->print([ARGS])';
 378     my $this = shift;
 379     print $this @_;
 380 }
 381
 382 sub printf {
 383     @_ or croak 'usage: $fh->printf([ARGS])';
 384     my $this = shift;
 385     printf $this @_;
 386 }
 387
 388 sub getline {
 389     @_ == 1 or croak 'usage: $fh->getline';
 390     my $this = shift;
 391     return scalar <$this>;
 392 }
 393
 394 sub getlines {
 395     @_ == 1 or croak 'usage: $fh->getline()';
 396     my $this = shift;
 397     wantarray or croak "Can't call FileHandle::getlines in a scalar context";
 398     return <$this>;
 399 }
 400
 401 ################################################
 402 ## State modification functions.
 403 ##
 404
 405 sub autoflush {
 406     my $old = new SelectSaver qualify($_[0], caller);
 407     my $prev = $|;
 408     $| = @_ > 1 ? $_[1] : 1;
 409     $prev;
 410 }
 411
 412 sub output_field_separator {
 413     my $old = new SelectSaver qualify($_[0], caller);
 414     my $prev = $,;
 415     $, = $_[1] if @_ > 1;
 416     $prev;
 417 }
 418
 419 sub output_record_separator {
 420     my $old = new SelectSaver qualify($_[0], caller);
 421     my $prev = $\;
 422     $\ = $_[1] if @_ > 1;
 423     $prev;
 424 }
 425
 426 sub input_record_separator {
 427     my $old = new SelectSaver qualify($_[0], caller);
 428     my $prev = $/;
 429     $/ = $_[1] if @_ > 1;
 430     $prev;
 431 }
 432
 433 sub input_line_number {
 434     my $old = new SelectSaver qualify($_[0], caller);
 435     my $prev = $.;
 436     $. = $_[1] if @_ > 1;
 437     $prev;
 438 }
 439
 440 sub format_page_number {
 441     my $old = new SelectSaver qualify($_[0], caller);
 442     my $prev = $%;
 443     $% = $_[1] if @_ > 1;
 444     $prev;
 445 }
 446
 447 sub format_lines_per_page {
 448     my $old = new SelectSaver qualify($_[0], caller);
 449     my $prev = $=;
 450     $= = $_[1] if @_ > 1;
 451     $prev;
 452 }
 453
 454 sub format_lines_left {
 455     my $old = new SelectSaver qualify($_[0], caller);
 456     my $prev = $-;
 457     $- = $_[1] if @_ > 1;
 458     $prev;
 459 }
 460
 461 sub format_name {
 462     my $old = new SelectSaver qualify($_[0], caller);
 463     my $prev = $~;
 464     $~ = qualify($_[1], caller) if @_ > 1;
 465     $prev;
 466 }
 467
 468 sub format_top_name {
 469     my $old = new SelectSaver qualify($_[0], caller);
 470     my $prev = $^;
 471     $^ = qualify($_[1], caller) if @_ > 1;
 472     $prev;
 473 }
 474
 475 sub format_line_break_characters {
 476     my $old = new SelectSaver qualify($_[0], caller);
 477     my $prev = $:;
 478     $: = $_[1] if @_ > 1;
 479     $prev;
 480 }
 481
 482 sub format_formfeed {
 483     my $old = new SelectSaver qualify($_[0], caller);
 484     my $prev = $^L;
 485     $^L = $_[1] if @_ > 1;
 486     $prev;
 487 }
 488
 489 1;