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.
 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: The IO::Handle::setvbuf() is not available by default on
 197 Perls 5.8.0 and later because setvbuf() is rather specific to using
 198 the stdio library, while Perl prefers the new perlio subsystem instead.
 199
 200 WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
 201 be modified> in any way until the IO::Handle is closed or C<setbuf> or
 202 C<setvbuf> is called again, or memory corruption may result! Remember that
 203 the order of global destruction is undefined, so even if your buffer
 204 variable remains in scope until program termination, it may be undefined
 205 before the file IO::Handle is closed. Note that you need to import the
 206 constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
 207 returns nothing. setvbuf returns "0 but true", on success, C<undef> on
 208 failure.
 209
 210 Lastly, there is a special method for working under B<-T> and setuid/gid
 211 scripts:
 212
 213 =over 4
 214
 215 =item $io->untaint
 216
 217 Marks the object as taint-clean, and as such data read from it will also
 218 be considered taint-clean. Note that this is a very trusting action to
 219 take, and appropriate consideration for the data source and potential
 220 vulnerability should be kept in mind. Returns 0 on success, -1 if setting
 221 the taint-clean flag failed. (eg invalid handle)
 222
 223 =back
 224
 225 =head1 NOTE
 226
 227 An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
 228 the C<Symbol> package).  Some modules that
 229 inherit from C<IO::Handle> may want to keep object related variables
 230 in the hash table part of the GLOB. In an attempt to prevent modules
 231 trampling on each other I propose the that any such module should prefix
 232 its variables with its own name separated by _'s. For example the IO::Socket
 233 module keeps a C<timeout> variable in 'io_socket_timeout'.
 234
 235 =head1 SEE ALSO
 236
 237 L<perlfunc>,
 238 L<perlop/"I/O Operators">,
 239 L<IO::File>
 240
 241 =head1 BUGS
 242
 243 Due to backwards compatibility, all filehandles resemble objects
 244 of class C<IO::Handle>, or actually classes derived from that class.
 245 They actually aren't.  Which means you can't derive your own
 246 class from C<IO::Handle> and inherit those methods.
 247
 248 =head1 HISTORY
 249
 250 Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
 251
 252 =cut
 253
 254 use 5.006_001;
 255 use strict;
 256 our($VERSION, @EXPORT_OK, @ISA);
 257 use Carp;
 258 use Symbol;
 259 use SelectSaver;
 260 use IO ();      # Load the XS module
 261
 262 require Exporter;
 263 @ISA = qw(Exporter);
 264
 265 $VERSION = "1.24";
 266 $VERSION = eval $VERSION;
 267
 268 @EXPORT_OK = qw(
 269     autoflush
 270     output_field_separator
 271     output_record_separator
 272     input_record_separator
 273     input_line_number
 274     format_page_number
 275     format_lines_per_page
 276     format_lines_left
 277     format_name
 278     format_top_name
 279     format_line_break_characters
 280     format_formfeed
 281     format_write
 282
 283     print
 284     printf
 285     getline
 286     getlines
 287
 288     printflush
 289     flush
 290
 291     SEEK_SET
 292     SEEK_CUR
 293     SEEK_END
 294     _IOFBF
 295     _IOLBF
 296     _IONBF
 297 );
 298
 299 ################################################
 300 ## Constructors, destructors.
 301 ##
 302
 303 sub new {
 304     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 305     @_ == 1 or croak "usage: new $class";
 306     my $io = gensym;
 307     bless $io, $class;
 308 }
 309
 310 sub new_from_fd {
 311     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 312     @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
 313     my $io = gensym;
 314     shift;
 315     IO::Handle::fdopen($io, @_)
 316         or return undef;
 317     bless $io, $class;
 318 }
 319
 320 #
 321 # There is no need for DESTROY to do anything, because when the
 322 # last reference to an IO object is gone, Perl automatically
 323 # closes its associated files (if any).  However, to avoid any
 324 # attempts to autoload DESTROY, we here define it to do nothing.
 325 #
 326 sub DESTROY {}
 327
 328
 329 ################################################
 330 ## Open and close.
 331 ##
 332
 333 sub _open_mode_string {
 334     my ($mode) = @_;
 335     $mode =~ /^\+?(<|>>?)$/
 336       or $mode =~ s/^r(\+?)$/$1</
 337       or $mode =~ s/^w(\+?)$/$1>/
 338       or $mode =~ s/^a(\+?)$/$1>>/
 339       or croak "IO::Handle: bad open mode: $mode";
 340     $mode;
 341 }
 342
 343 sub fdopen {
 344     @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
 345     my ($io, $fd, $mode) = @_;
 346     local(*GLOB);
 347
 348     if (ref($fd) && "".$fd =~ /GLOB\(/o) {
 349         # It's a glob reference; Alias it as we cannot get name of anon GLOBs
 350         my $n = qualify(*GLOB);
 351         *GLOB = *{*$fd};
 352         $fd =  $n;
 353     } elsif ($fd =~ m#^\d+$#) {
 354         # It's an FD number; prefix with "=".
 355         $fd = "=$fd";
 356     }
 357
 358     open($io, _open_mode_string($mode) . '&' . $fd)
 359         ? $io : undef;
 360 }
 361
 362 sub close {
 363     @_ == 1 or croak 'usage: $io->close()';
 364     my($io) = @_;
 365
 366     close($io);
 367 }
 368
 369 ################################################
 370 ## Normal I/O functions.
 371 ##
 372
 373 # flock
 374 # select
 375
 376 sub opened {
 377     @_ == 1 or croak 'usage: $io->opened()';
 378     defined fileno($_[0]);
 379 }
 380
 381 sub fileno {
 382     @_ == 1 or croak 'usage: $io->fileno()';
 383     fileno($_[0]);
 384 }
 385
 386 sub getc {
 387     @_ == 1 or croak 'usage: $io->getc()';
 388     getc($_[0]);
 389 }
 390
 391 sub eof {
 392     @_ == 1 or croak 'usage: $io->eof()';
 393     eof($_[0]);
 394 }
 395
 396 sub print {
 397     @_ or croak 'usage: $io->print(ARGS)';
 398     my $this = shift;
 399     print $this @_;
 400 }
 401
 402 sub printf {
 403     @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
 404     my $this = shift;
 405     printf $this @_;
 406 }
 407
 408 sub getline {
 409     @_ == 1 or croak 'usage: $io->getline()';
 410     my $this = shift;
 411     return scalar <$this>;
 412 }
 413
 414 *gets = \&getline;  # deprecated
 415
 416 sub getlines {
 417     @_ == 1 or croak 'usage: $io->getlines()';
 418     wantarray or
 419         croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
 420     my $this = shift;
 421     return <$this>;
 422 }
 423
 424 sub truncate {
 425     @_ == 2 or croak 'usage: $io->truncate(LEN)';
 426     truncate($_[0], $_[1]);
 427 }
 428
 429 sub read {
 430     @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
 431     read($_[0], $_[1], $_[2], $_[3] || 0);
 432 }
 433
 434 sub sysread {
 435     @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
 436     sysread($_[0], $_[1], $_[2], $_[3] || 0);
 437 }
 438
 439 sub write {
 440     @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
 441     local($\) = "";
 442     $_[2] = length($_[1]) unless defined $_[2];
 443     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 444 }
 445
 446 sub syswrite {
 447     @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
 448     if (defined($_[2])) {
 449         syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 450     } else {
 451         syswrite($_[0], $_[1]);
 452     }
 453 }
 454
 455 sub stat {
 456     @_ == 1 or croak 'usage: $io->stat()';
 457     stat($_[0]);
 458 }
 459
 460 ################################################
 461 ## State modification functions.
 462 ##
 463
 464 sub autoflush {
 465     my $old = new SelectSaver qualify($_[0], caller);
 466     my $prev = $|;
 467     $| = @_ > 1 ? $_[1] : 1;
 468     $prev;
 469 }
 470
 471 sub output_field_separator {
 472     carp "output_field_separator is not supported on a per-handle basis"
 473         if ref($_[0]);
 474     my $prev = $,;
 475     $, = $_[1] if @_ > 1;
 476     $prev;
 477 }
 478
 479 sub output_record_separator {
 480     carp "output_record_separator is not supported on a per-handle basis"
 481         if ref($_[0]);
 482     my $prev = $\;
 483     $\ = $_[1] if @_ > 1;
 484     $prev;
 485 }
 486
 487 sub input_record_separator {
 488     carp "input_record_separator is not supported on a per-handle basis"
 489         if ref($_[0]);
 490     my $prev = $/;
 491     $/ = $_[1] if @_ > 1;
 492     $prev;
 493 }
 494
 495 sub input_line_number {
 496     local $.;
 497     () = tell qualify($_[0], caller) if ref($_[0]);
 498     my $prev = $.;
 499     $. = $_[1] if @_ > 1;
 500     $prev;
 501 }
 502
 503 sub format_page_number {
 504     my $old;
 505     $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;
 513     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 514     my $prev = $=;
 515     $= = $_[1] if @_ > 1;
 516     $prev;
 517 }
 518
 519 sub format_lines_left {
 520     my $old;
 521     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 522     my $prev = $-;
 523     $- = $_[1] if @_ > 1;
 524     $prev;
 525 }
 526
 527 sub format_name {
 528     my $old;
 529     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 530     my $prev = $~;
 531     $~ = qualify($_[1], caller) if @_ > 1;
 532     $prev;
 533 }
 534
 535 sub format_top_name {
 536     my $old;
 537     $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 538     my $prev = $^;
 539     $^ = qualify($_[1], caller) if @_ > 1;
 540     $prev;
 541 }
 542
 543 sub format_line_break_characters {
 544     carp "format_line_break_characters is not supported on a per-handle basis"
 545         if ref($_[0]);
 546     my $prev = $:;
 547     $: = $_[1] if @_ > 1;
 548     $prev;
 549 }
 550
 551 sub format_formfeed {
 552     carp "format_formfeed is not supported on a per-handle basis"
 553         if ref($_[0]);
 554     my $prev = $^L;
 555     $^L = $_[1] if @_ > 1;
 556     $prev;
 557 }
 558
 559 sub formline {
 560     my $io = shift;
 561     my $picture = shift;
 562     local($^A) = $^A;
 563     local($\) = "";
 564     formline($picture, @_);
 565     print $io $^A;
 566 }
 567
 568 sub format_write {
 569     @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
 570     if (@_ == 2) {
 571         my ($io, $fmt) = @_;
 572         my $oldfmt = $io->format_name($fmt);
 573         CORE::write($io);
 574         $io->format_name($oldfmt);
 575     } else {
 576         CORE::write($_[0]);
 577     }
 578 }
 579
 580 # XXX undocumented
 581 sub fcntl {
 582     @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
 583     my ($io, $op) = @_;
 584     return fcntl($io, $op, $_[2]);
 585 }
 586
 587 # XXX undocumented
 588 sub ioctl {
 589     @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
 590     my ($io, $op) = @_;
 591     return ioctl($io, $op, $_[2]);
 592 }
 593
 594 # this sub is for compatability with older releases of IO that used
 595 # a sub called constant to detemine if a constant existed -- GMB
 596 #
 597 # The SEEK_* and _IO?BF constants were the only constants at that time
 598 # any new code should just chech defined(&CONSTANT_NAME)
 599
 600 sub constant {
 601     no strict 'refs';
 602     my $name = shift;
 603     (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
 604         ? &{$name}() : undef;
 605 }
 606
 607
 608 # so that flush.pl can be deprecated
 609
 610 sub printflush {
 611     my $io = shift;
 612     my $old;
 613     $old = new SelectSaver qualify($io, caller) if ref($io);
 614     local $| = 1;
 615     if(ref($io)) {
 616         print $io @_;
 617     }
 618     else {
 619         print @_;
 620     }
 621 }
 622
 623 1;