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