This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5.002beta3
[perl5.git] / lib / FileCache.pm
CommitLineData
c07a80fd 1package FileCache;
2
3=head1 NAME
4
5FileCache - keep more files open than the system permits
6
7=head1 SYNOPSIS
8
9 cacheout $path;
10 print $path @data;
11
12=head1 DESCRIPTION
13
14The C<cacheout> function will make sure that there's a filehandle open
15for writing available as the pathname you give it. It automatically
16closes and re-opens files if you exceed your system file descriptor
17maximum.
18
19=head1 BUGS
20
21F<sys/param.h> lies with its C<NOFILE> define on some systems,
22so you may have to set $cacheout::maxopen yourself.
23
24=cut
25
26require 5.000;
27use Carp;
28use Exporter;
29
30@ISA = qw(Exporter);
31@EXPORT = qw(
32 cacheout
33);
34
35# Open in their package.
36
37sub cacheout_open {
38 my $pack = caller(1);
39 open(*{$pack . '::' . $_[0]}, $_[1]);
40}
41
42sub cacheout_close {
43 my $pack = caller(1);
44 close(*{$pack . '::' . $_[0]});
45}
46
47# But only this sub name is visible to them.
48
49$cacheout_seq = 0;
50$cacheout_numopen = 0;
51
52sub cacheout {
53 ($file) = @_;
54 unless (defined $cacheout_maxopen) {
55 if (open(PARAM,'/usr/include/sys/param.h')) {
56 local $.;
57 while (<PARAM>) {
58 $cacheout_maxopen = $1 - 4
59 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
60 }
61 close PARAM;
62 }
63 $cacheout_maxopen = 16 unless $cacheout_maxopen;
64 }
65 if (!$isopen{$file}) {
66 if (++$cacheout_numopen > $cacheout_maxopen) {
67 my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
68 splice(@lru, $cacheout_maxopen / 3);
69 $cacheout_numopen -= @lru;
70 for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
71 }
72 cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
73 or croak("Can't create $file: $!");
74 }
75 $isopen{$file} = ++$cacheout_seq;
76}
77
781;