This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Re: restricted hashes are unblessable
[perl5.git] / lib / FileCache.pm
CommitLineData
c07a80fd 1package FileCache;
2
7c21b9ea 3our $VERSION = '1.01';
b75c8c73 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
7c21b9ea
JP
21=head1 CAVEATS
22
23If the argument passed to cacheout does not begin with a valid mode
24(>, +>, <, +<, >>, |) then the file will be clobbered the first time
25it is opened.
26
27 cacheout '>>' . $path;
28 print $path @data;
29
30If $path includes the filemode the filehandle will not be accessible
31as $path.
32
c07a80fd 33=head1 BUGS
34
35F<sys/param.h> lies with its C<NOFILE> define on some systems,
687277c3 36so you may have to set $FileCache::cacheout_maxopen yourself.
c07a80fd 37
38=cut
39
40require 5.000;
41use Carp;
42use Exporter;
7c21b9ea
JP
43use strict;
44use vars qw(@ISA @EXPORT %saw $cacheout_maxopen);
c07a80fd 45
46@ISA = qw(Exporter);
47@EXPORT = qw(
48 cacheout
49);
50
7c21b9ea
JP
51my %isopen;
52my $cacheout_seq = 0;
53
c07a80fd 54# Open in their package.
55
56sub cacheout_open {
57 my $pack = caller(1);
7c21b9ea 58 no strict 'refs';
c07a80fd 59 open(*{$pack . '::' . $_[0]}, $_[1]);
60}
61
62sub cacheout_close {
63 my $pack = caller(1);
64 close(*{$pack . '::' . $_[0]});
65}
66
67# But only this sub name is visible to them.
68
c07a80fd 69sub cacheout {
7c21b9ea 70 my($file) = @_;
c07a80fd 71 unless (defined $cacheout_maxopen) {
72 if (open(PARAM,'/usr/include/sys/param.h')) {
7adad424 73 local ($_, $.);
c07a80fd 74 while (<PARAM>) {
75 $cacheout_maxopen = $1 - 4
76 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
77 }
78 close PARAM;
79 }
80 $cacheout_maxopen = 16 unless $cacheout_maxopen;
81 }
82 if (!$isopen{$file}) {
7c21b9ea 83 if ( scalar keys(%isopen) + 1 > $cacheout_maxopen) {
c07a80fd 84 my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
85 splice(@lru, $cacheout_maxopen / 3);
c07a80fd 86 for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
87 }
7c21b9ea
JP
88 my $symbol = $file;
89 unless( $symbol =~ s/^(\s?(?:>>)|(?:\+?>)|(?:\+?<)|\|)// ){
90 $file = ($saw{$file}++ ? '>>' : '>') . $file;
91 }
92 cacheout_open($symbol, $file)
c07a80fd 93 or croak("Can't create $file: $!");
94 }
95 $isopen{$file} = ++$cacheout_seq;
96}
97
981;