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