This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1d1fe18e533e981e13a6ea949d321965e804604a
[perl5.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 in either Perl form (">", "+<", etc.) or POSIX form
62 ("w", "r+", etc.).
63
64 C<FileHandle::fdopen> is like C<open> except that its first parameter
65 is not a filename but rather a file handle name, a FileHandle object,
66 or a file descriptor number.
67
68 If the C functions fgetpos() and fsetpos() are available, then
69 C<FileHandle::getpos> returns an opaque value that represents the
70 current position of the FileHandle, and C<FileHandle::setpos> uses
71 that value to return to a previously visited position.
72
73 If the C function setvbuf() is available, then C<FileHandle::setvbuf>
74 sets the buffering policy for the FileHandle.  The calling sequence
75 for the Perl function is the same as its C counterpart, including the
76 macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
77 parameter specifies a scalar variable to use as a buffer.  WARNING: A
78 variable used as a buffer by C<FileHandle::setvbuf> must not be
79 modified in any way until the FileHandle is closed or until
80 C<FileHandle::setvbuf> is called again, or memory corruption may
81 result!
82
83 See L<perlfunc> for complete descriptions of each of the following
84 supported C<FileHandle> methods, which are just front ends for the
85 corresponding built-in functions:
86   
87     close
88     fileno
89     getc
90     gets
91     eof
92     clearerr
93     seek
94     tell
95
96 See L<perlvar> for complete descriptions of each of the following
97 supported C<FileHandle> methods:
98
99     autoflush
100     output_field_separator
101     output_record_separator
102     input_record_separator
103     input_line_number
104     format_page_number
105     format_lines_per_page
106     format_lines_left
107     format_name
108     format_top_name
109     format_line_break_characters
110     format_formfeed
111
112 Furthermore, for doing normal I/O you might need these:
113
114 =over 
115
116 =item $fh->print
117
118 See L<perlfunc/print>.
119
120 =item $fh->printf
121
122 See L<perlfunc/printf>.
123
124 =item $fh->getline
125
126 This works like <$fh> described in L<perlop/"I/O Operators">
127 except that it's more readable and can be safely called in an
128 array context but still returns just one line.
129
130 =item $fh->getlines
131
132 This works like <$fh> when called in an array context to
133 read all the remaining lines in a file, except that it's more readable.
134 It will also croak() if accidentally called in a scalar context.
135
136 =back
137
138 =head1 SEE ALSO
139
140 L<perlfunc>, 
141 L<perlop/"I/O Operators">,
142 L<POSIX/"FileHandle">
143
144 =head1 BUGS
145
146 Due to backwards compatibility, all filehandles resemble objects
147 of class C<FileHandle>, or actually classes derived from that class.
148 They actually aren't.  Which means you can't derive your own 
149 class from C<FileHandle> and inherit those methods.
150
151 =cut
152
153 require 5.000;
154 use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
155 use Carp;
156 use Symbol;
157 use English;
158 use SelectSaver;
159
160 require Exporter;
161 require DynaLoader;
162 @ISA = qw(Exporter DynaLoader);
163
164 $VERSION = "1.00" ;
165
166 @EXPORT = qw(_IOFBF _IOLBF _IONBF);
167
168 @EXPORT_OK = qw(
169     autoflush
170     output_field_separator
171     output_record_separator
172     input_record_separator
173     input_line_number
174     format_page_number
175     format_lines_per_page
176     format_lines_left
177     format_name
178     format_top_name
179     format_line_break_characters
180     format_formfeed
181
182     print
183     printf
184     getline
185     getlines
186 );
187
188
189 ################################################
190 ## If the Fcntl extension is available,
191 ##  export its constants.
192 ##
193
194 sub import {
195     my $pkg = shift;
196     my $callpkg = caller;
197     Exporter::export $pkg, $callpkg;
198     eval {
199         require Fcntl;
200         Exporter::export 'Fcntl', $callpkg;
201     };
202 };
203
204
205 ################################################
206 ## Interaction with the XS.
207 ##
208
209 eval {
210     bootstrap FileHandle;
211 };
212 if ($@) {
213     *constant = sub { undef };
214 }
215
216 sub AUTOLOAD {
217     if ($AUTOLOAD =~ /::(_?[a-z])/) {
218         $AutoLoader::AUTOLOAD = $AUTOLOAD;
219         goto &AutoLoader::AUTOLOAD
220     }
221     my $constname = $AUTOLOAD;
222     $constname =~ s/.*:://;
223     my $val = constant($constname);
224     defined $val or croak "$constname is not a valid FileHandle macro";
225     *$AUTOLOAD = sub { $val };
226     goto &$AUTOLOAD;
227 }
228
229
230 ################################################
231 ## Constructors, destructors.
232 ##
233
234 sub new {
235     @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]';
236     my $class = shift;
237     my $fh = gensym;
238     if (@_) {
239         FileHandle::open($fh, @_)
240             or return undef;
241     }
242     bless $fh, $class;
243 }
244
245 sub new_from_fd {
246     @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
247     my $class = shift;
248     my $fh = gensym;
249     FileHandle::fdopen($fh, @_)
250         or return undef;
251     bless $fh, $class;
252 }
253
254 sub DESTROY {
255     my ($fh) = @_;
256     close($fh);
257 }
258
259 ################################################
260 ## Open and close.
261 ##
262
263 sub pipe {
264     @_ and croak 'usage: FileHandle::pipe()';
265     my $readfh = new FileHandle;
266     my $writefh = new FileHandle;
267     pipe($readfh, $writefh)
268         or return undef;
269     ($readfh, $writefh);
270 }
271
272 sub _open_mode_string {
273     my ($mode) = @_;
274     $mode =~ /^\+?(<|>>?)$/
275       or $mode =~ s/^r(\+?)$/$1</
276       or $mode =~ s/^w(\+?)$/$1>/
277       or $mode =~ s/^a(\+?)$/$1>>/
278       or croak "FileHandle: bad open mode: $mode";
279     $mode;
280 }
281
282 sub open {
283     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
284     my ($fh, $file) = @_;
285     if (@_ > 2) {
286         my ($mode, $perms) = @_[2, 3];
287         if ($mode =~ /^\d+$/) {
288             defined $perms or $perms = 0666;
289             return sysopen($fh, $file, $mode, $perms);
290         }
291         $file = "./" . $file unless $file =~ m#^/#;
292         $file = _open_mode_string($mode) . " $file\0";
293     }
294     open($fh, $file);
295 }
296
297 sub fdopen {
298     @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
299     my ($fh, $fd, $mode) = @_;
300     if (ref($fd) =~ /GLOB\(/) {
301         # It's a glob reference; remove the star from its name.
302         ($fd = "".$$fd) =~ s/^\*//;
303     } elsif ($fd =~ m#^\d+$#) {
304         # It's an FD number; prefix with "=".
305         $fd = "=$fd";
306     }
307     open($fh, _open_mode_string($mode) . '&' . $fd);
308 }
309
310 sub close {
311     @_ == 1 or croak 'usage: $fh->close()';
312     close($_[0]);
313 }
314
315 ################################################
316 ## Normal I/O functions.
317 ##
318
319 sub fileno {
320     @_ == 1 or croak 'usage: $fh->fileno()';
321     fileno($_[0]);
322 }
323
324 sub getc {
325     @_ == 1 or croak 'usage: $fh->getc()';
326     getc($_[0]);
327 }
328
329 sub gets {
330     @_ == 1 or croak 'usage: $fh->gets()';
331     my ($handle) = @_;
332     scalar <$handle>;
333 }
334
335 sub eof {
336     @_ == 1 or croak 'usage: $fh->eof()';
337     eof($_[0]);
338 }
339
340 sub clearerr {
341     @_ == 1 or croak 'usage: $fh->clearerr()';
342     seek($_[0], 0, 1);
343 }
344
345 sub seek {
346     @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
347     seek($_[0], $_[1], $_[2]);
348 }
349
350 sub tell {
351     @_ == 1 or croak 'usage: $fh->tell()';
352     tell($_[0]);
353 }
354
355 sub print {
356     @_ or croak 'usage: $fh->print([ARGS])';
357     my $this = shift;
358     print $this @_;
359 }
360
361 sub printf {
362     @_ or croak 'usage: $fh->printf([ARGS])';
363     my $this = shift;
364     printf $this @_;
365 }
366
367 sub getline {
368     @_ == 1 or croak 'usage: $fh->getline';
369     my $this = shift;
370     return scalar <$this>;
371
372
373 sub getlines {
374     @_ == 1 or croak 'usage: $fh->getline()';
375     my $this = shift;
376     wantarray or croak "Can't call FileHandle::getlines in a scalar context";
377     return <$this>;
378 }
379
380 ################################################
381 ## State modification functions.
382 ##
383
384 sub autoflush {
385     my $old = new SelectSaver qualify($_[0], caller);
386     my $prev = $OUTPUT_AUTOFLUSH;
387     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
388     $prev;
389 }
390
391 sub output_field_separator {
392     my $old = new SelectSaver qualify($_[0], caller);
393     my $prev = $OUTPUT_FIELD_SEPARATOR;
394     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
395     $prev;
396 }
397
398 sub output_record_separator {
399     my $old = new SelectSaver qualify($_[0], caller);
400     my $prev = $OUTPUT_RECORD_SEPARATOR;
401     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
402     $prev;
403 }
404
405 sub input_record_separator {
406     my $old = new SelectSaver qualify($_[0], caller);
407     my $prev = $INPUT_RECORD_SEPARATOR;
408     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
409     $prev;
410 }
411
412 sub input_line_number {
413     my $old = new SelectSaver qualify($_[0], caller);
414     my $prev = $INPUT_LINE_NUMBER;
415     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
416     $prev;
417 }
418
419 sub format_page_number {
420     my $old = new SelectSaver qualify($_[0], caller);
421     my $prev = $FORMAT_PAGE_NUMBER;
422     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
423     $prev;
424 }
425
426 sub format_lines_per_page {
427     my $old = new SelectSaver qualify($_[0], caller);
428     my $prev = $FORMAT_LINES_PER_PAGE;
429     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
430     $prev;
431 }
432
433 sub format_lines_left {
434     my $old = new SelectSaver qualify($_[0], caller);
435     my $prev = $FORMAT_LINES_LEFT;
436     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
437     $prev;
438 }
439
440 sub format_name {
441     my $old = new SelectSaver qualify($_[0], caller);
442     my $prev = $FORMAT_NAME;
443     $FORMAT_NAME = qualify($_[1], caller) if @_ > 1;
444     $prev;
445 }
446
447 sub format_top_name {
448     my $old = new SelectSaver qualify($_[0], caller);
449     my $prev = $FORMAT_TOP_NAME;
450     $FORMAT_TOP_NAME = qualify($_[1], caller) if @_ > 1;
451     $prev;
452 }
453
454 sub format_line_break_characters {
455     my $old = new SelectSaver qualify($_[0], caller);
456     my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
457     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
458     $prev;
459 }
460
461 sub format_formfeed {
462     my $old = new SelectSaver qualify($_[0], caller);
463     my $prev = $FORMAT_FORMFEED;
464     $FORMAT_FORMFEED = $_[1] if @_ > 1;
465     $prev;
466 }
467
468 1;