dist/IO/lib/IO/Handle.pm

   1 package IO::Handle;
   2
   3 =head1 NAME
   4
   5 IO::Handle - supply object methods for I/O handles
   6
   7 =head1 SYNOPSIS
   8
   9     use IO::Handle;
  10
  11     $io = new IO::Handle;
  12     if ($io->fdopen(fileno(STDIN),"r")) {
  13         print $io->getline;
  14         $io->close;
  15     }
  16
  17     $io = new IO::Handle;
  18     if ($io->fdopen(fileno(STDOUT),"w")) {
  19         $io->print("Some text\n");
  20     }
  21
  22     # setvbuf is not available by default on Perls 5.8.0 and later.
  23     use IO::Handle '_IOLBF';
  24     $io->setvbuf($buffer_var, _IOLBF, 1024);
  25
  26     undef $io;       # automatically closes the file if it's open
  27
  28     autoflush STDOUT 1;
  29
  30 =head1 DESCRIPTION
  31
  32 C<IO::Handle> is the base class for all other IO handle classes. It is
  33 not intended that objects of C<IO::Handle> would be created directly,
  34 but instead C<IO::Handle> is inherited from by several other classes
  35 in the IO hierarchy.
  36
  37 If you are reading this documentation, looking for a replacement for
  38 the C<FileHandle> package, then I suggest you read the documentation
  39 for C<IO::File> too.
  40
  41 =head1 CONSTRUCTOR
  42
  43 =over 4
  44
  45 =item new ()
  46
  47 Creates a new C<IO::Handle> object.
  48
  49 =item new_from_fd ( FD, MODE )
  50
  51 Creates an C<IO::Handle> like C<new> does.
  52 It requires two parameters, which are passed to the method C<fdopen>;
  53 if the fdopen fails, the object is destroyed. Otherwise, it is returned
  54 to the caller.
  55
  56 =back
  57
  58 =head1 METHODS
  59
  60 See L<perlfunc> for complete descriptions of each of the following
  61 supported C<IO::Handle> methods, which are just front ends for the
  62 corresponding built-in functions:
  63
  64     $io->close
  65     $io->eof
  66     $io->fcntl( FUNCTION, SCALAR )
  67     $io->fileno
  68     $io->format_write( [FORMAT_NAME] )
  69     $io->getc
  70     $io->ioctl( FUNCTION, SCALAR )
  71     $io->read ( BUF, LEN, [OFFSET] )
  72     $io->print ( ARGS )
  73     $io->printf ( FMT, [ARGS] )
  74     $io->say ( ARGS )
  75     $io->stat
  76     $io->sysread ( BUF, LEN, [OFFSET] )
  77     $io->syswrite ( BUF, [LEN, [OFFSET]] )
  78     $io->truncate ( LEN )
  79
  80 See L<perlvar> for complete descriptions of each of the following
  81 supported C<IO::Handle> methods.  All of them return the previous
  82 value of the attribute and takes an optional single argument that when
  83 given will set the value.  If no argument is given the previous value
  84 is unchanged (except for $io->autoflush will actually turn ON
  85 autoflush by default).
  86
  87     $io->autoflush ( [BOOL] )                         $|
  88     $io->format_page_number( [NUM] )                  $%
  89     $io->format_lines_per_page( [NUM] )               $=
  90     $io->format_lines_left( [NUM] )                   $-
  91     $io->format_name( [STR] )                         $~
  92     $io->format_top_name( [STR] )                     $^
  93     $io->input_line_number( [NUM])                    $.
  94
  95 The following methods are not supported on a per-filehandle basis.
  96
  97     IO::Handle->format_line_break_characters( [STR] ) $:
  98     IO::Handle->format_formfeed( [STR])               $^L
  99     IO::Handle->output_field_separator( [STR] )       $,
 100     IO::Handle->output_record_separator( [STR] )      $\
 101
 102     IO::Handle->input_record_separator( [STR] )       $/
 103
 104 Furthermore, for doing normal I/O you might need these:
 105
 106 =over 4
 107
 108 =item $io->fdopen ( FD, MODE )
 109
 110 C<fdopen> is like an ordinary C<open> except that its first parameter
 111 is not a filename but rather a file handle name, an IO::Handle object,
 112 or a file descriptor number.  (For the documentation of the C<open>
 113 method, see L<IO::File>.)
 114
 115 =item $io->opened
 116
 117 Returns true if the object is currently a valid file descriptor, false
 118 otherwise.
 119
 120 =item $io->getline
 121
 122 This works like <$io> described in L<perlop/"I/O Operators">
 123 except that it's more readable and can be safely called in a
 124 list context but still returns just one line.  If used as the conditional
 125 +within a C<while> or C-style C<for> loop, however, you will need to
 126 +emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>.
 127
 128 =item $io->getlines
 129
 130 This works like <$io> when called in a list context to read all
 131 the remaining lines in a file, except that it's more readable.
 132 It will also croak() if accidentally called in a scalar context.
 133
 134 =item $io->ungetc ( ORD )
 135
 136 Pushes a character with the given ordinal value back onto the given
 137 handle's input stream.  Only one character of pushback per handle is
 138 guaranteed.
 139
 140 =item $io->write ( BUF, LEN [, OFFSET ] )
 141
 142 This C<write> is like C<write> found in C, that is it is the
 143 opposite of read. The wrapper for the perl C<write> function is
 144 called C<format_write>.
 145
 146 =item $io->error
 147
 148 Returns a true value if the given handle has experienced any errors
 149 since it was opened or since the last call to C<clearerr>, or if the
 150 handle is invalid. It only returns false for a valid handle with no
 151 outstanding errors.
 152
 153 =item $io->clearerr
 154
 155 Clear the given handle's error indicator. Returns -1 if the handle is
 156 invalid, 0 otherwise.
 157
 158 =item $io->sync
 159
 160 C<sync> synchronizes a file's in-memory state  with  that  on the
 161 physical medium. C<sync> does not operate at the perlio api level, but
 162 operates on the file descriptor (similar to sysread, sysseek and
 163 systell). This means that any data held at the perlio api level will not
 164 be synchronized. To synchronize data that is buffered at the perlio api
 165 level you must use the flush method. C<sync> is not implemented on all
 166 platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
 167 for an invalid handle. See L<fsync(3c)>.
 168
 169 =item $io->flush
 170
 171 C<flush> causes perl to flush any buffered data at the perlio api level.
 172 Any unread data in the buffer will be discarded, and any unwritten data
 173 will be written to the underlying file descriptor. Returns "0 but true"
 174 on success, C<undef> on error.
 175
 176 =item $io->printflush ( ARGS )
 177
 178 Turns on autoflush, print ARGS and then restores the autoflush status of the
 179 C<IO::Handle> object. Returns the return value from print.
 180
 181 =item $io->blocking ( [ BOOL ] )
 182
 183 If called with an argument C<blocking> will turn on non-blocking IO if
 184 C<BOOL> is false, and turn it off if C<BOOL> is true.
 185
 186 C<blocking> will return the value of the previous setting, or the
 187 current setting if C<BOOL> is not given.
 188
 189 If an error occurs C<blocking> will return undef and C<$!> will be set.
 190
 191 =back
 192
 193
 194 If the C functions setbuf() and/or setvbuf() are available, then
 195 C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
 196 policy for an IO::Handle.  The calling sequences for the Perl functions
 197 are the same as their C counterparts--including the constants C<_IOFBF>,
 198 C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
 199 specifies a scalar variable to use as a buffer. You should only
 200 change the buffer before any I/O, or immediately after calling flush.
 201
 202 WARNING: The IO::Handle::setvbuf() is not available by default on
 203 Perls 5.8.0 and later because setvbuf() is rather specific to using
 204 the stdio library, while Perl prefers the new perlio subsystem instead.
 205
 206 WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
 207 be modified> in any way until the IO::Handle is closed or C<setbuf> or
 208 C<setvbuf> is called again, or memory corruption may result! Remember that
 209 the order of global destruction is undefined, so even if your buffer
 210 variable remains in scope until program termination, it may be undefined
 211 before the file IO::Handle is closed. Note that you need to import the
 212 constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
 213 returns nothing. setvbuf returns "0 but true", on success, C<undef> on
 214 failure.
 215
 216 Lastly, there is a special method for working under B<-T> and setuid/gid
 217 scripts:
 218
 219 =over 4
 220
 221 =item $io->untaint
 222
 223 Marks the object as taint-clean, and as such data read from it will also
 224 be considered taint-clean. Note that this is a very trusting action to
 225 take, and appropriate consideration for the data source and potential
 226 vulnerability should be kept in mind. Returns 0 on success, -1 if setting
 227 the taint-clean flag failed. (eg invalid handle)
 228
 229 =back
 230
 231 =head1 NOTE
 232
 233 An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
 234 the C<Symbol> package).  Some modules that
 235 inherit from C<IO::Handle> may want to keep object related variables
 236 in the hash table part of the GLOB. In an attempt to prevent modules
 237 trampling on each other I propose the that any such module should prefix
 238 its variables with its own name separated by _'s. For example the IO::Socket
 239 module keeps a C<timeout> variable in 'io_socket_timeout'.
 240
 241 =head1 SEE ALSO
 242
 243 L<perlfunc>,
 244 L<perlop/"I/O Operators">,
 245 L<IO::File>
 246
 247 =head1 BUGS
 248
 249 Due to backwards compatibility, all filehandles resemble objects
 250 of class C<IO::Handle>, or actually classes derived from that class.
 251 They actually aren't.  Which means you can't derive your own
 252 class from C<IO::Handle> and inherit those methods.
 253
 254 =head1 HISTORY
 255
 256 Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
 257
 258 =cut
 259
 260 use 5.006_001;
 261 use strict;
 262 our($VERSION, @EXPORT_OK, @ISA);
 263 use Carp;
 264 use Symbol;
 265 use SelectSaver;
 266 use IO ();      # Load the XS module
 267
 268 require Exporter;
 269 @ISA = qw(Exporter);
 270
 271 $VERSION = "1.28";
 272 $VERSION = eval $VERSION;
 273
 274 @EXPORT_OK = qw(
 275     autoflush
 276     output_field_separator
 277     output_record_separator
 278     input_record_separator
 279     input_line_number
 280     format_page_number
 281     format_lines_per_page
 282     format_lines_left
 283     format_name
 284     format_top_name
 285     format_line_break_characters
 286     format_formfeed
 287     format_write
 288
 289     print
 290     printf
 291     say
 292     getline
 293     getlines
 294
 295     printflush
 296     flush
 297
 298     SEEK_SET
 299     SEEK_CUR
 300     SEEK_END
 301     _IOFBF
 302     _IOLBF
 303     _IONBF
 304 );
 305
 306 ################################################
 307 ## Constructors, destructors.
 308 ##
 309
 310 sub new {
 311     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 312     @_ == 1 or croak "usage: new $class";
 313     my $io = gensym;
 314     bless $io, $class;
 315 }
 316
 317 sub new_from_fd {
 318     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 319     @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
 320     my $io = gensym;
 321     shift;
 322     IO::Handle::fdopen($io, @_)
 323         or return undef;
 324     bless $io, $class;
 325 }
 326
 327 #
 328 # There is no need for DESTROY to do anything, because when the
 329 # last reference to an IO object is gone, Perl automatically
 330 # closes its associated files (if any).  However, to avoid any
 331 # attempts to autoload DESTROY, we here define it to do nothing.
 332 #
 333 sub DESTROY {}
 334
 335
 336 ################################################
 337 ## Open and close.
 338 ##
 339
 340 sub _open_mode_string {
 341     my ($mode) = @_;
 342     $mode =~ /^\+?(<|>>?)$/
 343       or $mode =~ s/^r(\+?)$/$1</
 344       or $mode =~ s/^w(\+?)$/$1>/
 345       or $mode =~ s/^a(\+?)$/$1>>/
 346       or croak "IO::Handle: bad open mode: $mode";
 347     $mode;
 348 }
 349
 350 sub fdopen {
 351     @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
 352     my ($io, $fd, $mode) = @_;
 353     local(*GLOB);
 354
 355     if (ref($fd) && "".$fd =~ /GLOB\(/o) {
 356         # It's a glob reference; Alias it as we cannot get name of anon GLOBs
 357         my $n = qualify(*GLOB);
 358         *GLOB = *{*$fd};
 359         $fd =  $n;
 360     } elsif ($fd =~ m#^\d+$#) {
 361         # It's an FD number; prefix with "=".
 362         $fd = "=$fd";
 363     }
 364
 365     open($io, _open_mode_string($mode) . '&' . $fd)
 366         ? $io : undef;
 367 }
 368
 369 sub close {
 370     @_ == 1 or croak 'usage: $io->close()';
 371     my($io) = @_;
 372
 373     close($io);
 374 }
 375
 376 ################################################
 377 ## Normal I/O functions.
 378 ##
 379
 380 # flock
 381 # select
 382
 383 sub opened {
 384     @_ == 1 or croak 'usage: $io->opened()';
 385     defined fileno($_[0]);
 386 }
 387
 388 sub fileno {
 389     @_ == 1 or croak 'usage: $io->fileno()';
 390     fileno($_[0]);
 391 }
 392
 393 sub getc {
 394     @_ == 1 or croak 'usage: $io->getc()';
 395     getc($_[0]);
 396 }
 397
 398 sub eof {
 399     @_ == 1 or croak 'usage: $io->eof()';
 400     eof($_[0]);
 401 }
 402
 403 sub print {
 404     @_ or croak 'usage: $io->print(ARGS)';
 405     my $this = shift;
 406     print $this @_;
 407 }
 408
 409 sub printf {
 410     @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
 411     my $this = shift;
 412     printf $this @_;
 413 }
 414
 415 sub say {
 416     @_ or croak 'usage: $io->say(ARGS)';
 417     my $this = shift;
 418     local $\ = "\n";
 419     print $this @_;
 420 }
 421
 422 sub getline {
 423     @_ == 1 or croak 'usage: $io->getline()';
 424     my $this = shift;
 425     return scalar <$this>;
 426 }
 427
 428 *gets = \&getline;  # deprecated
 429
 430 sub getlines {
 431     @_ == 1 or croak 'usage: $io->getlines()';
 432     wantarray or
 433         croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
 434     my $this = shift;
 435     return <$this>;
 436 }
 437
 438 sub truncate {
 439     @_ == 2 or croak 'usage: $io->truncate(LEN)';
 440     truncate($_[0], $_[1]);
 441 }
 442
 443 sub read {
 444     @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
 445     read($_[0], $_[1], $_[2], $_[3] || 0);
 446 }
 447
 448 sub sysread {
 449     @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
 450     sysread($_[0], $_[1], $_[2], $_[3] || 0);
 451 }
 452
 453 sub write {
 454     @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
 455     local($\) = "";
 456     $_[2] = length($_[1]) unless defined $_[2];
 457     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 458 }
 459
 460 sub syswrite {
 461     @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
 462     if (defined($_[2])) {
 463         syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 464     } else {
 465         syswrite($_[0], $_[1]);
 466     }
 467 }
 468
 469 sub stat {
 470     @_ == 1 or croak 'usage: $io->stat()';
 471     stat($_[0]);
 472 }
 473
 474 ################################################
 475 ## State modification functions.
 476 ##
 477
 478 sub autoflush {
 479     my $old = new SelectSaver qualify($_[0], caller);
 480     my $prev = $|;
 481     $| = @_ > 1 ? $_[1] : 1;
 482     $prev;
 483 }
 484
 485 sub output_field_separator {
 486     carp "output_field_separator is not supported on a per-handle basis"
 487         if ref($_[0]);
 488     my $prev = $,;
 489     $, = $_[1] if @_ > 1;
 490     $prev;
 491 }
 492
 493 sub output_record_separator {
 494     carp "output_record_separator is not supported on a per-handle basis"
 495         if ref($_[0]);
 496     my $prev = $\;
 497     $\ = $_[1] if @_ > 1;
 498     $prev;
 499 }
 500
 501 sub input_record_separator {
 502     carp "input_record_separator is not supported on a per-handle basis"
 503         if ref($_[0]);
 504     my $prev = $/;
 505     $/ = $_[1] if @_ > 1;
 506     $prev;
 507 }
 508
 509 sub input_line_number {
 510     local $.;
 511     () = tell qualify($_[0], caller) if ref($_[0]);
 512     my $prev = $.;
 513     $. = $_[1] if @_ > 1;
 514     $prev;
 515 }
 516
 517 sub format_page_number {
 518     my $old;
 519     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 520     my $prev = $%;
 521     $% = $_[1] if @_ > 1;
 522     $prev;
 523 }
 524
 525 sub format_lines_per_page {
 526     my $old;
 527     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 528     my $prev = $=;
 529     $= = $_[1] if @_ > 1;
 530     $prev;
 531 }
 532
 533 sub format_lines_left {
 534     my $old;
 535     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 536     my $prev = $-;
 537     $- = $_[1] if @_ > 1;
 538     $prev;
 539 }
 540
 541 sub format_name {
 542     my $old;
 543     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 544     my $prev = $~;
 545     $~ = qualify($_[1], caller) if @_ > 1;
 546     $prev;
 547 }
 548
 549 sub format_top_name {
 550     my $old;
 551     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 552     my $prev = $^;
 553     $^ = qualify($_[1], caller) if @_ > 1;
 554     $prev;
 555 }
 556
 557 sub format_line_break_characters {
 558     carp "format_line_break_characters is not supported on a per-handle basis"
 559         if ref($_[0]);
 560     my $prev = $:;
 561     $: = $_[1] if @_ > 1;
 562     $prev;
 563 }
 564
 565 sub format_formfeed {
 566     carp "format_formfeed is not supported on a per-handle basis"
 567         if ref($_[0]);
 568     my $prev = $^L;
 569     $^L = $_[1] if @_ > 1;
 570     $prev;
 571 }
 572
 573 sub formline {
 574     my $io = shift;
 575     my $picture = shift;
 576     local($^A) = $^A;
 577     local($\) = "";
 578     formline($picture, @_);
 579     print $io $^A;
 580 }
 581
 582 sub format_write {
 583     @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
 584     if (@_ == 2) {
 585         my ($io, $fmt) = @_;
 586         my $oldfmt = $io->format_name(qualify($fmt,caller));
 587         CORE::write($io);
 588         $io->format_name($oldfmt);
 589     } else {
 590         CORE::write($_[0]);
 591     }
 592 }
 593
 594 sub fcntl {
 595     @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
 596     my ($io, $op) = @_;
 597     return fcntl($io, $op, $_[2]);
 598 }
 599
 600 sub ioctl {
 601     @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
 602     my ($io, $op) = @_;
 603     return ioctl($io, $op, $_[2]);
 604 }
 605
 606 # this sub is for compatibility with older releases of IO that used
 607 # a sub called constant to determine if a constant existed -- GMB
 608 #
 609 # The SEEK_* and _IO?BF constants were the only constants at that time
 610 # any new code should just chech defined(&CONSTANT_NAME)
 611
 612 sub constant {
 613     no strict 'refs';
 614     my $name = shift;
 615     (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
 616         ? &{$name}() : undef;
 617 }
 618
 619
 620 # so that flush.pl can be deprecated
 621
 622 sub printflush {
 623     my $io = shift;
 624     my $old;
 625     $old = new SelectSaver qualify($io, caller) if ref($io);
 626     local $| = 1;
 627     if(ref($io)) {
 628         print $io @_;
 629     }
 630     else {
 631         print @_;
 632     }
 633 }
 634
 635 1;