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