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