This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b1a30dec3a3c5f7f8dea4a47b4051743a3cfe07c
[perl5.git] / lib / FileCache.pm
1 package FileCache;
2
3 our $VERSION = '1.04_01';
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 =head1 CAVEATS
56
57 While it is permissible to C<close> a FileCache managed file,
58 do not do so if you are calling C<FileCache::cacheout> from a package other
59 than which it was imported, or with another module which overrides C<close>.
60 If you must, use C<FileCache::cacheout_close>.
61
62 Although FileCache can be used with piped opens ('-|' or '|-') doing so is
63 strongly discouraged.  If FileCache finds it necessary to close and then reopen
64 a pipe, the command at the far end of the pipe will be reexecuted - the results
65 of performing IO on FileCache'd pipes is unlikely to be what you expect.  The
66 ability to use FileCache on pipes may be removed in a future release.
67
68 FileCache does not store the current file offset if it finds it necessary to
69 close a file.  When the file is reopened, the offset will be as specified by the
70 original C<open> file mode.  This could be construed to be a bug.
71
72 =head1 BUGS
73
74 F<sys/param.h> lies with its C<NOFILE> define on some systems,
75 so you may have to set I<maxopen> yourself.
76
77 =cut
78
79 require 5.006;
80 use Carp;
81 use Config;
82 use strict;
83 no 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.
87 use vars qw(%saw $cacheout_maxopen);
88 my %isopen;
89 my $cacheout_seq = 0;
90
91 sub 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.
116 sub cacheout_open {
117   return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
118 }
119
120 # Close in their package.
121 sub 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.
130 sub 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}->[1] ){
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 }
168 1;