PATCH: untaint method for IO::Handle, 5.003_06 version
[perl.git] / 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;