ext/IO/lib/IO/Handle.pm

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