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