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