ext/IO/lib/IO/Handle.pm

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