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 a
 119 list context but still returns just one line.
 120
 121 =item $io->getlines
 122
 123 This works like <$io> when called in a list context to read all
 124 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.005_64;
 236 use strict;
 237 our($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     @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
 421     local($\) = "";
 422     $_[2] = length($_[1]) unless defined $_[2];
 423     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 424 }
 425
 426 sub syswrite {
 427     @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
 428     if (defined($_[2])) {
 429         syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 430     } else {
 431         syswrite($_[0], $_[1]);
 432     }
 433 }
 434
 435 sub stat {
 436     @_ == 1 or croak 'usage: $io->stat()';
 437     stat($_[0]);
 438 }
 439
 440 ################################################
 441 ## State modification functions.
 442 ##
 443
 444 sub autoflush {
 445     my $old = new SelectSaver qualify($_[0], caller);
 446     my $prev = $|;
 447     $| = @_ > 1 ? $_[1] : 1;
 448     $prev;
 449 }
 450
 451 sub output_field_separator {
 452     carp "output_field_separator is not supported on a per-handle basis"
 453         if ref($_[0]);
 454     my $prev = $,;
 455     $, = $_[1] if @_ > 1;
 456     $prev;
 457 }
 458
 459 sub output_record_separator {
 460     carp "output_record_separator is not supported on a per-handle basis"
 461         if ref($_[0]);
 462     my $prev = $\;
 463     $\ = $_[1] if @_ > 1;
 464     $prev;
 465 }
 466
 467 sub input_record_separator {
 468     carp "input_record_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 input_line_number {
 476     local $.;
 477     my $tell = tell qualify($_[0], caller) if ref($_[0]);
 478     my $prev = $.;
 479     $. = $_[1] if @_ > 1;
 480     $prev;
 481 }
 482
 483 sub format_page_number {
 484     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 485     my $prev = $%;
 486     $% = $_[1] if @_ > 1;
 487     $prev;
 488 }
 489
 490 sub format_lines_per_page {
 491     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 492     my $prev = $=;
 493     $= = $_[1] if @_ > 1;
 494     $prev;
 495 }
 496
 497 sub format_lines_left {
 498     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 499     my $prev = $-;
 500     $- = $_[1] if @_ > 1;
 501     $prev;
 502 }
 503
 504 sub format_name {
 505     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 506     my $prev = $~;
 507     $~ = qualify($_[1], caller) if @_ > 1;
 508     $prev;
 509 }
 510
 511 sub format_top_name {
 512     my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
 513     my $prev = $^;
 514     $^ = qualify($_[1], caller) if @_ > 1;
 515     $prev;
 516 }
 517
 518 sub format_line_break_characters {
 519     carp "format_line_break_characters is not supported on a per-handle basis"
 520         if ref($_[0]);
 521     my $prev = $:;
 522     $: = $_[1] if @_ > 1;
 523     $prev;
 524 }
 525
 526 sub format_formfeed {
 527     carp "format_formfeed is not supported on a per-handle basis"
 528         if ref($_[0]);
 529     my $prev = $^L;
 530     $^L = $_[1] if @_ > 1;
 531     $prev;
 532 }
 533
 534 sub formline {
 535     my $io = shift;
 536     my $picture = shift;
 537     local($^A) = $^A;
 538     local($\) = "";
 539     formline($picture, @_);
 540     print $io $^A;
 541 }
 542
 543 sub format_write {
 544     @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
 545     if (@_ == 2) {
 546         my ($io, $fmt) = @_;
 547         my $oldfmt = $io->format_name($fmt);
 548         CORE::write($io);
 549         $io->format_name($oldfmt);
 550     } else {
 551         CORE::write($_[0]);
 552     }
 553 }
 554
 555 # XXX undocumented
 556 sub fcntl {
 557     @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
 558     my ($io, $op) = @_;
 559     return fcntl($io, $op, $_[2]);
 560 }
 561
 562 # XXX undocumented
 563 sub ioctl {
 564     @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
 565     my ($io, $op) = @_;
 566     return ioctl($io, $op, $_[2]);
 567 }
 568
 569 # this sub is for compatability with older releases of IO that used
 570 # a sub called constant to detemine if a constant existed -- GMB
 571 #
 572 # The SEEK_* and _IO?BF constants were the only constants at that time
 573 # any new code should just chech defined(&CONSTANT_NAME)
 574
 575 sub constant {
 576     no strict 'refs';
 577     my $name = shift;
 578     (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
 579         ? &{$name}() : undef;
 580 }
 581
 582
 583 # so that flush.pl can be depriciated
 584
 585 sub printflush {
 586     my $io = shift;
 587     my $old = new SelectSaver qualify($io, caller) if ref($io);
 588     local $| = 1;
 589     if(ref($io)) {
 590         print $io @_;
 591     }
 592     else {
 593         print @_;
 594     }
 595 }
 596
 597 1;