Commit | Line | Data |
c07a80fd |
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 | ($readfh, $writefh) = FileHandle::pipe; |
36 | |
37 | autoflush STDOUT 1; |
38 | |
39 | =head1 DESCRIPTION |
40 | |
41 | C<FileHandle::new> creates a C<FileHandle>, which is a reference to a |
42 | newly created symbol (see the C<Symbol> package). If it receives any |
43 | parameters, they are passed to C<FileHandle::open>; if the open fails, |
44 | the C<FileHandle> object is destroyed. Otherwise, it is returned to |
45 | the caller. |
46 | |
47 | C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does. |
48 | It requires two parameters, which are passed to C<FileHandle::fdopen>; |
49 | if the fdopen fails, the C<FileHandle> object is destroyed. |
50 | Otherwise, it is returned to the caller. |
51 | |
52 | C<FileHandle::open> accepts one parameter or two. With one parameter, |
53 | it is just a front end for the built-in C<open> function. With two |
54 | parameters, the first parameter is a filename that may include |
55 | whitespace or other special characters, and the second parameter is |
56 | the open mode in either Perl form (">", "+<", etc.) or POSIX form |
57 | ("w", "r+", etc.). |
58 | |
59 | C<FileHandle::fdopen> is like C<open> except that its first parameter |
60 | is not a filename but rather a file handle name, a FileHandle object, |
61 | or a file descriptor number. |
62 | |
63 | See L<perlfunc> for complete descriptions of each of the following |
64 | supported C<FileHandle> methods, which are just front ends for the |
65 | corresponding built-in functions: |
66 | |
67 | close |
68 | fileno |
69 | getc |
70 | gets |
71 | eof |
72 | clearerr |
73 | seek |
74 | tell |
75 | |
76 | See L<perlvar> for complete descriptions of each of the following |
77 | supported C<FileHandle> methods: |
78 | |
79 | autoflush |
80 | output_field_separator |
81 | output_record_separator |
82 | input_record_separator |
83 | input_line_number |
84 | format_page_number |
85 | format_lines_per_page |
86 | format_lines_left |
87 | format_name |
88 | format_top_name |
89 | format_line_break_characters |
90 | format_formfeed |
91 | |
92 | Furthermore, for doing normal I/O you might need these: |
93 | |
94 | =over |
95 | |
96 | =item $fh->print |
97 | |
98 | See L<perlfunc/print>. |
99 | |
100 | =item $fh->printf |
101 | |
102 | See L<perlfunc/printf>. |
103 | |
104 | =item $fh->getline |
105 | |
106 | This works like <$fh> described in L<perlop/"I/O Operators"> |
107 | except that it's more readable and can be safely called in an |
108 | array context but still returns just one line. |
109 | |
110 | =item $fh->getlines |
111 | |
112 | This works like <$fh> when called in an array context to |
113 | read all the remaining lines in a file, except that it's more readable. |
114 | It will also croak() if accidentally called in a scalar context. |
115 | |
116 | =back |
117 | |
118 | =head1 SEE ALSO |
119 | |
120 | L<perlfunc>, |
121 | L<perlop/"I/O Operators">, |
122 | L<POSIX/"FileHandle"> |
123 | |
124 | =head1 BUGS |
125 | |
126 | Due to backwards compatibility, all filehandles resemble objects |
127 | of class C<FileHandle>, or actually classes derived from that class. |
128 | They actually aren't. Which means you can't derive your own |
129 | class from C<FileHandle> and inherit those methods. |
130 | |
131 | =cut |
132 | |
133 | require 5.000; |
134 | use Carp; |
135 | use Fcntl; |
136 | use Symbol; |
137 | use English; |
138 | use SelectSaver; |
139 | |
140 | require Exporter; |
141 | require DynaLoader; |
142 | @ISA = qw(Exporter DynaLoader); |
143 | |
144 | @EXPORT = (@Fcntl::EXPORT, |
145 | qw(_IOFBF _IOLBF _IONBF)); |
146 | |
147 | @EXPORT_OK = qw( |
148 | autoflush |
149 | output_field_separator |
150 | output_record_separator |
151 | input_record_separator |
152 | input_line_number |
153 | format_page_number |
154 | format_lines_per_page |
155 | format_lines_left |
156 | format_name |
157 | format_top_name |
158 | format_line_break_characters |
159 | format_formfeed |
160 | |
161 | print |
162 | printf |
163 | getline |
164 | getlines |
165 | ); |
166 | |
167 | |
168 | ################################################ |
169 | ## Interaction with the XS. |
170 | ## |
171 | |
172 | bootstrap FileHandle; |
173 | |
174 | sub AUTOLOAD { |
175 | if ($AUTOLOAD =~ /::(_?[a-z])/) { |
176 | $AutoLoader::AUTOLOAD = $AUTOLOAD; |
177 | goto &AutoLoader::AUTOLOAD |
178 | } |
179 | my $constname = $AUTOLOAD; |
180 | $constname =~ s/.*:://; |
181 | my $val = constant($constname); |
182 | defined $val or croak "$constname is not a valid FileHandle macro"; |
183 | *$AUTOLOAD = sub { $val }; |
184 | goto &$AUTOLOAD; |
185 | } |
186 | |
187 | |
188 | ################################################ |
189 | ## Constructors, destructors. |
190 | ## |
191 | |
192 | sub new { |
193 | @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]'; |
194 | my $class = shift; |
195 | my $fh = gensym; |
196 | if (@_) { |
197 | FileHandle::open($fh, @_) |
198 | or return undef; |
199 | } |
200 | bless $fh, $class; |
201 | } |
202 | |
203 | sub new_from_fd { |
204 | @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE'; |
205 | my $class = shift; |
206 | my $fh = gensym; |
207 | FileHandle::fdopen($fh, @_) |
208 | or return undef; |
209 | bless $fh, $class; |
210 | } |
211 | |
212 | sub DESTROY { |
213 | my ($fh) = @_; |
214 | close($fh); |
215 | } |
216 | |
217 | ################################################ |
218 | ## Open and close. |
219 | ## |
220 | |
221 | sub pipe { |
222 | @_ and croak 'usage: FileHandle::pipe()'; |
223 | my $readfh = new FileHandle; |
224 | my $writefh = new FileHandle; |
225 | pipe($readfh, $writefh) |
226 | or return undef; |
227 | ($readfh, $writefh); |
228 | } |
229 | |
230 | sub _open_mode_string { |
231 | my ($mode) = @_; |
232 | $mode =~ /^\+?(<|>>?)$/ |
233 | or $mode =~ s/^r(\+?)$/$1</ |
234 | or $mode =~ s/^w(\+?)$/$1>/ |
235 | or $mode =~ s/^a(\+?)$/$1>>/ |
236 | or croak "FileHandle: bad open mode: $mode"; |
237 | $mode; |
238 | } |
239 | |
240 | sub open { |
241 | @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; |
242 | my ($fh, $file) = @_; |
243 | if (@_ > 2) { |
244 | my ($mode, $perms) = @_[2, 3]; |
245 | if ($mode =~ /^\d+$/) { |
246 | defined $perms or $perms = 0666; |
247 | return sysopen($fh, $file, $mode, $perms); |
248 | } |
249 | $file = "./" . $file unless $file =~ m#^/#; |
250 | $file = _open_mode_string($mode) . " $file\0"; |
251 | } |
252 | open($fh, $file); |
253 | } |
254 | |
255 | sub fdopen { |
256 | @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; |
257 | my ($fh, $fd, $mode) = @_; |
258 | if (ref($fd) =~ /GLOB\(/) { |
259 | # It's a glob reference; remove the star from its name. |
260 | ($fd = "".$$fd) =~ s/^\*//; |
261 | } elsif ($fd =~ m#^\d+$#) { |
262 | # It's an FD number; prefix with "=". |
263 | $fd = "=$fd"; |
264 | } |
265 | open($fh, _open_mode_string($mode) . '&' . $fd); |
266 | } |
267 | |
268 | sub close { |
269 | @_ == 1 or croak 'usage: $fh->close()'; |
270 | close($_[0]); |
271 | } |
272 | |
273 | ################################################ |
274 | ## Normal I/O functions. |
275 | ## |
276 | |
277 | sub fileno { |
278 | @_ == 1 or croak 'usage: $fh->fileno()'; |
279 | fileno($_[0]); |
280 | } |
281 | |
282 | sub getc { |
283 | @_ == 1 or croak 'usage: $fh->getc()'; |
284 | getc($_[0]); |
285 | } |
286 | |
287 | sub gets { |
288 | @_ == 1 or croak 'usage: $fh->gets()'; |
289 | my ($handle) = @_; |
290 | scalar <$handle>; |
291 | } |
292 | |
293 | sub eof { |
294 | @_ == 1 or croak 'usage: $fh->eof()'; |
295 | eof($_[0]); |
296 | } |
297 | |
298 | sub clearerr { |
299 | @_ == 1 or croak 'usage: $fh->clearerr()'; |
300 | seek($_[0], 0, 1); |
301 | } |
302 | |
303 | sub seek { |
304 | @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; |
305 | seek($_[0], $_[1], $_[2]); |
306 | } |
307 | |
308 | sub tell { |
309 | @_ == 1 or croak 'usage: $fh->tell()'; |
310 | tell($_[0]); |
311 | } |
312 | |
313 | sub print { |
314 | @_ or croak 'usage: $fh->print([ARGS])'; |
315 | my $this = shift; |
316 | print $this @_; |
317 | } |
318 | |
319 | sub printf { |
320 | @_ or croak 'usage: $fh->printf([ARGS])'; |
321 | my $this = shift; |
322 | printf $this @_; |
323 | } |
324 | |
325 | sub getline { |
326 | @_ == 1 or croak 'usage: $fh->getline'; |
327 | my $this = shift; |
328 | return scalar <$this>; |
329 | } |
330 | |
331 | sub getlines { |
332 | @_ == 1 or croak 'usage: $fh->getline()'; |
333 | my $this = shift; |
334 | wantarray or croak "Can't call FileHandle::getlines in a scalar context"; |
335 | return <$this>; |
336 | } |
337 | |
338 | ################################################ |
339 | ## State modification functions. |
340 | ## |
341 | |
342 | sub autoflush { |
343 | my $old = new SelectSaver qualify($_[0], caller); |
344 | my $prev = $OUTPUT_AUTOFLUSH; |
345 | $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1; |
346 | $prev; |
347 | } |
348 | |
349 | sub output_field_separator { |
350 | my $old = new SelectSaver qualify($_[0], caller); |
351 | my $prev = $OUTPUT_FIELD_SEPARATOR; |
352 | $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1; |
353 | $prev; |
354 | } |
355 | |
356 | sub output_record_separator { |
357 | my $old = new SelectSaver qualify($_[0], caller); |
358 | my $prev = $OUTPUT_RECORD_SEPARATOR; |
359 | $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1; |
360 | $prev; |
361 | } |
362 | |
363 | sub input_record_separator { |
364 | my $old = new SelectSaver qualify($_[0], caller); |
365 | my $prev = $INPUT_RECORD_SEPARATOR; |
366 | $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1; |
367 | $prev; |
368 | } |
369 | |
370 | sub input_line_number { |
371 | my $old = new SelectSaver qualify($_[0], caller); |
372 | my $prev = $INPUT_LINE_NUMBER; |
373 | $INPUT_LINE_NUMBER = $_[1] if @_ > 1; |
374 | $prev; |
375 | } |
376 | |
377 | sub format_page_number { |
378 | my $old = new SelectSaver qualify($_[0], caller); |
379 | my $prev = $FORMAT_PAGE_NUMBER; |
380 | $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1; |
381 | $prev; |
382 | } |
383 | |
384 | sub format_lines_per_page { |
385 | my $old = new SelectSaver qualify($_[0], caller); |
386 | my $prev = $FORMAT_LINES_PER_PAGE; |
387 | $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1; |
388 | $prev; |
389 | } |
390 | |
391 | sub format_lines_left { |
392 | my $old = new SelectSaver qualify($_[0], caller); |
393 | my $prev = $FORMAT_LINES_LEFT; |
394 | $FORMAT_LINES_LEFT = $_[1] if @_ > 1; |
395 | $prev; |
396 | } |
397 | |
398 | sub format_name { |
399 | my $old = new SelectSaver qualify($_[0], caller); |
400 | my $prev = $FORMAT_NAME; |
401 | $FORMAT_NAME = qualify($_[1], caller) if @_ > 1; |
402 | $prev; |
403 | } |
404 | |
405 | sub format_top_name { |
406 | my $old = new SelectSaver qualify($_[0], caller); |
407 | my $prev = $FORMAT_TOP_NAME; |
408 | $FORMAT_TOP_NAME = qualify($_[1], caller) if @_ > 1; |
409 | $prev; |
410 | } |
411 | |
412 | sub format_line_break_characters { |
413 | my $old = new SelectSaver qualify($_[0], caller); |
414 | my $prev = $FORMAT_LINE_BREAK_CHARACTERS; |
415 | $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1; |
416 | $prev; |
417 | } |
418 | |
419 | sub format_formfeed { |
420 | my $old = new SelectSaver qualify($_[0], caller); |
421 | my $prev = $FORMAT_FORMFEED; |
422 | $FORMAT_FORMFEED = $_[1] if @_ > 1; |
423 | $prev; |
424 | } |
425 | |
426 | 1; |