1package FileCache; 2 3our $VERSION = '1.04_01'; 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=head1 CAVEATS 56 57While it is permissible to C<close> a FileCache managed file, 58do not do so if you are calling C<FileCache::cacheout> from a package other 59than which it was imported, or with another module which overrides C<close>. 60If you must, use C<FileCache::cacheout_close>. 61 62Although FileCache can be used with piped opens ('-|' or '|-') doing so is 63strongly discouraged. If FileCache finds it necessary to close and then reopen 64a pipe, the command at the far end of the pipe will be reexecuted - the results 65of performing IO on FileCache'd pipes is unlikely to be what you expect. The 66ability to use FileCache on pipes may be removed in a future release. 67 68FileCache does not store the current file offset if it finds it necessary to 69close a file. When the file is reopened, the offset will be as specified by the 70original C<open> file mode. This could be construed to be a bug. 71 72=head1 BUGS 73 74F<sys/param.h> lies with its C<NOFILE> define on some systems, 75so you may have to set I<maxopen> yourself. 76 77=cut 78 79require 5.006; 80use Carp; 81use Config; 82use strict; 83no strict 'refs'; 84# These are not C<my> for legacy reasons. 85# Previous versions requested the user set $cacheout_maxopen by hand. 86# Some authors fiddled with %saw to overcome the clobber on initial open. 87use vars qw(%saw $cacheout_maxopen); 88my %isopen; 89my $cacheout_seq = 0; 90 91sub import { 92 my ($pkg,%args) = @_; 93 $pkg = caller(1); 94 *{$pkg.'::cacheout'} = \&cacheout; 95 *{$pkg.'::close'} = \&cacheout_close; 96 97 # Truth is okay here because setting maxopen to 0 would be bad 98 return $cacheout_maxopen = $args{maxopen} if $args{maxopen}; 99 foreach my $param ( '/usr/include/sys/param.h' ){ 100 if (open($param, '<', $param)) { 101 local ($_, $.); 102 while (<$param>) { 103 if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){ 104 $cacheout_maxopen = $1 - 4; 105 close($param); 106 last; 107 } 108 } 109 close $param; 110 } 111 } 112 $cacheout_maxopen ||= 16; 113} 114 115# Open in their package. 116sub cacheout_open { 117 return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1]; 118} 119 120# Close in their package. 121sub cacheout_close { 122 # Short-circuit in case the filehandle disappeared 123 my $pkg = caller($_[1]||0); 124 fileno(*{$pkg . '::' . $_[0]}) && 125 CORE::close(*{$pkg . '::' . $_[0]}); 126 delete $isopen{$_[0]}; 127} 128 129# But only this sub name is visible to them. 130sub cacheout { 131 my($mode, $file, $class, $ret, $ref, $narg); 132 croak "Not enough arguments for cacheout" unless $narg = scalar @_; 133 croak "Too many arguments for cacheout" if $narg > 2; 134 135 ($mode, $file) = @_; 136 ($file, $mode) = ($mode, $file) if $narg == 1; 137 croak "Invalid mode for cacheout" if $mode && 138 ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ ); 139 140 # Mode changed? 141 if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[2] ){ 142 &cacheout_close($file, 1); 143 } 144 145 if( $isopen{$file}) { 146 $ret = $file; 147 $isopen{$file}->[0]++; 148 } 149 else{ 150 if( scalar keys(%isopen) > $cacheout_maxopen -1 ) { 151 my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen); 152 $cacheout_seq = 0; 153 $isopen{$_}->[0] = $cacheout_seq++ for 154 splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen); 155 &cacheout_close($_, 1) for @lru; 156 } 157 158 unless( $ref ){ 159 $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>'); 160 } 161 #XXX should we just return the value from cacheout_open, no croak? 162 $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!"); 163 164 $isopen{$file} = [++$cacheout_seq, $mode]; 165 } 166 return $ret; 167} 1681; 169