Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package FileCache; |
2 | ||
3 | our $VERSION = '1.021'; | |
4 | ||
5 | =head1 NAME | |
6 | ||
7 | FileCache - keep more files open than the system permits | |
8 | ||
9 | =head1 SYNOPSIS | |
10 | ||
11 | use FileCache; | |
12 | # or | |
13 | use FileCache maxopen => 16; | |
14 | ||
15 | cacheout $path; | |
16 | print $path @data; | |
17 | ||
18 | cacheout $mode, $path; | |
19 | print $path @data; | |
20 | ||
21 | =head1 DESCRIPTION | |
22 | ||
23 | The C<cacheout> function will make sure that there's a filehandle open | |
24 | for reading or writing available as the pathname you give it. It | |
25 | automatically closes and re-opens files if you exceed your system's | |
26 | maximum number of file descriptors, or the suggested maximum. | |
27 | ||
28 | =over | |
29 | ||
30 | =item cacheout EXPR | |
31 | ||
32 | The 1-argument form of cacheout will open a file for writing (C<< '>' >>) | |
33 | on it's first use, and appending (C<<< '>>' >>>) thereafter. | |
34 | ||
35 | =item cacheout MODE, EXPR | |
36 | ||
37 | The 2-argument form of cacheout will use the supplied mode for the initial | |
38 | and subsequent openings. Most valid modes for 3-argument C<open> are supported | |
39 | namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>, | |
40 | C< '|-' > and C< '-|' > | |
41 | ||
42 | =head1 CAVEATS | |
43 | ||
44 | If you use cacheout with C<'|-'> or C<'-|'> you should catch SIGPIPE | |
45 | and explicitly close the filehandle., when it is closed from the | |
46 | other end some cleanup needs to be done. | |
47 | ||
48 | While it is permissible to C<close> a FileCache managed file, | |
49 | do not do so if you are calling C<FileCache::cacheout> from a package other | |
50 | than which it was imported, or with another module which overrides C<close>. | |
51 | If you must, use C<FileCache::cacheout_close>. | |
52 | ||
53 | =head1 BUGS | |
54 | ||
55 | F<sys/param.h> lies with its C<NOFILE> define on some systems, | |
56 | so you may have to set maxopen (I<$FileCache::cacheout_maxopen>) yourself. | |
57 | ||
58 | =cut | |
59 | ||
60 | require 5.006; | |
61 | use Carp; | |
62 | use strict; | |
63 | no strict 'refs'; | |
64 | use vars qw(%saw $cacheout_maxopen); | |
65 | # These are not C<my> for legacy reasons. | |
66 | # Previous versions requested the user set $cacheout_maxopen by hand. | |
67 | # Some authors fiddled with %saw to overcome the clobber on initial open. | |
68 | my %isopen; | |
69 | my $cacheout_seq = 0; | |
70 | ||
71 | sub import { | |
72 | my ($pkg,%args) = @_; | |
73 | *{caller(1).'::cacheout'} = \&cacheout; | |
74 | *{caller(1).'::close'} = \&cacheout_close; | |
75 | ||
76 | # Truth is okay here because setting maxopen to 0 would be bad | |
77 | return $cacheout_maxopen = $args{maxopen} if $args{maxopen} ; | |
78 | if (open(PARAM,'/usr/include/sys/param.h')) { | |
79 | local ($_, $.); | |
80 | while (<PARAM>) { | |
81 | $cacheout_maxopen = $1 - 4 | |
82 | if /^\s*#\s*define\s+NOFILE\s+(\d+)/; | |
83 | } | |
84 | close PARAM; | |
85 | } | |
86 | $cacheout_maxopen ||= 16; | |
87 | } | |
88 | ||
89 | # Open in their package. | |
90 | ||
91 | sub cacheout_open { | |
92 | open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]); | |
93 | } | |
94 | ||
95 | # Close in their package. | |
96 | ||
97 | sub cacheout_close { | |
98 | fileno(*{caller(1) . '::' . $_[0]}) && | |
99 | CORE::close(*{caller(1) . '::' . $_[0]}); | |
100 | delete $isopen{$_[0]}; | |
101 | } | |
102 | ||
103 | # But only this sub name is visible to them. | |
104 | ||
105 | sub cacheout { | |
106 | croak "Not enough arguments for cacheout" unless @_; | |
107 | croak "Too many arguments for cacheout" if scalar @_ > 2; | |
108 | my($mode, $file)=@_; | |
109 | ($file, $mode) = ($mode, $file) if scalar @_ == 1; | |
110 | # We don't want children | |
111 | croak "Invalid file for cacheout" if $file =~ /^\s*(?:\|\-)|(?:\-\|)\s*$/; | |
112 | croak "Invalid mode for cacheout" if $mode && | |
113 | ( $mode !~ /^\s*(?:>>)|(?:\+?>)|(?:\+?<)|(?:\|\-)|(?:\-\|)\s*$/ ); | |
114 | ||
115 | unless( $isopen{$file}) { | |
116 | if( scalar keys(%isopen) > $cacheout_maxopen -1 ) { | |
117 | my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); | |
118 | &cacheout_close($_) for splice(@lru, $cacheout_maxopen / 3); | |
119 | } | |
120 | $mode ||= ( $saw{$file} = ! $saw{$file} ) ? '>': '>>'; | |
121 | cacheout_open($mode, $file) or croak("Can't create $file: $!"); | |
122 | } | |
123 | $isopen{$file} = ++$cacheout_seq; | |
124 | } | |
125 | ||
126 | 1; |