[14489] | 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 | $io = new IO::Handle;
|
---|
| 12 | if ($io->fdopen(fileno(STDIN),"r")) {
|
---|
| 13 | print $io->getline;
|
---|
| 14 | $io->close;
|
---|
| 15 | }
|
---|
| 16 |
|
---|
| 17 | $io = new IO::Handle;
|
---|
| 18 | if ($io->fdopen(fileno(STDOUT),"w")) {
|
---|
| 19 | $io->print("Some text\n");
|
---|
| 20 | }
|
---|
| 21 |
|
---|
| 22 | # setvbuf is not available by default on Perls 5.8.0 and later.
|
---|
| 23 | use IO::Handle '_IOLBF';
|
---|
| 24 | $io->setvbuf($buffer_var, _IOLBF, 1024);
|
---|
| 25 |
|
---|
| 26 | undef $io; # automatically closes the file if it's open
|
---|
| 27 |
|
---|
| 28 | autoflush STDOUT 1;
|
---|
| 29 |
|
---|
| 30 | =head1 DESCRIPTION
|
---|
| 31 |
|
---|
| 32 | C<IO::Handle> is the base class for all other IO handle classes. It is
|
---|
| 33 | not intended that objects of C<IO::Handle> would be created directly,
|
---|
| 34 | but instead C<IO::Handle> is inherited from by several other classes
|
---|
| 35 | in the IO hierarchy.
|
---|
| 36 |
|
---|
| 37 | If you are reading this documentation, looking for a replacement for
|
---|
| 38 | the C<FileHandle> package, then I suggest you read the documentation
|
---|
| 39 | for C<IO::File> too.
|
---|
| 40 |
|
---|
| 41 | =head1 CONSTRUCTOR
|
---|
| 42 |
|
---|
| 43 | =over 4
|
---|
| 44 |
|
---|
| 45 | =item new ()
|
---|
| 46 |
|
---|
| 47 | Creates a new C<IO::Handle> object.
|
---|
| 48 |
|
---|
| 49 | =item new_from_fd ( FD, MODE )
|
---|
| 50 |
|
---|
| 51 | Creates an C<IO::Handle> like C<new> does.
|
---|
| 52 | It requires two parameters, which are passed to the method C<fdopen>;
|
---|
| 53 | if the fdopen fails, the object is destroyed. Otherwise, it is returned
|
---|
| 54 | to the caller.
|
---|
| 55 |
|
---|
| 56 | =back
|
---|
| 57 |
|
---|
| 58 | =head1 METHODS
|
---|
| 59 |
|
---|
| 60 | See L<perlfunc> for complete descriptions of each of the following
|
---|
| 61 | supported C<IO::Handle> methods, which are just front ends for the
|
---|
| 62 | corresponding built-in functions:
|
---|
| 63 |
|
---|
| 64 | $io->close
|
---|
| 65 | $io->eof
|
---|
| 66 | $io->fileno
|
---|
| 67 | $io->format_write( [FORMAT_NAME] )
|
---|
| 68 | $io->getc
|
---|
| 69 | $io->read ( BUF, LEN, [OFFSET] )
|
---|
| 70 | $io->print ( ARGS )
|
---|
| 71 | $io->printf ( FMT, [ARGS] )
|
---|
| 72 | $io->stat
|
---|
| 73 | $io->sysread ( BUF, LEN, [OFFSET] )
|
---|
| 74 | $io->syswrite ( BUF, [LEN, [OFFSET]] )
|
---|
| 75 | $io->truncate ( LEN )
|
---|
| 76 |
|
---|
| 77 | See L<perlvar> for complete descriptions of each of the following
|
---|
| 78 | supported C<IO::Handle> methods. All of them return the previous
|
---|
| 79 | value of the attribute and takes an optional single argument that when
|
---|
| 80 | given will set the value. If no argument is given the previous value
|
---|
| 81 | is unchanged (except for $io->autoflush will actually turn ON
|
---|
| 82 | autoflush by default).
|
---|
| 83 |
|
---|
| 84 | $io->autoflush ( [BOOL] ) $|
|
---|
| 85 | $io->format_page_number( [NUM] ) $%
|
---|
| 86 | $io->format_lines_per_page( [NUM] ) $=
|
---|
| 87 | $io->format_lines_left( [NUM] ) $-
|
---|
| 88 | $io->format_name( [STR] ) $~
|
---|
| 89 | $io->format_top_name( [STR] ) $^
|
---|
| 90 | $io->input_line_number( [NUM]) $.
|
---|
| 91 |
|
---|
| 92 | The following methods are not supported on a per-filehandle basis.
|
---|
| 93 |
|
---|
| 94 | IO::Handle->format_line_break_characters( [STR] ) $:
|
---|
| 95 | IO::Handle->format_formfeed( [STR]) $^L
|
---|
| 96 | IO::Handle->output_field_separator( [STR] ) $,
|
---|
| 97 | IO::Handle->output_record_separator( [STR] ) $\
|
---|
| 98 |
|
---|
| 99 | IO::Handle->input_record_separator( [STR] ) $/
|
---|
| 100 |
|
---|
| 101 | Furthermore, for doing normal I/O you might need these:
|
---|
| 102 |
|
---|
| 103 | =over 4
|
---|
| 104 |
|
---|
| 105 | =item $io->fdopen ( FD, MODE )
|
---|
| 106 |
|
---|
| 107 | C<fdopen> is like an ordinary C<open> except that its first parameter
|
---|
| 108 | is not a filename but rather a file handle name, an IO::Handle object,
|
---|
| 109 | or a file descriptor number.
|
---|
| 110 |
|
---|
| 111 | =item $io->opened
|
---|
| 112 |
|
---|
| 113 | Returns true if the object is currently a valid file descriptor, false
|
---|
| 114 | otherwise.
|
---|
| 115 |
|
---|
| 116 | =item $io->getline
|
---|
| 117 |
|
---|
| 118 | This works like <$io> described in L<perlop/"I/O Operators">
|
---|
| 119 | except that it's more readable and can be safely called in a
|
---|
| 120 | list context but still returns just one line. If used as the conditional
|
---|
| 121 | +within a C<while> or C-style C<for> loop, however, you will need to
|
---|
| 122 | +emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>.
|
---|
| 123 |
|
---|
| 124 | =item $io->getlines
|
---|
| 125 |
|
---|
| 126 | This works like <$io> when called in a list context to read all
|
---|
| 127 | the remaining lines in a file, except that it's more readable.
|
---|
| 128 | It will also croak() if accidentally called in a scalar context.
|
---|
| 129 |
|
---|
| 130 | =item $io->ungetc ( ORD )
|
---|
| 131 |
|
---|
| 132 | Pushes a character with the given ordinal value back onto the given
|
---|
| 133 | handle's input stream. Only one character of pushback per handle is
|
---|
| 134 | guaranteed.
|
---|
| 135 |
|
---|
| 136 | =item $io->write ( BUF, LEN [, OFFSET ] )
|
---|
| 137 |
|
---|
| 138 | This C<write> is like C<write> found in C, that is it is the
|
---|
| 139 | opposite of read. The wrapper for the perl C<write> function is
|
---|
| 140 | called C<format_write>.
|
---|
| 141 |
|
---|
| 142 | =item $io->error
|
---|
| 143 |
|
---|
| 144 | Returns a true value if the given handle has experienced any errors
|
---|
| 145 | since it was opened or since the last call to C<clearerr>, or if the
|
---|
| 146 | handle is invalid. It only returns false for a valid handle with no
|
---|
| 147 | outstanding errors.
|
---|
| 148 |
|
---|
| 149 | =item $io->clearerr
|
---|
| 150 |
|
---|
| 151 | Clear the given handle's error indicator. Returns -1 if the handle is
|
---|
| 152 | invalid, 0 otherwise.
|
---|
| 153 |
|
---|
| 154 | =item $io->sync
|
---|
| 155 |
|
---|
| 156 | C<sync> synchronizes a file's in-memory state with that on the
|
---|
| 157 | physical medium. C<sync> does not operate at the perlio api level, but
|
---|
| 158 | operates on the file descriptor (similar to sysread, sysseek and
|
---|
| 159 | systell). This means that any data held at the perlio api level will not
|
---|
| 160 | be synchronized. To synchronize data that is buffered at the perlio api
|
---|
| 161 | level you must use the flush method. C<sync> is not implemented on all
|
---|
| 162 | platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
|
---|
| 163 | for an invalid handle. See L<fsync(3c)>.
|
---|
| 164 |
|
---|
| 165 | =item $io->flush
|
---|
| 166 |
|
---|
| 167 | C<flush> causes perl to flush any buffered data at the perlio api level.
|
---|
| 168 | Any unread data in the buffer will be discarded, and any unwritten data
|
---|
| 169 | will be written to the underlying file descriptor. Returns "0 but true"
|
---|
| 170 | on success, C<undef> on error.
|
---|
| 171 |
|
---|
| 172 | =item $io->printflush ( ARGS )
|
---|
| 173 |
|
---|
| 174 | Turns on autoflush, print ARGS and then restores the autoflush status of the
|
---|
| 175 | C<IO::Handle> object. Returns the return value from print.
|
---|
| 176 |
|
---|
| 177 | =item $io->blocking ( [ BOOL ] )
|
---|
| 178 |
|
---|
| 179 | If called with an argument C<blocking> will turn on non-blocking IO if
|
---|
| 180 | C<BOOL> is false, and turn it off if C<BOOL> is true.
|
---|
| 181 |
|
---|
| 182 | C<blocking> will return the value of the previous setting, or the
|
---|
| 183 | current setting if C<BOOL> is not given.
|
---|
| 184 |
|
---|
| 185 | If an error occurs C<blocking> will return undef and C<$!> will be set.
|
---|
| 186 |
|
---|
| 187 | =back
|
---|
| 188 |
|
---|
| 189 |
|
---|
| 190 | If the C functions setbuf() and/or setvbuf() are available, then
|
---|
| 191 | C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
|
---|
| 192 | policy for an IO::Handle. The calling sequences for the Perl functions
|
---|
| 193 | are the same as their C counterparts--including the constants C<_IOFBF>,
|
---|
| 194 | C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
|
---|
| 195 | specifies a scalar variable to use as a buffer. You should only
|
---|
| 196 | change the buffer before any I/O, or immediately after calling flush.
|
---|
| 197 |
|
---|
| 198 | WARNING: The IO::Handle::setvbuf() is not available by default on
|
---|
| 199 | Perls 5.8.0 and later because setvbuf() is rather specific to using
|
---|
| 200 | the stdio library, while Perl prefers the new perlio subsystem instead.
|
---|
| 201 |
|
---|
| 202 | WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
|
---|
| 203 | be modified> in any way until the IO::Handle is closed or C<setbuf> or
|
---|
| 204 | C<setvbuf> is called again, or memory corruption may result! Remember that
|
---|
| 205 | the order of global destruction is undefined, so even if your buffer
|
---|
| 206 | variable remains in scope until program termination, it may be undefined
|
---|
| 207 | before the file IO::Handle is closed. Note that you need to import the
|
---|
| 208 | constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
|
---|
| 209 | returns nothing. setvbuf returns "0 but true", on success, C<undef> on
|
---|
| 210 | failure.
|
---|
| 211 |
|
---|
| 212 | Lastly, there is a special method for working under B<-T> and setuid/gid
|
---|
| 213 | scripts:
|
---|
| 214 |
|
---|
| 215 | =over 4
|
---|
| 216 |
|
---|
| 217 | =item $io->untaint
|
---|
| 218 |
|
---|
| 219 | Marks the object as taint-clean, and as such data read from it will also
|
---|
| 220 | be considered taint-clean. Note that this is a very trusting action to
|
---|
| 221 | take, and appropriate consideration for the data source and potential
|
---|
| 222 | vulnerability should be kept in mind. Returns 0 on success, -1 if setting
|
---|
| 223 | the taint-clean flag failed. (eg invalid handle)
|
---|
| 224 |
|
---|
| 225 | =back
|
---|
| 226 |
|
---|
| 227 | =head1 NOTE
|
---|
| 228 |
|
---|
| 229 | An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
|
---|
| 230 | the C<Symbol> package). Some modules that
|
---|
| 231 | inherit from C<IO::Handle> may want to keep object related variables
|
---|
| 232 | in the hash table part of the GLOB. In an attempt to prevent modules
|
---|
| 233 | trampling on each other I propose the that any such module should prefix
|
---|
| 234 | its variables with its own name separated by _'s. For example the IO::Socket
|
---|
| 235 | module keeps a C<timeout> variable in 'io_socket_timeout'.
|
---|
| 236 |
|
---|
| 237 | =head1 SEE ALSO
|
---|
| 238 |
|
---|
| 239 | L<perlfunc>,
|
---|
| 240 | L<perlop/"I/O Operators">,
|
---|
| 241 | L<IO::File>
|
---|
| 242 |
|
---|
| 243 | =head1 BUGS
|
---|
| 244 |
|
---|
| 245 | Due to backwards compatibility, all filehandles resemble objects
|
---|
| 246 | of class C<IO::Handle>, or actually classes derived from that class.
|
---|
| 247 | They actually aren't. Which means you can't derive your own
|
---|
| 248 | class from C<IO::Handle> and inherit those methods.
|
---|
| 249 |
|
---|
| 250 | =head1 HISTORY
|
---|
| 251 |
|
---|
| 252 | Derived from FileHandle.pm by Graham Barr E<lt>F<[email protected]>E<gt>
|
---|
| 253 |
|
---|
| 254 | =cut
|
---|
| 255 |
|
---|
| 256 | use 5.006_001;
|
---|
| 257 | use strict;
|
---|
| 258 | our($VERSION, @EXPORT_OK, @ISA);
|
---|
| 259 | use Carp;
|
---|
| 260 | use Symbol;
|
---|
| 261 | use SelectSaver;
|
---|
| 262 | use IO (); # Load the XS module
|
---|
| 263 |
|
---|
| 264 | require Exporter;
|
---|
| 265 | @ISA = qw(Exporter);
|
---|
| 266 |
|
---|
| 267 | $VERSION = "1.25";
|
---|
| 268 | $VERSION = eval $VERSION;
|
---|
| 269 |
|
---|
| 270 | @EXPORT_OK = qw(
|
---|
| 271 | autoflush
|
---|
| 272 | output_field_separator
|
---|
| 273 | output_record_separator
|
---|
| 274 | input_record_separator
|
---|
| 275 | input_line_number
|
---|
| 276 | format_page_number
|
---|
| 277 | format_lines_per_page
|
---|
| 278 | format_lines_left
|
---|
| 279 | format_name
|
---|
| 280 | format_top_name
|
---|
| 281 | format_line_break_characters
|
---|
| 282 | format_formfeed
|
---|
| 283 | format_write
|
---|
| 284 |
|
---|
| 285 | print
|
---|
| 286 | printf
|
---|
| 287 | getline
|
---|
| 288 | getlines
|
---|
| 289 |
|
---|
| 290 | printflush
|
---|
| 291 | flush
|
---|
| 292 |
|
---|
| 293 | SEEK_SET
|
---|
| 294 | SEEK_CUR
|
---|
| 295 | SEEK_END
|
---|
| 296 | _IOFBF
|
---|
| 297 | _IOLBF
|
---|
| 298 | _IONBF
|
---|
| 299 | );
|
---|
| 300 |
|
---|
| 301 | ################################################
|
---|
| 302 | ## Constructors, destructors.
|
---|
| 303 | ##
|
---|
| 304 |
|
---|
| 305 | sub new {
|
---|
| 306 | my $class = ref($_[0]) || $_[0] || "IO::Handle";
|
---|
| 307 | @_ == 1 or croak "usage: new $class";
|
---|
| 308 | my $io = gensym;
|
---|
| 309 | bless $io, $class;
|
---|
| 310 | }
|
---|
| 311 |
|
---|
| 312 | sub new_from_fd {
|
---|
| 313 | my $class = ref($_[0]) || $_[0] || "IO::Handle";
|
---|
| 314 | @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
|
---|
| 315 | my $io = gensym;
|
---|
| 316 | shift;
|
---|
| 317 | IO::Handle::fdopen($io, @_)
|
---|
| 318 | or return undef;
|
---|
| 319 | bless $io, $class;
|
---|
| 320 | }
|
---|
| 321 |
|
---|
| 322 | #
|
---|
| 323 | # There is no need for DESTROY to do anything, because when the
|
---|
| 324 | # last reference to an IO object is gone, Perl automatically
|
---|
| 325 | # closes its associated files (if any). However, to avoid any
|
---|
| 326 | # attempts to autoload DESTROY, we here define it to do nothing.
|
---|
| 327 | #
|
---|
| 328 | sub DESTROY {}
|
---|
| 329 |
|
---|
| 330 |
|
---|
| 331 | ################################################
|
---|
| 332 | ## Open and close.
|
---|
| 333 | ##
|
---|
| 334 |
|
---|
| 335 | sub _open_mode_string {
|
---|
| 336 | my ($mode) = @_;
|
---|
| 337 | $mode =~ /^\+?(<|>>?)$/
|
---|
| 338 | or $mode =~ s/^r(\+?)$/$1</
|
---|
| 339 | or $mode =~ s/^w(\+?)$/$1>/
|
---|
| 340 | or $mode =~ s/^a(\+?)$/$1>>/
|
---|
| 341 | or croak "IO::Handle: bad open mode: $mode";
|
---|
| 342 | $mode;
|
---|
| 343 | }
|
---|
| 344 |
|
---|
| 345 | sub fdopen {
|
---|
| 346 | @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
|
---|
| 347 | my ($io, $fd, $mode) = @_;
|
---|
| 348 | local(*GLOB);
|
---|
| 349 |
|
---|
| 350 | if (ref($fd) && "".$fd =~ /GLOB\(/o) {
|
---|
| 351 | # It's a glob reference; Alias it as we cannot get name of anon GLOBs
|
---|
| 352 | my $n = qualify(*GLOB);
|
---|
| 353 | *GLOB = *{*$fd};
|
---|
| 354 | $fd = $n;
|
---|
| 355 | } elsif ($fd =~ m#^\d+$#) {
|
---|
| 356 | # It's an FD number; prefix with "=".
|
---|
| 357 | $fd = "=$fd";
|
---|
| 358 | }
|
---|
| 359 |
|
---|
| 360 | open($io, _open_mode_string($mode) . '&' . $fd)
|
---|
| 361 | ? $io : undef;
|
---|
| 362 | }
|
---|
| 363 |
|
---|
| 364 | sub close {
|
---|
| 365 | @_ == 1 or croak 'usage: $io->close()';
|
---|
| 366 | my($io) = @_;
|
---|
| 367 |
|
---|
| 368 | close($io);
|
---|
| 369 | }
|
---|
| 370 |
|
---|
| 371 | ################################################
|
---|
| 372 | ## Normal I/O functions.
|
---|
| 373 | ##
|
---|
| 374 |
|
---|
| 375 | # flock
|
---|
| 376 | # select
|
---|
| 377 |
|
---|
| 378 | sub opened {
|
---|
| 379 | @_ == 1 or croak 'usage: $io->opened()';
|
---|
| 380 | defined fileno($_[0]);
|
---|
| 381 | }
|
---|
| 382 |
|
---|
| 383 | sub fileno {
|
---|
| 384 | @_ == 1 or croak 'usage: $io->fileno()';
|
---|
| 385 | fileno($_[0]);
|
---|
| 386 | }
|
---|
| 387 |
|
---|
| 388 | sub getc {
|
---|
| 389 | @_ == 1 or croak 'usage: $io->getc()';
|
---|
| 390 | getc($_[0]);
|
---|
| 391 | }
|
---|
| 392 |
|
---|
| 393 | sub eof {
|
---|
| 394 | @_ == 1 or croak 'usage: $io->eof()';
|
---|
| 395 | eof($_[0]);
|
---|
| 396 | }
|
---|
| 397 |
|
---|
| 398 | sub print {
|
---|
| 399 | @_ or croak 'usage: $io->print(ARGS)';
|
---|
| 400 | my $this = shift;
|
---|
| 401 | print $this @_;
|
---|
| 402 | }
|
---|
| 403 |
|
---|
| 404 | sub printf {
|
---|
| 405 | @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
|
---|
| 406 | my $this = shift;
|
---|
| 407 | printf $this @_;
|
---|
| 408 | }
|
---|
| 409 |
|
---|
| 410 | sub getline {
|
---|
| 411 | @_ == 1 or croak 'usage: $io->getline()';
|
---|
| 412 | my $this = shift;
|
---|
| 413 | return scalar <$this>;
|
---|
| 414 | }
|
---|
| 415 |
|
---|
| 416 | *gets = \&getline; # deprecated
|
---|
| 417 |
|
---|
| 418 | sub getlines {
|
---|
| 419 | @_ == 1 or croak 'usage: $io->getlines()';
|
---|
| 420 | wantarray or
|
---|
| 421 | croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
|
---|
| 422 | my $this = shift;
|
---|
| 423 | return <$this>;
|
---|
| 424 | }
|
---|
| 425 |
|
---|
| 426 | sub truncate {
|
---|
| 427 | @_ == 2 or croak 'usage: $io->truncate(LEN)';
|
---|
| 428 | truncate($_[0], $_[1]);
|
---|
| 429 | }
|
---|
| 430 |
|
---|
| 431 | sub read {
|
---|
| 432 | @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
|
---|
| 433 | read($_[0], $_[1], $_[2], $_[3] || 0);
|
---|
| 434 | }
|
---|
| 435 |
|
---|
| 436 | sub sysread {
|
---|
| 437 | @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
|
---|
| 438 | sysread($_[0], $_[1], $_[2], $_[3] || 0);
|
---|
| 439 | }
|
---|
| 440 |
|
---|
| 441 | sub write {
|
---|
| 442 | @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
|
---|
| 443 | local($\) = "";
|
---|
| 444 | $_[2] = length($_[1]) unless defined $_[2];
|
---|
| 445 | print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
|
---|
| 446 | }
|
---|
| 447 |
|
---|
| 448 | sub syswrite {
|
---|
| 449 | @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
|
---|
| 450 | if (defined($_[2])) {
|
---|
| 451 | syswrite($_[0], $_[1], $_[2], $_[3] || 0);
|
---|
| 452 | } else {
|
---|
| 453 | syswrite($_[0], $_[1]);
|
---|
| 454 | }
|
---|
| 455 | }
|
---|
| 456 |
|
---|
| 457 | sub stat {
|
---|
| 458 | @_ == 1 or croak 'usage: $io->stat()';
|
---|
| 459 | stat($_[0]);
|
---|
| 460 | }
|
---|
| 461 |
|
---|
| 462 | ################################################
|
---|
| 463 | ## State modification functions.
|
---|
| 464 | ##
|
---|
| 465 |
|
---|
| 466 | sub autoflush {
|
---|
| 467 | my $old = new SelectSaver qualify($_[0], caller);
|
---|
| 468 | my $prev = $|;
|
---|
| 469 | $| = @_ > 1 ? $_[1] : 1;
|
---|
| 470 | $prev;
|
---|
| 471 | }
|
---|
| 472 |
|
---|
| 473 | sub output_field_separator {
|
---|
| 474 | carp "output_field_separator is not supported on a per-handle basis"
|
---|
| 475 | if ref($_[0]);
|
---|
| 476 | my $prev = $,;
|
---|
| 477 | $, = $_[1] if @_ > 1;
|
---|
| 478 | $prev;
|
---|
| 479 | }
|
---|
| 480 |
|
---|
| 481 | sub output_record_separator {
|
---|
| 482 | carp "output_record_separator is not supported on a per-handle basis"
|
---|
| 483 | if ref($_[0]);
|
---|
| 484 | my $prev = $\;
|
---|
| 485 | $\ = $_[1] if @_ > 1;
|
---|
| 486 | $prev;
|
---|
| 487 | }
|
---|
| 488 |
|
---|
| 489 | sub input_record_separator {
|
---|
| 490 | carp "input_record_separator is not supported on a per-handle basis"
|
---|
| 491 | if ref($_[0]);
|
---|
| 492 | my $prev = $/;
|
---|
| 493 | $/ = $_[1] if @_ > 1;
|
---|
| 494 | $prev;
|
---|
| 495 | }
|
---|
| 496 |
|
---|
| 497 | sub input_line_number {
|
---|
| 498 | local $.;
|
---|
| 499 | () = tell qualify($_[0], caller) if ref($_[0]);
|
---|
| 500 | my $prev = $.;
|
---|
| 501 | $. = $_[1] if @_ > 1;
|
---|
| 502 | $prev;
|
---|
| 503 | }
|
---|
| 504 |
|
---|
| 505 | sub format_page_number {
|
---|
| 506 | my $old;
|
---|
| 507 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
|
---|
| 508 | my $prev = $%;
|
---|
| 509 | $% = $_[1] if @_ > 1;
|
---|
| 510 | $prev;
|
---|
| 511 | }
|
---|
| 512 |
|
---|
| 513 | sub format_lines_per_page {
|
---|
| 514 | my $old;
|
---|
| 515 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
|
---|
| 516 | my $prev = $=;
|
---|
| 517 | $= = $_[1] if @_ > 1;
|
---|
| 518 | $prev;
|
---|
| 519 | }
|
---|
| 520 |
|
---|
| 521 | sub format_lines_left {
|
---|
| 522 | my $old;
|
---|
| 523 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
|
---|
| 524 | my $prev = $-;
|
---|
| 525 | $- = $_[1] if @_ > 1;
|
---|
| 526 | $prev;
|
---|
| 527 | }
|
---|
| 528 |
|
---|
| 529 | sub format_name {
|
---|
| 530 | my $old;
|
---|
| 531 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
|
---|
| 532 | my $prev = $~;
|
---|
| 533 | $~ = qualify($_[1], caller) if @_ > 1;
|
---|
| 534 | $prev;
|
---|
| 535 | }
|
---|
| 536 |
|
---|
| 537 | sub format_top_name {
|
---|
| 538 | my $old;
|
---|
| 539 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
|
---|
| 540 | my $prev = $^;
|
---|
| 541 | $^ = qualify($_[1], caller) if @_ > 1;
|
---|
| 542 | $prev;
|
---|
| 543 | }
|
---|
| 544 |
|
---|
| 545 | sub format_line_break_characters {
|
---|
| 546 | carp "format_line_break_characters is not supported on a per-handle basis"
|
---|
| 547 | if ref($_[0]);
|
---|
| 548 | my $prev = $:;
|
---|
| 549 | $: = $_[1] if @_ > 1;
|
---|
| 550 | $prev;
|
---|
| 551 | }
|
---|
| 552 |
|
---|
| 553 | sub format_formfeed {
|
---|
| 554 | carp "format_formfeed is not supported on a per-handle basis"
|
---|
| 555 | if ref($_[0]);
|
---|
| 556 | my $prev = $^L;
|
---|
| 557 | $^L = $_[1] if @_ > 1;
|
---|
| 558 | $prev;
|
---|
| 559 | }
|
---|
| 560 |
|
---|
| 561 | sub formline {
|
---|
| 562 | my $io = shift;
|
---|
| 563 | my $picture = shift;
|
---|
| 564 | local($^A) = $^A;
|
---|
| 565 | local($\) = "";
|
---|
| 566 | formline($picture, @_);
|
---|
| 567 | print $io $^A;
|
---|
| 568 | }
|
---|
| 569 |
|
---|
| 570 | sub format_write {
|
---|
| 571 | @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
|
---|
| 572 | if (@_ == 2) {
|
---|
| 573 | my ($io, $fmt) = @_;
|
---|
| 574 | my $oldfmt = $io->format_name($fmt);
|
---|
| 575 | CORE::write($io);
|
---|
| 576 | $io->format_name($oldfmt);
|
---|
| 577 | } else {
|
---|
| 578 | CORE::write($_[0]);
|
---|
| 579 | }
|
---|
| 580 | }
|
---|
| 581 |
|
---|
| 582 | # XXX undocumented
|
---|
| 583 | sub fcntl {
|
---|
| 584 | @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
|
---|
| 585 | my ($io, $op) = @_;
|
---|
| 586 | return fcntl($io, $op, $_[2]);
|
---|
| 587 | }
|
---|
| 588 |
|
---|
| 589 | # XXX undocumented
|
---|
| 590 | sub ioctl {
|
---|
| 591 | @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
|
---|
| 592 | my ($io, $op) = @_;
|
---|
| 593 | return ioctl($io, $op, $_[2]);
|
---|
| 594 | }
|
---|
| 595 |
|
---|
| 596 | # this sub is for compatability with older releases of IO that used
|
---|
| 597 | # a sub called constant to detemine if a constant existed -- GMB
|
---|
| 598 | #
|
---|
| 599 | # The SEEK_* and _IO?BF constants were the only constants at that time
|
---|
| 600 | # any new code should just chech defined(&CONSTANT_NAME)
|
---|
| 601 |
|
---|
| 602 | sub constant {
|
---|
| 603 | no strict 'refs';
|
---|
| 604 | my $name = shift;
|
---|
| 605 | (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
|
---|
| 606 | ? &{$name}() : undef;
|
---|
| 607 | }
|
---|
| 608 |
|
---|
| 609 |
|
---|
| 610 | # so that flush.pl can be deprecated
|
---|
| 611 |
|
---|
| 612 | sub printflush {
|
---|
| 613 | my $io = shift;
|
---|
| 614 | my $old;
|
---|
| 615 | $old = new SelectSaver qualify($io, caller) if ref($io);
|
---|
| 616 | local $| = 1;
|
---|
| 617 | if(ref($io)) {
|
---|
| 618 | print $io @_;
|
---|
| 619 | }
|
---|
| 620 | else {
|
---|
| 621 | print @_;
|
---|
| 622 | }
|
---|
| 623 | }
|
---|
| 624 |
|
---|
| 625 | 1;
|
---|