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