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