This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
FileCache 1.02 -> 1.021
[perl5.git] / lib / FileCache.pm
CommitLineData
c07a80fd 1package FileCache;
2
dfe3554a 3our $VERSION = '1.021';
b75c8c73 4
c07a80fd 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
c07a80fd 15 cacheout $path;
16 print $path @data;
17
c14fc35a
JH
18 cacheout $mode, $path;
19 print $path @data;
20
c07a80fd 21=head1 DESCRIPTION
22
23The C<cacheout> function will make sure that there's a filehandle open
c14fc35a
JH
24for reading or writing available as the pathname you give it. It
25automatically closes and re-opens files if you exceed your system's
26maximum number of file descriptors, or the suggested maximum.
c07a80fd 27
c14fc35a 28=over
7c21b9ea 29
c14fc35a 30=item cacheout EXPR
7c21b9ea 31
c14fc35a
JH
32The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
33on it's first use, and appending (C<<< '>>' >>>) thereafter.
34
35=item cacheout MODE, EXPR
36
37The 2-argument form of cacheout will use the supplied mode for the initial
38and subsequent openings. Most valid modes for 3-argument C<open> are supported
39namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
40C< '|-' > and C< '-|' >
41
42=head1 CAVEATS
7c21b9ea 43
c14fc35a
JH
44If you use cacheout with C<'|-'> or C<'-|'> you should catch SIGPIPE
45and explicitly close the filehandle., when it is closed from the
46other end some cleanup needs to be done.
7c21b9ea 47
dfe3554a
JP
48While it is permissible to C<close> a FileCache managed file,
49do not do so if you are calling C<FileCache::cacheout> from a package other
50than which it was imported, or with another module which overrides C<close>.
51If you must, use C<FileCache::cacheout_close>.
52
c07a80fd 53=head1 BUGS
54
55F<sys/param.h> lies with its C<NOFILE> define on some systems,
c14fc35a 56so you may have to set maxopen (I<$FileCache::cacheout_maxopen>) yourself.
c07a80fd 57
58=cut
59
dfe3554a 60require 5.006;
c07a80fd 61use Carp;
7c21b9ea 62use strict;
c14fc35a
JH
63no strict 'refs';
64use vars qw(%saw $cacheout_maxopen);
65# These are not C<my> for legacy reasons.
66# Previous versions requested the user set $cacheout_maxopen by hand.
67# Some authors fiddled with %saw to overcome the clobber on initial open.
7c21b9ea
JP
68my %isopen;
69my $cacheout_seq = 0;
70
c14fc35a
JH
71sub import {
72 my ($pkg,%args) = @_;
73 *{caller(1).'::cacheout'} = \&cacheout;
74 *{caller(1).'::close'} = \&cacheout_close;
75
76 # Truth is okay here because setting maxopen to 0 would be bad
77 return $cacheout_maxopen = $args{maxopen} if $args{maxopen} ;
78 if (open(PARAM,'/usr/include/sys/param.h')) {
79 local ($_, $.);
80 while (<PARAM>) {
81 $cacheout_maxopen = $1 - 4
82 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
83 }
84 close PARAM;
85 }
86 $cacheout_maxopen ||= 16;
87}
88
c07a80fd 89# Open in their package.
90
91sub cacheout_open {
c14fc35a 92 open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]);
c07a80fd 93}
94
c14fc35a
JH
95# Close in their package.
96
c07a80fd 97sub cacheout_close {
c14fc35a
JH
98 fileno(*{caller(1) . '::' . $_[0]}) &&
99 CORE::close(*{caller(1) . '::' . $_[0]});
100 delete $isopen{$_[0]};
c07a80fd 101}
102
103# But only this sub name is visible to them.
c14fc35a 104
c07a80fd 105sub cacheout {
c14fc35a
JH
106 croak "Not enough arguments for cacheout" unless @_;
107 croak "Too many arguments for cacheout" if scalar @_ > 2;
108 my($mode, $file)=@_;
109 ($file, $mode) = ($mode, $file) if scalar @_ == 1;
110 # We don't want children
111 croak "Invalid file for cacheout" if $file =~ /^\s*(?:\|\-)|(?:\-\|)\s*$/;
112 croak "Invalid mode for cacheout" if $mode &&
113 ( $mode !~ /^\s*(?:>>)|(?:\+?>)|(?:\+?<)|(?:\|\-)|(?:\-\|)\s*$/ );
114
115 unless( $isopen{$file}) {
116 if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
117 my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
118 &cacheout_close($_) for splice(@lru, $cacheout_maxopen / 3);
119 }
120 $mode ||= ( $saw{$file} = ! $saw{$file} ) ? '>': '>>';
121 cacheout_open($mode, $file) or croak("Can't create $file: $!");
c07a80fd 122 }
123 $isopen{$file} = ++$cacheout_seq;
124}
125
1261;