perl5.002beta3
[perl.git] / lib / FileCache.pm
1 package FileCache;
2
3 =head1 NAME
4
5 FileCache - 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
14 The C<cacheout> function will make sure that there's a filehandle open
15 for writing available as the pathname you give it.  It automatically
16 closes and re-opens files if you exceed your system file descriptor
17 maximum.
18
19 =head1 BUGS
20
21 F<sys/param.h> lies with its C<NOFILE> define on some systems,
22 so you may have to set $cacheout::maxopen yourself.
23
24 =cut
25
26 require 5.000;
27 use Carp;
28 use Exporter;
29
30 @ISA = qw(Exporter);
31 @EXPORT = qw(
32     cacheout
33 );
34
35 # Open in their package.
36
37 sub cacheout_open {
38     my $pack = caller(1);
39     open(*{$pack . '::' . $_[0]}, $_[1]);
40 }
41
42 sub 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
52 sub 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
78 1;