our $TODO should be local $::TODO, revealing a bug in the de-commenting regexp.
[perl.git] / lib / FileCache.pm
1 package FileCache;
2
3 our $VERSION = '1.07';
4
5 =head1 NAME
6
7 FileCache - keep more files open than the system permits
8
9 =head1 SYNOPSIS
10
11     use FileCache;
12     # or
13     use FileCache maxopen => 16;
14
15     cacheout $mode, $path;
16     # or
17     cacheout $path;
18     print $path @data;
19
20     $fh = cacheout $mode, $path;
21     # or
22     $fh = cacheout $path;
23     print $fh @data;
24
25 =head1 DESCRIPTION
26
27 The C<cacheout> function will make sure that there's a filehandle open
28 for reading or writing available as the pathname you give it. It
29 automatically closes and re-opens files if you exceed your system's
30 maximum number of file descriptors, or the suggested maximum I<maxopen>.
31
32 =over
33
34 =item cacheout EXPR
35
36 The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
37 on it's first use, and appending (C<<< '>>' >>>) thereafter.
38
39 Returns EXPR on success for convenience. You may neglect the
40 return value and manipulate EXPR as the filehandle directly if you prefer.
41
42 =item cacheout MODE, EXPR
43
44 The 2-argument form of cacheout will use the supplied mode for the initial
45 and subsequent openings. Most valid modes for 3-argument C<open> are supported
46 namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
47 C< '|-' > and C< '-|' >
48
49 To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
50 append them to the command string as you would system EXPR.
51
52 Returns EXPR on success for convenience. You may neglect the
53 return value and manipulate EXPR as the filehandle directly if you prefer.
54
55 =back
56
57 =head1 CAVEATS
58
59 While it is permissible to C<close> a FileCache managed file,
60 do not do so if you are calling C<FileCache::cacheout> from a package other
61 than which it was imported, or with another module which overrides C<close>.
62 If you must, use C<FileCache::cacheout_close>.
63
64 Although FileCache can be used with piped opens ('-|' or '|-') doing so is
65 strongly discouraged.  If FileCache finds it necessary to close and then reopen
66 a pipe, the command at the far end of the pipe will be reexecuted - the results
67 of performing IO on FileCache'd pipes is unlikely to be what you expect.  The
68 ability to use FileCache on pipes may be removed in a future release.
69
70 FileCache does not store the current file offset if it finds it necessary to
71 close a file.  When the file is reopened, the offset will be as specified by the
72 original C<open> file mode.  This could be construed to be a bug.
73
74 =head1 BUGS
75
76 F<sys/param.h> lies with its C<NOFILE> define on some systems,
77 so you may have to set I<maxopen> yourself.
78
79 =cut
80
81 require 5.006;
82 use Carp;
83 use strict;
84 no strict 'refs';
85
86 # These are not C<my> for legacy reasons.
87 # Previous versions requested the user set $cacheout_maxopen by hand.
88 # Some authors fiddled with %saw to overcome the clobber on initial open.
89 use vars qw(%saw $cacheout_maxopen);
90 $cacheout_maxopen = 16;
91
92 use base 'Exporter';
93 our @EXPORT = qw[cacheout cacheout_close];
94
95
96 my %isopen;
97 my $cacheout_seq = 0;
98
99 sub import {
100     my ($pkg,%args) = @_;
101
102     # Use Exporter. %args are for us, not Exporter.
103     # Make sure to up export_to_level, or we will import into ourselves,
104     # rather than our calling package;
105
106     __PACKAGE__->export_to_level(1);
107     Exporter::import( $pkg );
108
109     # Truth is okay here because setting maxopen to 0 would be bad
110     return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
111
112     # XXX This code is crazy.  Why is it a one element foreach loop?
113     # Why is it using $param both as a filename and filehandle?
114     foreach my $param ( '/usr/include/sys/param.h' ){
115       if (open($param, '<', $param)) {
116         local ($_, $.);
117         while (<$param>) {
118           if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
119             $cacheout_maxopen = $1 - 4;
120             close($param);
121             last;
122           }
123         }
124         close $param;
125       }
126     }
127     $cacheout_maxopen ||= 16;
128 }
129
130 # Open in their package.
131 sub cacheout_open {
132   return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
133 }
134
135 # Close in their package.
136 sub cacheout_close {
137   # Short-circuit in case the filehandle disappeared
138   my $pkg = caller($_[1]||0);
139   defined fileno(*{$pkg . '::' . $_[0]}) &&
140     CORE::close(*{$pkg . '::' . $_[0]});
141   delete $isopen{$_[0]};
142 }
143
144 # But only this sub name is visible to them.
145 sub cacheout {
146     my($mode, $file, $class, $ret, $ref, $narg);
147     croak "Not enough arguments for cacheout"  unless $narg = scalar @_;
148     croak "Too many arguments for cacheout"    if $narg > 2;
149
150     ($mode, $file) = @_;
151     ($file, $mode) = ($mode, $file) if $narg == 1;
152     croak "Invalid mode for cacheout" if $mode &&
153       ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
154
155     # Mode changed?
156     if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
157       &cacheout_close($file, 1);
158     }
159
160     if( $isopen{$file}) {
161       $ret = $file;
162       $isopen{$file}->[0]++;
163     }
164     else{
165       if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
166         my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
167         $cacheout_seq = 0;
168         $isopen{$_}->[0] = $cacheout_seq++ for
169           splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
170         &cacheout_close($_, 1) for @lru;
171       }
172
173       unless( $ref ){
174         $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
175       }
176       #XXX should we just return the value from cacheout_open, no croak?
177       $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
178
179       $isopen{$file} = [++$cacheout_seq, $mode];
180     }
181     return $ret;
182 }
183 1;