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