ext/IO/lib/IO/Handle.pm

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