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