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