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 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: 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 An 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 use 5.006_001;
 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_00";
 262 $VERSION = eval $VERSION;
 263
 264 @EXPORT_OK = qw(
 265     autoflush
 266     output_field_separator
 267     output_record_separator
 268     input_record_separator
 269     input_line_number
 270     format_page_number
 271     format_lines_per_page
 272     format_lines_left
 273     format_name
 274     format_top_name
 275     format_line_break_characters
 276     format_formfeed
 277     format_write
 278
 279     print
 280     printf
 281     getline
 282     getlines
 283
 284     printflush
 285     flush
 286
 287     SEEK_SET
 288     SEEK_CUR
 289     SEEK_END
 290     _IOFBF
 291     _IOLBF
 292     _IONBF
 293 );
 294
 295 ################################################
 296 ## Constructors, destructors.
 297 ##
 298
 299 sub new {
 300     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 301     @_ == 1 or croak "usage: new $class";
 302     my $io = gensym;
 303     bless $io, $class;
 304 }
 305
 306 sub new_from_fd {
 307     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 308     @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
 309     my $io = gensym;
 310     shift;
 311     IO::Handle::fdopen($io, @_)
 312         or return undef;
 313     bless $io, $class;
 314 }
 315
 316 #
 317 # There is no need for DESTROY to do anything, because when the
 318 # last reference to an IO object is gone, Perl automatically
 319 # closes its associated files (if any).  However, to avoid any
 320 # attempts to autoload DESTROY, we here define it to do nothing.
 321 #
 322 sub DESTROY {}
 323
 324
 325 ################################################
 326 ## Open and close.
 327 ##
 328
 329 sub _open_mode_string {
 330     my ($mode) = @_;
 331     $mode =~ /^\+?(<|>>?)$/
 332       or $mode =~ s/^r(\+?)$/$1</
 333       or $mode =~ s/^w(\+?)$/$1>/
 334       or $mode =~ s/^a(\+?)$/$1>>/
 335       or croak "IO::Handle: bad open mode: $mode";
 336     $mode;
 337 }
 338
 339 sub fdopen {
 340     @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
 341     my ($io, $fd, $mode) = @_;
 342     local(*GLOB);
 343
 344     if (ref($fd) && "".$fd =~ /GLOB\(/o) {
 345         # It's a glob reference; Alias it as we cannot get name of anon GLOBs
 346         my $n = qualify(*GLOB);
 347         *GLOB = *{*$fd};
 348         $fd =  $n;
 349     } elsif ($fd =~ m#^\d+$#) {
 350         # It's an FD number; prefix with "=".
 351         $fd = "=$fd";
 352     }
 353
 354     open($io, _open_mode_string($mode) . '&' . $fd)
 355         ? $io : undef;
 356 }
 357
 358 sub close {
 359     @_ == 1 or croak 'usage: $io->close()';
 360     my($io) = @_;
 361
 362     close($io);
 363 }
 364
 365 ################################################
 366 ## Normal I/O functions.
 367 ##
 368
 369 # flock
 370 # select
 371
 372 sub opened {
 373     @_ == 1 or croak 'usage: $io->opened()';
 374     defined fileno($_[0]);
 375 }
 376
 377 sub fileno {
 378     @_ == 1 or croak 'usage: $io->fileno()';
 379     fileno($_[0]);
 380 }
 381
 382 sub getc {
 383     @_ == 1 or croak 'usage: $io->getc()';
 384     getc($_[0]);
 385 }
 386
 387 sub eof {
 388     @_ == 1 or croak 'usage: $io->eof()';
 389     eof($_[0]);
 390 }
 391
 392 sub print {
 393     @_ or croak 'usage: $io->print(ARGS)';
 394     my $this = shift;
 395     print $this @_;
 396 }
 397
 398 sub printf {
 399     @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
 400     my $this = shift;
 401     printf $this @_;
 402 }
 403
 404 sub getline {
 405     @_ == 1 or croak 'usage: $io->getline()';
 406     my $this = shift;
 407     return scalar <$this>;
 408 }
 409
 410 *gets = \&getline;  # deprecated
 411
 412 sub getlines {
 413     @_ == 1 or croak 'usage: $io->getlines()';
 414     wantarray or
 415         croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
 416     my $this = shift;
 417     return <$this>;
 418 }
 419
 420 sub truncate {
 421     @_ == 2 or croak 'usage: $io->truncate(LEN)';
 422     truncate($_[0], $_[1]);
 423 }
 424
 425 sub read {
 426     @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
 427     read($_[0], $_[1], $_[2], $_[3] || 0);
 428 }
 429
 430 sub sysread {
 431     @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
 432     sysread($_[0], $_[1], $_[2], $_[3] || 0);
 433 }
 434
 435 sub write {
 436     @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
 437     local($\) = "";
 438     $_[2] = length($_[1]) unless defined $_[2];
 439     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 440 }
 441
 442 sub syswrite {
 443     @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
 444     if (defined($_[2])) {
 445         syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 446     } else {
 447         syswrite($_[0], $_[1]);
 448     }
 449 }
 450
 451 sub stat {
 452     @_ == 1 or croak 'usage: $io->stat()';
 453     stat($_[0]);
 454 }
 455
 456 ################################################
 457 ## State modification functions.
 458 ##
 459
 460 sub autoflush {
 461     my $old = new SelectSaver qualify($_[0], caller);
 462     my $prev = $|;
 463     $| = @_ > 1 ? $_[1] : 1;
 464     $prev;
 465 }
 466
 467 sub output_field_separator {
 468     carp "output_field_separator is not supported on a per-handle basis"
 469         if ref($_[0]);
 470     my $prev = $,;
 471     $, = $_[1] if @_ > 1;
 472     $prev;
 473 }
 474
 475 sub output_record_separator {
 476     carp "output_record_separator is not supported on a per-handle basis"
 477         if ref($_[0]);
 478     my $prev = $\;
 479     $\ = $_[1] if @_ > 1;
 480     $prev;
 481 }
 482
 483 sub input_record_separator {
 484     carp "input_record_separator is not supported on a per-handle basis"
 485         if ref($_[0]);
 486     my $prev = $/;
 487     $/ = $_[1] if @_ > 1;
 488     $prev;
 489 }
 490
 491 sub input_line_number {
 492     local $.;
 493     my $tell = tell qualify($_[0], caller) if ref($_[0]);
 494     my $prev = $.;
 495     $. = $_[1] if @_ > 1;
 496     $prev;
 497 }
 498
 499 sub format_page_number {
 500     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 501     my $prev = $%;
 502     $% = $_[1] if @_ > 1;
 503     $prev;
 504 }
 505
 506 sub format_lines_per_page {
 507     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 508     my $prev = $=;
 509     $= = $_[1] if @_ > 1;
 510     $prev;
 511 }
 512
 513 sub format_lines_left {
 514     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 515     my $prev = $-;
 516     $- = $_[1] if @_ > 1;
 517     $prev;
 518 }
 519
 520 sub format_name {
 521     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 522     my $prev = $~;
 523     $~ = qualify($_[1], caller) if @_ > 1;
 524     $prev;
 525 }
 526
 527 sub format_top_name {
 528     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 529     my $prev = $^;
 530     $^ = qualify($_[1], caller) if @_ > 1;
 531     $prev;
 532 }
 533
 534 sub format_line_break_characters {
 535     carp "format_line_break_characters is not supported on a per-handle basis"
 536         if ref($_[0]);
 537     my $prev = $:;
 538     $: = $_[1] if @_ > 1;
 539     $prev;
 540 }
 541
 542 sub format_formfeed {
 543     carp "format_formfeed is not supported on a per-handle basis"
 544         if ref($_[0]);
 545     my $prev = $^L;
 546     $^L = $_[1] if @_ > 1;
 547     $prev;
 548 }
 549
 550 sub formline {
 551     my $io = shift;
 552     my $picture = shift;
 553     local($^A) = $^A;
 554     local($\) = "";
 555     formline($picture, @_);
 556     print $io $^A;
 557 }
 558
 559 sub format_write {
 560     @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
 561     if (@_ == 2) {
 562         my ($io, $fmt) = @_;
 563         my $oldfmt = $io->format_name($fmt);
 564         CORE::write($io);
 565         $io->format_name($oldfmt);
 566     } else {
 567         CORE::write($_[0]);
 568     }
 569 }
 570
 571 # XXX undocumented
 572 sub fcntl {
 573     @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
 574     my ($io, $op) = @_;
 575     return fcntl($io, $op, $_[2]);
 576 }
 577
 578 # XXX undocumented
 579 sub ioctl {
 580     @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
 581     my ($io, $op) = @_;
 582     return ioctl($io, $op, $_[2]);
 583 }
 584
 585 # this sub is for compatability with older releases of IO that used
 586 # a sub called constant to detemine if a constant existed -- GMB
 587 #
 588 # The SEEK_* and _IO?BF constants were the only constants at that time
 589 # any new code should just chech defined(&CONSTANT_NAME)
 590
 591 sub constant {
 592     no strict 'refs';
 593     my $name = shift;
 594     (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
 595         ? &{$name}() : undef;
 596 }
 597
 598
 599 # so that flush.pl can be deprecated
 600
 601 sub printflush {
 602     my $io = shift;
 603     my $old = new SelectSaver qualify($io, caller) if ref($io);
 604     local $| = 1;
 605     if(ref($io)) {
 606         print $io @_;
 607     }
 608     else {
 609         print @_;
 610     }
 611 }
 612
 613 1;