Commit | Line | Data |
8990e307 |
1 | package FileHandle; |
2 | |
a0d0e21e |
3 | # Note that some additional FileHandle methods are defined in POSIX.pm. |
4 | |
cb1a09d0 |
5 | =head1 NAME |
f06db76b |
6 | |
7 | FileHandle - supply object methods for filehandles |
8 | |
9 | cacheout - keep more files open than the system permits |
10 | |
11 | =head1 SYNOPSIS |
12 | |
13 | use FileHandle; |
14 | autoflush STDOUT 1; |
15 | |
16 | cacheout($path); |
17 | print $path @data; |
18 | |
19 | =head1 DESCRIPTION |
20 | |
21 | See L<perlvar> for complete descriptions of each of the following supported C<FileHandle> |
22 | methods: |
23 | |
f06db76b |
24 | autoflush |
25 | output_field_separator |
26 | output_record_separator |
27 | input_record_separator |
28 | input_line_number |
29 | format_page_number |
30 | format_lines_per_page |
31 | format_lines_left |
32 | format_name |
33 | format_top_name |
34 | format_line_break_characters |
35 | format_formfeed |
36 | |
cb1a09d0 |
37 | Furthermore, for doing normal I/O you might need these: |
38 | |
39 | =over |
40 | |
41 | =item $fh->print |
42 | |
43 | See L<perlfunc/print>. |
44 | |
45 | =item $fh->printf |
46 | |
47 | See L<perlfunc/printf>. |
48 | |
49 | =item $fh->getline |
50 | |
51 | This works like <$fh> described in L<perlop/"I/O Operators"> except that it's more readable |
52 | and can be safely called in an array context but still |
53 | returns just one line. |
54 | |
55 | =item $fh->getlines |
56 | |
57 | This works like <$fh> when called in an array context to |
58 | read all the remaining lines in a file, except that it's more readable. |
59 | It will also croak() if accidentally called in a scalar context. |
60 | |
61 | =back |
62 | |
63 | =head2 The cacheout() Library |
64 | |
f06db76b |
65 | The cacheout() function will make sure that there's a filehandle |
66 | open for writing available as the pathname you give it. It automatically |
67 | closes and re-opens files if you exceed your system file descriptor maximum. |
68 | |
cb1a09d0 |
69 | =head1 SEE ALSO |
70 | |
71 | L<perlfunc>, |
72 | L<perlop/"I/O Operators">, |
73 | L<POSIX/"FileHandle"> |
74 | |
f06db76b |
75 | =head1 BUGS |
76 | |
77 | F<sys/param.h> lies with its C<NOFILE> define on some systems, |
78 | so you may have to set $cacheout::maxopen yourself. |
79 | |
cb1a09d0 |
80 | Some of the methods that set variables (like format_name()) don't |
81 | seem to work. |
82 | |
83 | The POSIX functions that create FileHandle methods should be |
84 | in this module instead. |
85 | |
f06db76b |
86 | Due to backwards compatibility, all filehandles resemble objects |
87 | of class C<FileHandle>, or actually classes derived from that class. |
88 | They actually aren't. Which means you can't derive your own |
89 | class from C<FileHandle> and inherit those methods. |
90 | |
91 | =cut |
92 | |
a0d0e21e |
93 | require 5.000; |
94 | use English; |
cb1a09d0 |
95 | use Carp; |
a0d0e21e |
96 | use Exporter; |
2304df62 |
97 | |
a0d0e21e |
98 | @ISA = qw(Exporter); |
2304df62 |
99 | @EXPORT = qw( |
2304df62 |
100 | autoflush |
101 | output_field_separator |
102 | output_record_separator |
103 | input_record_separator |
104 | input_line_number |
105 | format_page_number |
106 | format_lines_per_page |
107 | format_lines_left |
108 | format_name |
109 | format_top_name |
110 | format_line_break_characters |
111 | format_formfeed |
cb1a09d0 |
112 | |
113 | print |
114 | printf |
115 | getline |
116 | getlines |
117 | |
a0d0e21e |
118 | cacheout |
2304df62 |
119 | ); |
8990e307 |
120 | |
121 | sub print { |
122 | local($this) = shift; |
123 | print $this @_; |
124 | } |
125 | |
cb1a09d0 |
126 | sub printf { |
127 | local($this) = shift; |
128 | printf $this @_; |
129 | } |
130 | |
131 | sub getline { |
132 | local($this) = shift; |
133 | croak "usage: FileHandle::getline()" if @_; |
134 | return scalar <$this>; |
135 | } |
136 | |
137 | sub getlines { |
138 | local($this) = shift; |
139 | croak "usage: FileHandle::getline()" if @_; |
140 | croak "can't call FileHandle::getlines in a scalar context" if wantarray; |
141 | return <$this>; |
142 | } |
143 | |
2304df62 |
144 | sub autoflush { |
8990e307 |
145 | local($old) = select($_[0]); |
146 | local($prev) = $OUTPUT_AUTOFLUSH; |
147 | $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1; |
148 | select($old); |
149 | $prev; |
150 | } |
151 | |
152 | sub output_field_separator { |
153 | local($old) = select($_[0]); |
154 | local($prev) = $OUTPUT_FIELD_SEPARATOR; |
155 | $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1; |
156 | select($old); |
157 | $prev; |
158 | } |
159 | |
160 | sub output_record_separator { |
161 | local($old) = select($_[0]); |
162 | local($prev) = $OUTPUT_RECORD_SEPARATOR; |
163 | $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1; |
164 | select($old); |
165 | $prev; |
166 | } |
167 | |
168 | sub input_record_separator { |
169 | local($old) = select($_[0]); |
170 | local($prev) = $INPUT_RECORD_SEPARATOR; |
171 | $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1; |
172 | select($old); |
173 | $prev; |
174 | } |
175 | |
176 | sub input_line_number { |
177 | local($old) = select($_[0]); |
178 | local($prev) = $INPUT_LINE_NUMBER; |
179 | $INPUT_LINE_NUMBER = $_[1] if @_ > 1; |
180 | select($old); |
181 | $prev; |
182 | } |
183 | |
184 | sub format_page_number { |
185 | local($old) = select($_[0]); |
186 | local($prev) = $FORMAT_PAGE_NUMBER; |
187 | $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1; |
188 | select($old); |
189 | $prev; |
190 | } |
191 | |
192 | sub format_lines_per_page { |
193 | local($old) = select($_[0]); |
194 | local($prev) = $FORMAT_LINES_PER_PAGE; |
195 | $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1; |
196 | select($old); |
197 | $prev; |
198 | } |
199 | |
200 | sub format_lines_left { |
201 | local($old) = select($_[0]); |
202 | local($prev) = $FORMAT_LINES_LEFT; |
203 | $FORMAT_LINES_LEFT = $_[1] if @_ > 1; |
204 | select($old); |
205 | $prev; |
206 | } |
207 | |
208 | sub format_name { |
209 | local($old) = select($_[0]); |
210 | local($prev) = $FORMAT_NAME; |
211 | $FORMAT_NAME = $_[1] if @_ > 1; |
212 | select($old); |
213 | $prev; |
214 | } |
215 | |
216 | sub format_top_name { |
217 | local($old) = select($_[0]); |
218 | local($prev) = $FORMAT_TOP_NAME; |
219 | $FORMAT_TOP_NAME = $_[1] if @_ > 1; |
220 | select($old); |
221 | $prev; |
222 | } |
223 | |
224 | sub format_line_break_characters { |
225 | local($old) = select($_[0]); |
226 | local($prev) = $FORMAT_LINE_BREAK_CHARACTERS; |
227 | $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1; |
228 | select($old); |
229 | $prev; |
230 | } |
231 | |
232 | sub format_formfeed { |
233 | local($old) = select($_[0]); |
234 | local($prev) = $FORMAT_FORMFEED; |
235 | $FORMAT_FORMFEED = $_[1] if @_ > 1; |
236 | select($old); |
237 | $prev; |
238 | } |
239 | |
a0d0e21e |
240 | |
241 | # --- cacheout functions --- |
242 | |
243 | # Open in their package. |
244 | |
245 | sub cacheout_open { |
246 | my $pack = caller(1); |
247 | open(*{$pack . '::' . $_[0]}, $_[1]); |
248 | } |
249 | |
250 | sub cacheout_close { |
251 | my $pack = caller(1); |
252 | close(*{$pack . '::' . $_[0]}); |
253 | } |
254 | |
255 | # But only this sub name is visible to them. |
256 | |
257 | sub cacheout { |
258 | ($file) = @_; |
259 | if (!$cacheout_maxopen){ |
260 | if (open(PARAM,'/usr/include/sys/param.h')) { |
261 | local($.); |
262 | while (<PARAM>) { |
263 | $cacheout_maxopen = $1 - 4 |
264 | if /^\s*#\s*define\s+NOFILE\s+(\d+)/; |
265 | } |
266 | close PARAM; |
267 | } |
268 | $cacheout_maxopen = 16 unless $cacheout_maxopen; |
269 | } |
270 | if (!$isopen{$file}) { |
271 | if (++$cacheout_numopen > $cacheout_maxopen) { |
272 | local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); |
273 | splice(@lru, $cacheout_maxopen / 3); |
274 | $cacheout_numopen -= @lru; |
275 | for (@lru) { &cacheout_close($_); delete $isopen{$_}; } |
276 | } |
277 | &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file) |
278 | || croak("Can't create $file: $!"); |
279 | } |
280 | $isopen{$file} = ++$cacheout_seq; |
281 | } |
282 | |
283 | $cacheout_seq = 0; |
284 | $cacheout_numopen = 0; |
285 | |
8990e307 |
286 | 1; |