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 = IO::Handle->new();
  12     if ($io->fdopen(fileno(STDIN),"r")) {
  13         print $io->getline;
  14         $io->close;
  15     }
  16
  17     $io = IO::Handle->new();
  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 somewhat like C<write> found in C, in that it is the
 143 opposite of read. The wrapper for the perl C<write> function is
 144 called C<format_write>. However, whilst the C C<write> function returns
 145 the number of bytes written, this C<write> function simply returns true
 146 if successful (like C<print>). A more C-like C<write> is C<syswrite>
 147 (see above).
 148
 149 =item $io->error
 150
 151 Returns a true value if the given handle has experienced any errors
 152 since it was opened or since the last call to C<clearerr>, or if the
 153 handle is invalid. It only returns false for a valid handle with no
 154 outstanding errors.
 155
 156 =item $io->clearerr
 157
 158 Clear the given handle's error indicator. Returns -1 if the handle is
 159 invalid, 0 otherwise.
 160
 161 =item $io->sync
 162
 163 C<sync> synchronizes a file's in-memory state  with  that  on the
 164 physical medium. C<sync> does not operate at the perlio api level, but
 165 operates on the file descriptor (similar to sysread, sysseek and
 166 systell). This means that any data held at the perlio api level will not
 167 be synchronized. To synchronize data that is buffered at the perlio api
 168 level you must use the flush method. C<sync> is not implemented on all
 169 platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
 170 for an invalid handle. See L<fsync(3c)>.
 171
 172 =item $io->flush
 173
 174 C<flush> causes perl to flush any buffered data at the perlio api level.
 175 Any unread data in the buffer will be discarded, and any unwritten data
 176 will be written to the underlying file descriptor. Returns "0 but true"
 177 on success, C<undef> on error.
 178
 179 =item $io->printflush ( ARGS )
 180
 181 Turns on autoflush, print ARGS and then restores the autoflush status of the
 182 C<IO::Handle> object. Returns the return value from print.
 183
 184 =item $io->blocking ( [ BOOL ] )
 185
 186 If called with an argument C<blocking> will turn on non-blocking IO if
 187 C<BOOL> is false, and turn it off if C<BOOL> is true.
 188
 189 C<blocking> will return the value of the previous setting, or the
 190 current setting if C<BOOL> is not given.
 191
 192 If an error occurs C<blocking> will return undef and C<$!> will be set.
 193
 194 =back
 195
 196
 197 If the C functions setbuf() and/or setvbuf() are available, then
 198 C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
 199 policy for an IO::Handle.  The calling sequences for the Perl functions
 200 are the same as their C counterparts--including the constants C<_IOFBF>,
 201 C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
 202 specifies a scalar variable to use as a buffer. You should only
 203 change the buffer before any I/O, or immediately after calling flush.
 204
 205 WARNING: The IO::Handle::setvbuf() is not available by default on
 206 Perls 5.8.0 and later because setvbuf() is rather specific to using
 207 the stdio library, while Perl prefers the new perlio subsystem instead.
 208
 209 WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
 210 be modified> in any way until the IO::Handle is closed or C<setbuf> or
 211 C<setvbuf> is called again, or memory corruption may result! Remember that
 212 the order of global destruction is undefined, so even if your buffer
 213 variable remains in scope until program termination, it may be undefined
 214 before the file IO::Handle is closed. Note that you need to import the
 215 constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
 216 returns nothing. setvbuf returns "0 but true", on success, C<undef> on
 217 failure.
 218
 219 Lastly, there is a special method for working under B<-T> and setuid/gid
 220 scripts:
 221
 222 =over 4
 223
 224 =item $io->untaint
 225
 226 Marks the object as taint-clean, and as such data read from it will also
 227 be considered taint-clean. Note that this is a very trusting action to
 228 take, and appropriate consideration for the data source and potential
 229 vulnerability should be kept in mind. Returns 0 on success, -1 if setting
 230 the taint-clean flag failed. (eg invalid handle)
 231
 232 =back
 233
 234 =head1 NOTE
 235
 236 An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
 237 the C<Symbol> package).  Some modules that
 238 inherit from C<IO::Handle> may want to keep object related variables
 239 in the hash table part of the GLOB. In an attempt to prevent modules
 240 trampling on each other I propose the that any such module should prefix
 241 its variables with its own name separated by _'s. For example the IO::Socket
 242 module keeps a C<timeout> variable in 'io_socket_timeout'.
 243
 244 =head1 SEE ALSO
 245
 246 L<perlfunc>,
 247 L<perlop/"I/O Operators">,
 248 L<IO::File>
 249
 250 =head1 BUGS
 251
 252 Due to backwards compatibility, all filehandles resemble objects
 253 of class C<IO::Handle>, or actually classes derived from that class.
 254 They actually aren't.  Which means you can't derive your own
 255 class from C<IO::Handle> and inherit those methods.
 256
 257 =head1 HISTORY
 258
 259 Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
 260
 261 =cut
 262
 263 use 5.006_001;
 264 use strict;
 265 our($VERSION, @EXPORT_OK, @ISA);
 266 use Carp;
 267 use Symbol;
 268 use SelectSaver;
 269 use IO ();      # Load the XS module
 270
 271 require Exporter;
 272 @ISA = qw(Exporter);
 273
 274 $VERSION = "1.34";
 275 $VERSION = eval $VERSION;
 276
 277 @EXPORT_OK = qw(
 278     autoflush
 279     output_field_separator
 280     output_record_separator
 281     input_record_separator
 282     input_line_number
 283     format_page_number
 284     format_lines_per_page
 285     format_lines_left
 286     format_name
 287     format_top_name
 288     format_line_break_characters
 289     format_formfeed
 290     format_write
 291
 292     print
 293     printf
 294     say
 295     getline
 296     getlines
 297
 298     printflush
 299     flush
 300
 301     SEEK_SET
 302     SEEK_CUR
 303     SEEK_END
 304     _IOFBF
 305     _IOLBF
 306     _IONBF
 307 );
 308
 309 ################################################
 310 ## Constructors, destructors.
 311 ##
 312
 313 sub new {
 314     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 315     if (@_ != 1) {
 316         # Since perl will automatically require IO::File if needed, but
 317         # also initialises IO::File's @ISA as part of the core we must
 318         # ensure IO::File is loaded if IO::Handle is. This avoids effect-
 319         # ively "half-loading" IO::File.
 320         if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) {
 321             require IO::File;
 322             shift;
 323             return IO::File::->new(@_);
 324         }
 325         croak "usage: $class->new()";
 326     }
 327     my $io = gensym;
 328     bless $io, $class;
 329 }
 330
 331 sub new_from_fd {
 332     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 333     @_ == 3 or croak "usage: $class->new_from_fd(FD, MODE)";
 334     my $io = gensym;
 335     shift;
 336     IO::Handle::fdopen($io, @_)
 337         or return undef;
 338     bless $io, $class;
 339 }
 340
 341 #
 342 # There is no need for DESTROY to do anything, because when the
 343 # last reference to an IO object is gone, Perl automatically
 344 # closes its associated files (if any).  However, to avoid any
 345 # attempts to autoload DESTROY, we here define it to do nothing.
 346 #
 347 sub DESTROY {}
 348
 349
 350 ################################################
 351 ## Open and close.
 352 ##
 353
 354 sub _open_mode_string {
 355     my ($mode) = @_;
 356     $mode =~ /^\+?(<|>>?)$/
 357       or $mode =~ s/^r(\+?)$/$1</
 358       or $mode =~ s/^w(\+?)$/$1>/
 359       or $mode =~ s/^a(\+?)$/$1>>/
 360       or croak "IO::Handle: bad open mode: $mode";
 361     $mode;
 362 }
 363
 364 sub fdopen {
 365     @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
 366     my ($io, $fd, $mode) = @_;
 367     local(*GLOB);
 368
 369     if (ref($fd) && "".$fd =~ /GLOB\(/o) {
 370         # It's a glob reference; Alias it as we cannot get name of anon GLOBs
 371         my $n = qualify(*GLOB);
 372         *GLOB = *{*$fd};
 373         $fd =  $n;
 374     } elsif ($fd =~ m#^\d+$#) {
 375         # It's an FD number; prefix with "=".
 376         $fd = "=$fd";
 377     }
 378
 379     open($io, _open_mode_string($mode) . '&' . $fd)
 380         ? $io : undef;
 381 }
 382
 383 sub close {
 384     @_ == 1 or croak 'usage: $io->close()';
 385     my($io) = @_;
 386
 387     close($io);
 388 }
 389
 390 ################################################
 391 ## Normal I/O functions.
 392 ##
 393
 394 # flock
 395 # select
 396
 397 sub opened {
 398     @_ == 1 or croak 'usage: $io->opened()';
 399     defined fileno($_[0]);
 400 }
 401
 402 sub fileno {
 403     @_ == 1 or croak 'usage: $io->fileno()';
 404     fileno($_[0]);
 405 }
 406
 407 sub getc {
 408     @_ == 1 or croak 'usage: $io->getc()';
 409     getc($_[0]);
 410 }
 411
 412 sub eof {
 413     @_ == 1 or croak 'usage: $io->eof()';
 414     eof($_[0]);
 415 }
 416
 417 sub print {
 418     @_ or croak 'usage: $io->print(ARGS)';
 419     my $this = shift;
 420     print $this @_;
 421 }
 422
 423 sub printf {
 424     @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
 425     my $this = shift;
 426     printf $this @_;
 427 }
 428
 429 sub say {
 430     @_ or croak 'usage: $io->say(ARGS)';
 431     my $this = shift;
 432     local $\ = "\n";
 433     print $this @_;
 434 }
 435
 436 # Special XS wrapper to make them inherit lexical hints from the caller.
 437 _create_getline_subs( <<'END' ) or die $@;
 438 sub getline {
 439     @_ == 1 or croak 'usage: $io->getline()';
 440     my $this = shift;
 441     return scalar <$this>;
 442 }
 443
 444 sub getlines {
 445     @_ == 1 or croak 'usage: $io->getlines()';
 446     wantarray or
 447         croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
 448     my $this = shift;
 449     return <$this>;
 450 }
 451 1; # return true for error checking
 452 END
 453
 454 *gets = \&getline;  # deprecated
 455
 456 sub truncate {
 457     @_ == 2 or croak 'usage: $io->truncate(LEN)';
 458     truncate($_[0], $_[1]);
 459 }
 460
 461 sub read {
 462     @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
 463     read($_[0], $_[1], $_[2], $_[3] || 0);
 464 }
 465
 466 sub sysread {
 467     @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
 468     sysread($_[0], $_[1], $_[2], $_[3] || 0);
 469 }
 470
 471 sub write {
 472     @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
 473     local($\) = "";
 474     $_[2] = length($_[1]) unless defined $_[2];
 475     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 476 }
 477
 478 sub syswrite {
 479     @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
 480     if (defined($_[2])) {
 481         syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 482     } else {
 483         syswrite($_[0], $_[1]);
 484     }
 485 }
 486
 487 sub stat {
 488     @_ == 1 or croak 'usage: $io->stat()';
 489     stat($_[0]);
 490 }
 491
 492 ################################################
 493 ## State modification functions.
 494 ##
 495
 496 sub autoflush {
 497     my $old = new SelectSaver qualify($_[0], caller);
 498     my $prev = $|;
 499     $| = @_ > 1 ? $_[1] : 1;
 500     $prev;
 501 }
 502
 503 sub output_field_separator {
 504     carp "output_field_separator is not supported on a per-handle basis"
 505         if ref($_[0]);
 506     my $prev = $,;
 507     $, = $_[1] if @_ > 1;
 508     $prev;
 509 }
 510
 511 sub output_record_separator {
 512     carp "output_record_separator is not supported on a per-handle basis"
 513         if ref($_[0]);
 514     my $prev = $\;
 515     $\ = $_[1] if @_ > 1;
 516     $prev;
 517 }
 518
 519 sub input_record_separator {
 520     carp "input_record_separator is not supported on a per-handle basis"
 521         if ref($_[0]);
 522     my $prev = $/;
 523     $/ = $_[1] if @_ > 1;
 524     $prev;
 525 }
 526
 527 sub input_line_number {
 528     local $.;
 529     () = tell qualify($_[0], caller) if ref($_[0]);
 530     my $prev = $.;
 531     $. = $_[1] if @_ > 1;
 532     $prev;
 533 }
 534
 535 sub format_page_number {
 536     my $old;
 537     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 538     my $prev = $%;
 539     $% = $_[1] if @_ > 1;
 540     $prev;
 541 }
 542
 543 sub format_lines_per_page {
 544     my $old;
 545     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 546     my $prev = $=;
 547     $= = $_[1] if @_ > 1;
 548     $prev;
 549 }
 550
 551 sub format_lines_left {
 552     my $old;
 553     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 554     my $prev = $-;
 555     $- = $_[1] if @_ > 1;
 556     $prev;
 557 }
 558
 559 sub format_name {
 560     my $old;
 561     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 562     my $prev = $~;
 563     $~ = qualify($_[1], caller) if @_ > 1;
 564     $prev;
 565 }
 566
 567 sub format_top_name {
 568     my $old;
 569     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 570     my $prev = $^;
 571     $^ = qualify($_[1], caller) if @_ > 1;
 572     $prev;
 573 }
 574
 575 sub format_line_break_characters {
 576     carp "format_line_break_characters is not supported on a per-handle basis"
 577         if ref($_[0]);
 578     my $prev = $:;
 579     $: = $_[1] if @_ > 1;
 580     $prev;
 581 }
 582
 583 sub format_formfeed {
 584     carp "format_formfeed is not supported on a per-handle basis"
 585         if ref($_[0]);
 586     my $prev = $^L;
 587     $^L = $_[1] if @_ > 1;
 588     $prev;
 589 }
 590
 591 sub formline {
 592     my $io = shift;
 593     my $picture = shift;
 594     local($^A) = $^A;
 595     local($\) = "";
 596     formline($picture, @_);
 597     print $io $^A;
 598 }
 599
 600 sub format_write {
 601     @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
 602     if (@_ == 2) {
 603         my ($io, $fmt) = @_;
 604         my $oldfmt = $io->format_name(qualify($fmt,caller));
 605         CORE::write($io);
 606         $io->format_name($oldfmt);
 607     } else {
 608         CORE::write($_[0]);
 609     }
 610 }
 611
 612 sub fcntl {
 613     @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
 614     my ($io, $op) = @_;
 615     return fcntl($io, $op, $_[2]);
 616 }
 617
 618 sub ioctl {
 619     @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
 620     my ($io, $op) = @_;
 621     return ioctl($io, $op, $_[2]);
 622 }
 623
 624 # this sub is for compatibility with older releases of IO that used
 625 # a sub called constant to determine if a constant existed -- GMB
 626 #
 627 # The SEEK_* and _IO?BF constants were the only constants at that time
 628 # any new code should just chech defined(&CONSTANT_NAME)
 629
 630 sub constant {
 631     no strict 'refs';
 632     my $name = shift;
 633     (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
 634         ? &{$name}() : undef;
 635 }
 636
 637
 638 # so that flush.pl can be deprecated
 639
 640 sub printflush {
 641     my $io = shift;
 642     my $old;
 643     $old = new SelectSaver qualify($io, caller) if ref($io);
 644     local $| = 1;
 645     if(ref($io)) {
 646         print $io @_;
 647     }
 648     else {
 649         print @_;
 650     }
 651 }
 652
 653 1;