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     $fh = new IO::Handle;
  13     if ($fh->fdopen(fileno(STDIN),"r")) {
  14         print $fh->getline;
  15         $fh->close;
  16     }
  17
  18     $fh = new IO::Handle;
  19     if ($fh->fdopen(fileno(STDOUT),"w")) {
  20         $fh->print("Some text\n");
  21     }
  22
  23     $fh->setvbuf($buffer_var, _IOLBF, 1024);
  24
  25     undef $fh;       # automatically closes the file if it's open
  26
  27     autoflush STDOUT 1;
  28
  29 =head1 DESCRIPTION
  30
  31 C<IO::Handle> is the base class for all other IO handle classes. It is
  32 not intended that objects of C<IO::Handle> would be created directly,
  33 but instead C<IO::Handle> is inherited from by several other classes
  34 in the IO hierarchy.
  35
  36 If you are reading this documentation, looking for a replacement for
  37 the C<FileHandle> package, then I suggest you read the documentation
  38 for C<IO::File>
  39
  40 A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
  41
  42 =head1 CONSTRUCTOR
  43
  44 =over 4
  45
  46 =item new ()
  47
  48 Creates a new C<IO::Handle> object.
  49
  50 =item new_from_fd ( FD, MODE )
  51
  52 Creates a C<IO::Handle> like C<new> does.
  53 It requires two parameters, which are passed to the method C<fdopen>;
  54 if the fdopen fails, the object is destroyed. Otherwise, it is returned
  55 to the caller.
  56
  57 =back
  58
  59 =head1 METHODS
  60
  61 See L<perlfunc> for complete descriptions of each of the following
  62 supported C<IO::Handle> methods, which are just front ends for the
  63 corresponding built-in functions:
  64
  65     close
  66     fileno
  67     getc
  68     eof
  69     read
  70     truncate
  71     stat
  72     print
  73     printf
  74     sysread
  75     syswrite
  76
  77 See L<perlvar> for complete descriptions of each of the following
  78 supported C<IO::Handle> methods:
  79
  80     autoflush
  81     output_field_separator
  82     output_record_separator
  83     input_record_separator
  84     input_line_number
  85     format_page_number
  86     format_lines_per_page
  87     format_lines_left
  88     format_name
  89     format_top_name
  90     format_line_break_characters
  91     format_formfeed
  92     format_write
  93
  94 Furthermore, for doing normal I/O you might need these:
  95
  96 =over
  97
  98 =item $fh->fdopen ( FD, MODE )
  99
 100 C<fdopen> is like an ordinary C<open> except that its first parameter
 101 is not a filename but rather a file handle name, a IO::Handle object,
 102 or a file descriptor number.
 103
 104 =item $fh->opened
 105
 106 Returns true if the object is currently a valid file descriptor.
 107
 108 =item $fh->getline
 109
 110 This works like <$fh> described in L<perlop/"I/O Operators">
 111 except that it's more readable and can be safely called in an
 112 array context but still returns just one line.
 113
 114 =item $fh->getlines
 115
 116 This works like <$fh> when called in an array context to
 117 read all the remaining lines in a file, except that it's more readable.
 118 It will also croak() if accidentally called in a scalar context.
 119
 120 =item $fh->ungetc ( ORD )
 121
 122 Pushes a character with the given ordinal value back onto the given
 123 handle's input stream.
 124
 125 =item $fh->write ( BUF, LEN [, OFFSET }\] )
 126
 127 This C<write> is like C<write> found in C, that is it is the
 128 opposite of read. The wrapper for the perl C<write> function is
 129 called C<format_write>.
 130
 131 =item $fh->flush
 132
 133 Flush the given handle's buffer.
 134
 135 =item $fh->error
 136
 137 Returns a true value if the given handle has experienced any errors
 138 since it was opened or since the last call to C<clearerr>.
 139
 140 =item $fh->clearerr
 141
 142 Clear the given handle's error indicator.
 143
 144 =back
 145
 146 If the C functions setbuf() and/or setvbuf() are available, then
 147 C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
 148 policy for an IO::Handle.  The calling sequences for the Perl functions
 149 are the same as their C counterparts--including the constants C<_IOFBF>,
 150 C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
 151 specifies a scalar variable to use as a buffer.  WARNING: A variable
 152 used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any
 153 way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called
 154 again, or memory corruption may result!
 155
 156 Lastly, there is a special method for working under B<-T> and setuid/gid
 157 scripts:
 158
 159 =over
 160
 161 =item $fh->untaint
 162
 163 Marks the object as taint-clean, and as such data read from it will also
 164 be considered taint-clean. Note that this is a very trusting action to
 165 take, and appropriate consideration for the data source and potential
 166 vulnerability should be kept in mind.
 167
 168 =back
 169
 170 =head1 NOTE
 171
 172 A C<IO::Handle> object is a GLOB reference. Some modules that
 173 inherit from C<IO::Handle> may want to keep object related variables
 174 in the hash table part of the GLOB. In an attempt to prevent modules
 175 trampling on each other I propose the that any such module should prefix
 176 its variables with its own name separated by _'s. For example the IO::Socket
 177 module keeps a C<timeout> variable in 'io_socket_timeout'.
 178
 179 =head1 SEE ALSO
 180
 181 L<perlfunc>,
 182 L<perlop/"I/O Operators">,
 183 L<IO::File>
 184
 185 =head1 BUGS
 186
 187 Due to backwards compatibility, all filehandles resemble objects
 188 of class C<IO::Handle>, or actually classes derived from that class.
 189 They actually aren't.  Which means you can't derive your own
 190 class from C<IO::Handle> and inherit those methods.
 191
 192 =head1 HISTORY
 193
 194 Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
 195
 196 =cut
 197
 198 require 5.000;
 199 use strict;
 200 use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA);
 201 use Carp;
 202 use Symbol;
 203 use SelectSaver;
 204
 205 require Exporter;
 206 @ISA = qw(Exporter);
 207
 208 $VERSION = "1.1504";
 209 $XS_VERSION = "1.15";
 210
 211 @EXPORT_OK = qw(
 212     autoflush
 213     output_field_separator
 214     output_record_separator
 215     input_record_separator
 216     input_line_number
 217     format_page_number
 218     format_lines_per_page
 219     format_lines_left
 220     format_name
 221     format_top_name
 222     format_line_break_characters
 223     format_formfeed
 224     format_write
 225
 226     print
 227     printf
 228     getline
 229     getlines
 230
 231     SEEK_SET
 232     SEEK_CUR
 233     SEEK_END
 234     _IOFBF
 235     _IOLBF
 236     _IONBF
 237 );
 238
 239
 240 ################################################
 241 ## Interaction with the XS.
 242 ##
 243
 244 require DynaLoader;
 245 @IO::ISA = qw(DynaLoader);
 246 bootstrap IO $XS_VERSION;
 247
 248 sub AUTOLOAD {
 249     if ($AUTOLOAD =~ /::(_?[a-z])/) {
 250         $AutoLoader::AUTOLOAD = $AUTOLOAD;
 251         goto &AutoLoader::AUTOLOAD
 252     }
 253     my $constname = $AUTOLOAD;
 254     $constname =~ s/.*:://;
 255     my $val = constant($constname);
 256     defined $val or croak "$constname is not a valid IO::Handle macro";
 257     no strict 'refs';
 258     *$AUTOLOAD = sub { $val };
 259     goto &$AUTOLOAD;
 260 }
 261
 262
 263 ################################################
 264 ## Constructors, destructors.
 265 ##
 266
 267 sub new {
 268     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 269     @_ == 1 or croak "usage: new $class";
 270     my $fh = gensym;
 271     bless $fh, $class;
 272 }
 273
 274 sub new_from_fd {
 275     my $class = ref($_[0]) || $_[0] || "IO::Handle";
 276     @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
 277     my $fh = gensym;
 278     shift;
 279     IO::Handle::fdopen($fh, @_)
 280         or return undef;
 281     bless $fh, $class;
 282 }
 283
 284 #
 285 # There is no need for DESTROY to do anything, because when the
 286 # last reference to an IO object is gone, Perl automatically
 287 # closes its associated files (if any).  However, to avoid any
 288 # attempts to autoload DESTROY, we here define it to do nothing.
 289 #
 290 sub DESTROY {}
 291
 292
 293 ################################################
 294 ## Open and close.
 295 ##
 296
 297 sub _open_mode_string {
 298     my ($mode) = @_;
 299     $mode =~ /^\+?(<|>>?)$/
 300       or $mode =~ s/^r(\+?)$/$1</
 301       or $mode =~ s/^w(\+?)$/$1>/
 302       or $mode =~ s/^a(\+?)$/$1>>/
 303       or croak "IO::Handle: bad open mode: $mode";
 304     $mode;
 305 }
 306
 307 sub fdopen {
 308     @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
 309     my ($fh, $fd, $mode) = @_;
 310     local(*GLOB);
 311
 312     if (ref($fd) && "".$fd =~ /GLOB\(/o) {
 313         # It's a glob reference; Alias it as we cannot get name of anon GLOBs
 314         my $n = qualify(*GLOB);
 315         *GLOB = *{*$fd};
 316         $fd =  $n;
 317     } elsif ($fd =~ m#^\d+$#) {
 318         # It's an FD number; prefix with "=".
 319         $fd = "=$fd";
 320     }
 321
 322     open($fh, _open_mode_string($mode) . '&' . $fd)
 323         ? $fh : undef;
 324 }
 325
 326 sub close {
 327     @_ == 1 or croak 'usage: $fh->close()';
 328     my($fh) = @_;
 329
 330     close($fh);
 331 }
 332
 333 ################################################
 334 ## Normal I/O functions.
 335 ##
 336
 337 # flock
 338 # select
 339
 340 sub opened {
 341     @_ == 1 or croak 'usage: $fh->opened()';
 342     defined fileno($_[0]);
 343 }
 344
 345 sub fileno {
 346     @_ == 1 or croak 'usage: $fh->fileno()';
 347     fileno($_[0]);
 348 }
 349
 350 sub getc {
 351     @_ == 1 or croak 'usage: $fh->getc()';
 352     getc($_[0]);
 353 }
 354
 355 sub eof {
 356     @_ == 1 or croak 'usage: $fh->eof()';
 357     eof($_[0]);
 358 }
 359
 360 sub print {
 361     @_ or croak 'usage: $fh->print([ARGS])';
 362     my $this = shift;
 363     print $this @_;
 364 }
 365
 366 sub printf {
 367     @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
 368     my $this = shift;
 369     printf $this @_;
 370 }
 371
 372 sub getline {
 373     @_ == 1 or croak 'usage: $fh->getline';
 374     my $this = shift;
 375     return scalar <$this>;
 376 }
 377
 378 *gets = \&getline;  # deprecated
 379
 380 sub getlines {
 381     @_ == 1 or croak 'usage: $fh->getline()';
 382     wantarray or
 383         croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
 384     my $this = shift;
 385     return <$this>;
 386 }
 387
 388 sub truncate {
 389     @_ == 2 or croak 'usage: $fh->truncate(LEN)';
 390     truncate($_[0], $_[1]);
 391 }
 392
 393 sub read {
 394     @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
 395     read($_[0], $_[1], $_[2], $_[3] || 0);
 396 }
 397
 398 sub sysread {
 399     @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
 400     sysread($_[0], $_[1], $_[2], $_[3] || 0);
 401 }
 402
 403 sub write {
 404     @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
 405     local($\) = "";
 406     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 407 }
 408
 409 sub syswrite {
 410     @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
 411     syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 412 }
 413
 414 sub stat {
 415     @_ == 1 or croak 'usage: $fh->stat()';
 416     stat($_[0]);
 417 }
 418
 419 ################################################
 420 ## State modification functions.
 421 ##
 422
 423 sub autoflush {
 424     my $old = new SelectSaver qualify($_[0], caller);
 425     my $prev = $|;
 426     $| = @_ > 1 ? $_[1] : 1;
 427     $prev;
 428 }
 429
 430 sub output_field_separator {
 431     my $old = new SelectSaver qualify($_[0], caller);
 432     my $prev = $,;
 433     $, = $_[1] if @_ > 1;
 434     $prev;
 435 }
 436
 437 sub output_record_separator {
 438     my $old = new SelectSaver qualify($_[0], caller);
 439     my $prev = $\;
 440     $\ = $_[1] if @_ > 1;
 441     $prev;
 442 }
 443
 444 sub input_record_separator {
 445     my $old = new SelectSaver qualify($_[0], caller);
 446     my $prev = $/;
 447     $/ = $_[1] if @_ > 1;
 448     $prev;
 449 }
 450
 451 sub input_line_number {
 452     my $old = new SelectSaver qualify($_[0], caller);
 453     my $prev = $.;
 454     $. = $_[1] if @_ > 1;
 455     $prev;
 456 }
 457
 458 sub format_page_number {
 459     my $old = new SelectSaver qualify($_[0], caller);
 460     my $prev = $%;
 461     $% = $_[1] if @_ > 1;
 462     $prev;
 463 }
 464
 465 sub format_lines_per_page {
 466     my $old = new SelectSaver qualify($_[0], caller);
 467     my $prev = $=;
 468     $= = $_[1] if @_ > 1;
 469     $prev;
 470 }
 471
 472 sub format_lines_left {
 473     my $old = new SelectSaver qualify($_[0], caller);
 474     my $prev = $-;
 475     $- = $_[1] if @_ > 1;
 476     $prev;
 477 }
 478
 479 sub format_name {
 480     my $old = new SelectSaver qualify($_[0], caller);
 481     my $prev = $~;
 482     $~ = qualify($_[1], caller) if @_ > 1;
 483     $prev;
 484 }
 485
 486 sub format_top_name {
 487     my $old = new SelectSaver qualify($_[0], caller);
 488     my $prev = $^;
 489     $^ = qualify($_[1], caller) if @_ > 1;
 490     $prev;
 491 }
 492
 493 sub format_line_break_characters {
 494     my $old = new SelectSaver qualify($_[0], caller);
 495     my $prev = $:;
 496     $: = $_[1] if @_ > 1;
 497     $prev;
 498 }
 499
 500 sub format_formfeed {
 501     my $old = new SelectSaver qualify($_[0], caller);
 502     my $prev = $^L;
 503     $^L = $_[1] if @_ > 1;
 504     $prev;
 505 }
 506
 507 sub formline {
 508     my $fh = shift;
 509     my $picture = shift;
 510     local($^A) = $^A;
 511     local($\) = "";
 512     formline($picture, @_);
 513     print $fh $^A;
 514 }
 515
 516 sub format_write {
 517     @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
 518     if (@_ == 2) {
 519         my ($fh, $fmt) = @_;
 520         my $oldfmt = $fh->format_name($fmt);
 521         write($fh);
 522         $fh->format_name($oldfmt);
 523     } else {
 524         write($_[0]);
 525     }
 526 }
 527
 528 sub fcntl {
 529     @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
 530     my ($fh, $op, $val) = @_;
 531     my $r = fcntl($fh, $op, $val);
 532     defined $r && $r eq "0 but true" ? 0 : $r;
 533 }
 534
 535 sub ioctl {
 536     @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
 537     my ($fh, $op, $val) = @_;
 538     my $r = ioctl($fh, $op, $val);
 539     defined $r && $r eq "0 but true" ? 0 : $r;
 540 }
 541
 542 1;