FileHandle::DESTROY for fd 0
[perl.git] / ext / FileHandle / FileHandle.pm
1 package FileHandle;
2
3 =head1 NAME
4
5 FileHandle - supply object methods for filehandles
6
7 =head1 SYNOPSIS
8
9     use FileHandle;
10
11     $fh = new FileHandle;
12     if ($fh->open "< file") {
13         print <$fh>;
14         $fh->close;
15     }
16
17     $fh = new FileHandle "> FOO";
18     if (defined $fh) {
19         print $fh "bar\n";
20         $fh->close;
21     }
22
23     $fh = new FileHandle "file", "r";
24     if (defined $fh) {
25         print <$fh>;
26         undef $fh;       # automatically closes the file
27     }
28
29     $fh = new FileHandle "file", O_WRONLY|O_APPEND;
30     if (defined $fh) {
31         print $fh "corge\n";
32         undef $fh;       # automatically closes the file
33     }
34
35     $pos = $fh->getpos;
36     $fh->setpos $pos;
37
38     $fh->setvbuf($buffer_var, _IOLBF, 1024);
39
40     ($readfh, $writefh) = FileHandle::pipe;
41
42     autoflush STDOUT 1;
43
44 =head1 DESCRIPTION
45
46 C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
47 newly created symbol (see the C<Symbol> package).  If it receives any
48 parameters, they are passed to C<FileHandle::open>; if the open fails,
49 the C<FileHandle> object is destroyed.  Otherwise, it is returned to
50 the caller.
51
52 C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
53 It requires two parameters, which are passed to C<FileHandle::fdopen>;
54 if the fdopen fails, the C<FileHandle> object is destroyed.
55 Otherwise, it is returned to the caller.
56
57 C<FileHandle::open> accepts one parameter or two.  With one parameter,
58 it is just a front end for the built-in C<open> function.  With two
59 parameters, the first parameter is a filename that may include
60 whitespace or other special characters, and the second parameter is
61 the open mode, optionally followed by a file permission value.
62
63 If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
64 or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
65 Perl C<open> operator.
66
67 If C<FileHandle::open> is given a numeric mode, it passes that mode
68 and the optional permissions value to the Perl C<sysopen> operator.
69 For convenience, C<FileHandle::import> tries to import the O_XXX
70 constants from the Fcntl module.  If dynamic loading is not available,
71 this may fail, but the rest of FileHandle will still work.
72
73 C<FileHandle::fdopen> is like C<open> except that its first parameter
74 is not a filename but rather a file handle name, a FileHandle object,
75 or a file descriptor number.
76
77 If the C functions fgetpos() and fsetpos() are available, then
78 C<FileHandle::getpos> returns an opaque value that represents the
79 current position of the FileHandle, and C<FileHandle::setpos> uses
80 that value to return to a previously visited position.
81
82 If the C function setvbuf() is available, then C<FileHandle::setvbuf>
83 sets the buffering policy for the FileHandle.  The calling sequence
84 for the Perl function is the same as its C counterpart, including the
85 macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
86 parameter specifies a scalar variable to use as a buffer.  WARNING: A
87 variable used as a buffer by C<FileHandle::setvbuf> must not be
88 modified in any way until the FileHandle is closed or until
89 C<FileHandle::setvbuf> is called again, or memory corruption may
90 result!
91
92 See L<perlfunc> for complete descriptions of each of the following
93 supported C<FileHandle> methods, which are just front ends for the
94 corresponding built-in functions:
95   
96     close
97     fileno
98     getc
99     gets
100     eof
101     clearerr
102     seek
103     tell
104
105 See L<perlvar> for complete descriptions of each of the following
106 supported C<FileHandle> methods:
107
108     autoflush
109     output_field_separator
110     output_record_separator
111     input_record_separator
112     input_line_number
113     format_page_number
114     format_lines_per_page
115     format_lines_left
116     format_name
117     format_top_name
118     format_line_break_characters
119     format_formfeed
120
121 Furthermore, for doing normal I/O you might need these:
122
123 =over 
124
125 =item $fh->print
126
127 See L<perlfunc/print>.
128
129 =item $fh->printf
130
131 See L<perlfunc/printf>.
132
133 =item $fh->getline
134
135 This works like <$fh> described in L<perlop/"I/O Operators">
136 except that it's more readable and can be safely called in an
137 array context but still returns just one line.
138
139 =item $fh->getlines
140
141 This works like <$fh> when called in an array context to
142 read all the remaining lines in a file, except that it's more readable.
143 It will also croak() if accidentally called in a scalar context.
144
145 =back
146
147 =head1 SEE ALSO
148
149 L<perlfunc>, 
150 L<perlop/"I/O Operators">,
151 L<POSIX/"FileHandle">
152
153 =head1 BUGS
154
155 Due to backwards compatibility, all filehandles resemble objects
156 of class C<FileHandle>, or actually classes derived from that class.
157 They actually aren't.  Which means you can't derive your own 
158 class from C<FileHandle> and inherit those methods.
159
160 =cut
161
162 require 5.000;
163 use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
164 use Carp;
165 use Symbol;
166 use SelectSaver;
167
168 require Exporter;
169 require DynaLoader;
170 @ISA = qw(Exporter DynaLoader);
171
172 $VERSION = "1.00" ;
173
174 @EXPORT = qw(_IOFBF _IOLBF _IONBF);
175
176 @EXPORT_OK = qw(
177     autoflush
178     output_field_separator
179     output_record_separator
180     input_record_separator
181     input_line_number
182     format_page_number
183     format_lines_per_page
184     format_lines_left
185     format_name
186     format_top_name
187     format_line_break_characters
188     format_formfeed
189
190     print
191     printf
192     getline
193     getlines
194 );
195
196
197 ################################################
198 ## If the Fcntl extension is available,
199 ##  export its constants.
200 ##
201
202 sub import {
203     my $pkg = shift;
204     my $callpkg = caller;
205     Exporter::export $pkg, $callpkg;
206     eval {
207         require Fcntl;
208         Exporter::export 'Fcntl', $callpkg;
209     };
210 };
211
212
213 ################################################
214 ## Interaction with the XS.
215 ##
216
217 eval {
218     bootstrap FileHandle;
219 };
220 if ($@) {
221     *constant = sub { undef };
222 }
223
224 sub AUTOLOAD {
225     if ($AUTOLOAD =~ /::(_?[a-z])/) {
226         $AutoLoader::AUTOLOAD = $AUTOLOAD;
227         goto &AutoLoader::AUTOLOAD
228     }
229     my $constname = $AUTOLOAD;
230     $constname =~ s/.*:://;
231     my $val = constant($constname);
232     defined $val or croak "$constname is not a valid FileHandle macro";
233     *$AUTOLOAD = sub { $val };
234     goto &$AUTOLOAD;
235 }
236
237
238 ################################################
239 ## Constructors, destructors.
240 ##
241
242 sub new {
243     @_ >= 1 && @_ <= 4
244         or croak 'usage: new FileHandle [FILENAME [,MODE [,PERMS]]]';
245     my $class = shift;
246     my $fh = gensym;
247     if (@_) {
248         FileHandle::open($fh, @_)
249             or return undef;
250     }
251     bless $fh, $class;
252 }
253
254 sub new_from_fd {
255     @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
256     my $class = shift;
257     my $fh = gensym;
258     FileHandle::fdopen($fh, @_)
259         or return undef;
260     bless $fh, $class;
261 }
262
263 sub DESTROY {
264     my ($fh) = @_;
265
266    # During global object destruction, this function may be called
267    # on FILEHANDLEs as well as on the GLOBs that contains them.
268    # Thus the following trickery.  If only the CORE file operators
269    # could deal with FILEHANDLEs, it wouldn't be necessary...
270
271    if ($fh =~ /=FILEHANDLE\(/) {
272      local *TMP = $fh;
273      close(TMP) if defined fileno(TMP);
274    }
275    else {
276      close($fh) if defined fileno($fh);
277    }
278 }
279
280 ################################################
281 ## Open and close.
282 ##
283
284 sub pipe {
285     @_ and croak 'usage: FileHandle::pipe()';
286     my $readfh = new FileHandle;
287     my $writefh = new FileHandle;
288     pipe($readfh, $writefh)
289         or return undef;
290     ($readfh, $writefh);
291 }
292
293 sub _open_mode_string {
294     my ($mode) = @_;
295     $mode =~ /^\+?(<|>>?)$/
296       or $mode =~ s/^r(\+?)$/$1</
297       or $mode =~ s/^w(\+?)$/$1>/
298       or $mode =~ s/^a(\+?)$/$1>>/
299       or croak "FileHandle: bad open mode: $mode";
300     $mode;
301 }
302
303 sub open {
304     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
305     my ($fh, $file) = @_;
306     if (@_ > 2) {
307         my ($mode, $perms) = @_[2, 3];
308         if ($mode =~ /^\d+$/) {
309             defined $perms or $perms = 0666;
310             return sysopen($fh, $file, $mode, $perms);
311         }
312         $file = "./" . $file unless $file =~ m#^/#;
313         $file = _open_mode_string($mode) . " $file\0";
314     }
315     open($fh, $file);
316 }
317
318 sub fdopen {
319     @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
320     my ($fh, $fd, $mode) = @_;
321     if (ref($fd) =~ /GLOB\(/) {
322         # It's a glob reference; remove the star from its name.
323         ($fd = "".$$fd) =~ s/^\*//;
324     } elsif ($fd =~ m#^\d+$#) {
325         # It's an FD number; prefix with "=".
326         $fd = "=$fd";
327     }
328     open($fh, _open_mode_string($mode) . '&' . $fd);
329 }
330
331 sub close {
332     @_ == 1 or croak 'usage: $fh->close()';
333     close($_[0]);
334 }
335
336 ################################################
337 ## Normal I/O functions.
338 ##
339
340 sub fileno {
341     @_ == 1 or croak 'usage: $fh->fileno()';
342     fileno($_[0]);
343 }
344
345 sub getc {
346     @_ == 1 or croak 'usage: $fh->getc()';
347     getc($_[0]);
348 }
349
350 sub gets {
351     @_ == 1 or croak 'usage: $fh->gets()';
352     my ($handle) = @_;
353     scalar <$handle>;
354 }
355
356 sub eof {
357     @_ == 1 or croak 'usage: $fh->eof()';
358     eof($_[0]);
359 }
360
361 sub clearerr {
362     @_ == 1 or croak 'usage: $fh->clearerr()';
363     seek($_[0], 0, 1);
364 }
365
366 sub seek {
367     @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
368     seek($_[0], $_[1], $_[2]);
369 }
370
371 sub tell {
372     @_ == 1 or croak 'usage: $fh->tell()';
373     tell($_[0]);
374 }
375
376 sub print {
377     @_ or croak 'usage: $fh->print([ARGS])';
378     my $this = shift;
379     print $this @_;
380 }
381
382 sub printf {
383     @_ or croak 'usage: $fh->printf([ARGS])';
384     my $this = shift;
385     printf $this @_;
386 }
387
388 sub getline {
389     @_ == 1 or croak 'usage: $fh->getline';
390     my $this = shift;
391     return scalar <$this>;
392
393
394 sub getlines {
395     @_ == 1 or croak 'usage: $fh->getline()';
396     my $this = shift;
397     wantarray or croak "Can't call FileHandle::getlines in a scalar context";
398     return <$this>;
399 }
400
401 ################################################
402 ## State modification functions.
403 ##
404
405 sub autoflush {
406     my $old = new SelectSaver qualify($_[0], caller);
407     my $prev = $|;
408     $| = @_ > 1 ? $_[1] : 1;
409     $prev;
410 }
411
412 sub output_field_separator {
413     my $old = new SelectSaver qualify($_[0], caller);
414     my $prev = $,;
415     $, = $_[1] if @_ > 1;
416     $prev;
417 }
418
419 sub output_record_separator {
420     my $old = new SelectSaver qualify($_[0], caller);
421     my $prev = $\;
422     $\ = $_[1] if @_ > 1;
423     $prev;
424 }
425
426 sub input_record_separator {
427     my $old = new SelectSaver qualify($_[0], caller);
428     my $prev = $/;
429     $/ = $_[1] if @_ > 1;
430     $prev;
431 }
432
433 sub input_line_number {
434     my $old = new SelectSaver qualify($_[0], caller);
435     my $prev = $.;
436     $. = $_[1] if @_ > 1;
437     $prev;
438 }
439
440 sub format_page_number {
441     my $old = new SelectSaver qualify($_[0], caller);
442     my $prev = $%;
443     $% = $_[1] if @_ > 1;
444     $prev;
445 }
446
447 sub format_lines_per_page {
448     my $old = new SelectSaver qualify($_[0], caller);
449     my $prev = $=;
450     $= = $_[1] if @_ > 1;
451     $prev;
452 }
453
454 sub format_lines_left {
455     my $old = new SelectSaver qualify($_[0], caller);
456     my $prev = $-;
457     $- = $_[1] if @_ > 1;
458     $prev;
459 }
460
461 sub format_name {
462     my $old = new SelectSaver qualify($_[0], caller);
463     my $prev = $~;
464     $~ = qualify($_[1], caller) if @_ > 1;
465     $prev;
466 }
467
468 sub format_top_name {
469     my $old = new SelectSaver qualify($_[0], caller);
470     my $prev = $^;
471     $^ = qualify($_[1], caller) if @_ > 1;
472     $prev;
473 }
474
475 sub format_line_break_characters {
476     my $old = new SelectSaver qualify($_[0], caller);
477     my $prev = $:;
478     $: = $_[1] if @_ > 1;
479     $prev;
480 }
481
482 sub format_formfeed {
483     my $old = new SelectSaver qualify($_[0], caller);
484     my $prev = $^L;
485     $^L = $_[1] if @_ > 1;
486     $prev;
487 }
488
489 1;