This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
More NetBSD patches from Johnny Lam.
[perl5.git] / lib / FileCache.pm
CommitLineData
c07a80fd 1package FileCache;
2
c14fc35a 3our $VERSION = '1.02';
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
c07a80fd 48=head1 BUGS
49
50F<sys/param.h> lies with its C<NOFILE> define on some systems,
c14fc35a 51so you may have to set maxopen (I<$FileCache::cacheout_maxopen>) yourself.
c07a80fd 52
53=cut
54
55require 5.000;
56use Carp;
7c21b9ea 57use strict;
c14fc35a
JH
58no strict 'refs';
59use vars qw(%saw $cacheout_maxopen);
60# These are not C<my> for legacy reasons.
61# Previous versions requested the user set $cacheout_maxopen by hand.
62# Some authors fiddled with %saw to overcome the clobber on initial open.
7c21b9ea
JP
63my %isopen;
64my $cacheout_seq = 0;
65
c14fc35a
JH
66sub import {
67 my ($pkg,%args) = @_;
68 *{caller(1).'::cacheout'} = \&cacheout;
69 *{caller(1).'::close'} = \&cacheout_close;
70
71 # Truth is okay here because setting maxopen to 0 would be bad
72 return $cacheout_maxopen = $args{maxopen} if $args{maxopen} ;
73 if (open(PARAM,'/usr/include/sys/param.h')) {
74 local ($_, $.);
75 while (<PARAM>) {
76 $cacheout_maxopen = $1 - 4
77 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
78 }
79 close PARAM;
80 }
81 $cacheout_maxopen ||= 16;
82}
83
c07a80fd 84# Open in their package.
85
86sub cacheout_open {
c14fc35a 87 open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]);
c07a80fd 88}
89
c14fc35a
JH
90# Close in their package.
91
c07a80fd 92sub cacheout_close {
c14fc35a
JH
93 fileno(*{caller(1) . '::' . $_[0]}) &&
94 CORE::close(*{caller(1) . '::' . $_[0]});
95 delete $isopen{$_[0]};
c07a80fd 96}
97
98# But only this sub name is visible to them.
c14fc35a 99
c07a80fd 100sub cacheout {
c14fc35a
JH
101 croak "Not enough arguments for cacheout" unless @_;
102 croak "Too many arguments for cacheout" if scalar @_ > 2;
103 my($mode, $file)=@_;
104 ($file, $mode) = ($mode, $file) if scalar @_ == 1;
105 # We don't want children
106 croak "Invalid file for cacheout" if $file =~ /^\s*(?:\|\-)|(?:\-\|)\s*$/;
107 croak "Invalid mode for cacheout" if $mode &&
108 ( $mode !~ /^\s*(?:>>)|(?:\+?>)|(?:\+?<)|(?:\|\-)|(?:\-\|)\s*$/ );
109
110 unless( $isopen{$file}) {
111 if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
112 my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
113 &cacheout_close($_) for splice(@lru, $cacheout_maxopen / 3);
114 }
115 $mode ||= ( $saw{$file} = ! $saw{$file} ) ? '>': '>>';
116 cacheout_open($mode, $file) or croak("Can't create $file: $!");
c07a80fd 117 }
118 $isopen{$file} = ++$cacheout_seq;
119}
120
1211;