This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to FileCache 1.04.
[perl5.git] / lib / FileCache.pm
CommitLineData
c07a80fd
PP
1package FileCache;
2
841bcc4d 3our $VERSION = 1.04;
b75c8c73 4
c07a80fd
PP
5=head1 NAME
6
7FileCache - keep more files open than the system permits
8
9=head1 SYNOPSIS
10
c14fc35a
JH
11 use FileCache;
12 # or
13 use FileCache maxopen => 16;
14
ba1df86b
JP
15 cacheout $mode, $path;
16 # or
c07a80fd
PP
17 cacheout $path;
18 print $path @data;
19
ba1df86b
JP
20 $fh = cacheout $mode, $path;
21 # or
22 $fh = cacheout $path;
23 print $fh @data;
c14fc35a 24
c07a80fd
PP
25=head1 DESCRIPTION
26
27The C<cacheout> function will make sure that there's a filehandle open
c14fc35a 28for reading or writing available as the pathname you give it. It
ba1df86b
JP
29automatically closes and re-opens files if you exceed your system's
30maximum number of file descriptors, or the suggested maximum I<maxopen>.
c07a80fd 31
c14fc35a 32=over
7c21b9ea 33
c14fc35a 34=item cacheout EXPR
7c21b9ea 35
c14fc35a
JH
36The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
37on it's first use, and appending (C<<< '>>' >>>) thereafter.
38
ba1df86b
JP
39Returns EXPR on success for convenience. You may neglect the
40return value and manipulate EXPR as the filehandle directly if you prefer.
41
c14fc35a
JH
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
841bcc4d
RGS
49To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
50append them to the command string as you would system EXPR.
51
ba1df86b
JP
52Returns EXPR on success for convenience. You may neglect the
53return value and manipulate EXPR as the filehandle directly if you prefer.
7c21b9ea 54
ba1df86b 55=head1 CAVEATS
7c21b9ea 56
dfe3554a
JP
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
c07a80fd
PP
62=head1 BUGS
63
64F<sys/param.h> lies with its C<NOFILE> define on some systems,
ba1df86b
JP
65so you may have to set I<maxopen> yourself.
66
67=head1 NOTES
68
841bcc4d
RGS
69FileCache installs localized signal handlers for CHLD (a.k.a. CLD) and PIPE
70to handle deceased children from 2-arg C<cacheout> with C<'|-'> or C<'-|'>
71I<expediently>. The children would otherwise be reaped eventually, unless you
72terminated before repeatedly calling cacheout.
c07a80fd
PP
73
74=cut
75
dfe3554a 76require 5.006;
c07a80fd 77use Carp;
42bff5bd 78use Config;
7c21b9ea 79use strict;
c14fc35a 80no strict 'refs';
c14fc35a
JH
81# These are not C<my> for legacy reasons.
82# Previous versions requested the user set $cacheout_maxopen by hand.
83# Some authors fiddled with %saw to overcome the clobber on initial open.
ba1df86b 84use vars qw(%saw $cacheout_maxopen);
7c21b9ea
JP
85my %isopen;
86my $cacheout_seq = 0;
87
c14fc35a
JH
88sub import {
89 my ($pkg,%args) = @_;
ba1df86b
JP
90 $pkg = caller(1);
91 *{$pkg.'::cacheout'} = \&cacheout;
92 *{$pkg.'::close'} = \&cacheout_close;
93
c14fc35a 94 # Truth is okay here because setting maxopen to 0 would be bad
ba1df86b
JP
95 return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
96 foreach my $param ( '/usr/include/sys/param.h' ){
97 if (open($param, '<', $param)) {
98 local ($_, $.);
99 while (<$param>) {
100 if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
101 $cacheout_maxopen = $1 - 4;
102 close($param);
103 last;
104 }
105 }
106 close $param;
c14fc35a 107 }
c14fc35a
JH
108 }
109 $cacheout_maxopen ||= 16;
110}
111
c07a80fd 112# Open in their package.
c07a80fd 113sub cacheout_open {
841bcc4d
RGS
114 # Reap our children
115 local $SIG{CLD} ||= 'IGNORE'if $Config{sig_name} =~ /\bCLD\b/;
116 local $SIG{CHLD} ||= 'IGNORE'if $Config{sig_name} =~ /\bCHLD\b/;
117 local $SIG{PIPE} ||= 'IGNORE'if $Config{sig_name} =~ /\bPIPE\b/;
118
ba1df86b 119 return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
c07a80fd
PP
120}
121
c14fc35a 122# Close in their package.
c07a80fd 123sub cacheout_close {
ba1df86b
JP
124 # Short-circuit in case the filehandle disappeared
125 my $pkg = caller($_[1]||0);
126 fileno(*{$pkg . '::' . $_[0]}) &&
127 CORE::close(*{$pkg . '::' . $_[0]});
128 delete $isopen{$_[0]};
c07a80fd
PP
129}
130
131# But only this sub name is visible to them.
c07a80fd 132sub cacheout {
ba1df86b
JP
133 my($mode, $file, $class, $ret, $ref, $narg);
134 croak "Not enough arguments for cacheout" unless $narg = scalar @_;
135 croak "Too many arguments for cacheout" if $narg > 2;
c14fc35a 136
ba1df86b
JP
137 ($mode, $file) = @_;
138 ($file, $mode) = ($mode, $file) if $narg == 1;
139 croak "Invalid mode for cacheout" if $mode &&
140 ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
841bcc4d 141
ba1df86b
JP
142 # Mode changed?
143 if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[2] ){
144 &cacheout_close($file, 1);
145 }
146
147 if( $isopen{$file}) {
148 $ret = $file;
149 $isopen{$file}->[0]++;
150 }
151 else{
c14fc35a 152 if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
ba1df86b
JP
153 my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
154 $cacheout_seq = 0;
155 $isopen{$_}->[0] = $cacheout_seq++ for
156 splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
157 &cacheout_close($_, 1) for @lru;
c14fc35a 158 }
ba1df86b
JP
159
160 unless( $ref ){
161 $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
162 }
163 #XXX should we just return the value from cacheout_open, no croak?
164 $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
165
166 $isopen{$file} = [++$cacheout_seq, $mode];
c07a80fd 167 }
ba1df86b 168 return $ret;
c07a80fd 169}
c07a80fd 1701;