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