lib/FileCache.pm

   1 package FileCache;
   2
   3 our $VERSION = 1.03;
   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 $mode, $path;
  16     # or
  17     cacheout $path;
  18     print $path @data;
  19
  20     $fh = cacheout $mode, $path;
  21     # or
  22     $fh = cacheout $path;
  23     print $fh @data;
  24
  25 =head1 DESCRIPTION
  26
  27 The C<cacheout> function will make sure that there's a filehandle open
  28 for reading or writing available as the pathname you give it. It
  29 automatically closes and re-opens files if you exceed your system's
  30 maximum number of file descriptors, or the suggested maximum I<maxopen>.
  31
  32 =over
  33
  34 =item cacheout EXPR
  35
  36 The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
  37 on it's first use, and appending (C<<< '>>' >>>) thereafter.
  38
  39 Returns EXPR on success for convenience. You may neglect the
  40 return value and manipulate EXPR as the filehandle directly if you prefer.
  41
  42 =item cacheout MODE, EXPR
  43
  44 The 2-argument form of cacheout will use the supplied mode for the initial
  45 and subsequent openings. Most valid modes for 3-argument C<open> are supported
  46 namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
  47 C< '|-' > and C< '-|' >
  48
  49 Returns EXPR on success for convenience. You may neglect the
  50 return value and manipulate EXPR as the filehandle directly if you prefer.
  51
  52 =head1 CAVEATS
  53
  54 While it is permissible to C<close> a FileCache managed file,
  55 do not do so if you are calling C<FileCache::cacheout> from a package other
  56 than which it was imported, or with another module which overrides C<close>.
  57 If you must, use C<FileCache::cacheout_close>.
  58
  59 =head1 BUGS
  60
  61 F<sys/param.h> lies with its C<NOFILE> define on some systems,
  62 so you may have to set I<maxopen> yourself.
  63
  64 =head1 NOTES
  65
  66 FileCache installs signal handlers for CHLD (a.k.a. CLD) and PIPE in the
  67 calling package to handle deceased children from 2-arg C<cacheout> with C<'|-'>
  68 or C<'-|'> I<expediently>. The children would otherwise be reaped eventually,
  69 unless you terminated before repeatedly calling cacheout.
  70
  71 =cut
  72
  73 require 5.006;
  74 use Carp;
  75 use Config;
  76 use strict;
  77 no strict 'refs';
  78 # These are not C<my> for legacy reasons.
  79 # Previous versions requested the user set $cacheout_maxopen by hand.
  80 # Some authors fiddled with %saw to overcome the clobber on initial open.
  81 use vars qw(%saw $cacheout_maxopen);
  82 my %isopen;
  83 my $cacheout_seq = 0;
  84
  85 sub import {
  86     my ($pkg,%args) = @_;
  87     $pkg = caller(1);
  88     *{$pkg.'::cacheout'} = \&cacheout;
  89     *{$pkg.'::close'}    = \&cacheout_close;
  90
  91     # Reap our children
  92     ${"$pkg\::SIG"}{'CLD'}  = 'IGNORE' if $Config{sig_name} =~ /\bCLD\b/;
  93     ${"$pkg\::SIG"}{'CHLD'} = 'IGNORE' if $Config{sig_name} =~ /\bCHLD\b/;
  94     ${"$pkg\::SIG"}{'PIPE'} = 'IGNORE' if $Config{sig_name} =~ /\bPIPE\b/;
  95
  96     # Truth is okay here because setting maxopen to 0 would be bad
  97     return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
  98     foreach my $param ( '/usr/include/sys/param.h' ){
  99       if (open($param, '<', $param)) {
 100         local ($_, $.);
 101         while (<$param>) {
 102           if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
 103             $cacheout_maxopen = $1 - 4;
 104             close($param);
 105             last;
 106           }
 107         }
 108         close $param;
 109       }
 110     }
 111     $cacheout_maxopen ||= 16;
 112 }
 113
 114 # Open in their package.
 115 sub cacheout_open {
 116   return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
 117 }
 118
 119 # Close in their package.
 120 sub cacheout_close {
 121   # Short-circuit in case the filehandle disappeared
 122   my $pkg = caller($_[1]||0);
 123   fileno(*{$pkg . '::' . $_[0]}) &&
 124     CORE::close(*{$pkg . '::' . $_[0]});
 125   delete $isopen{$_[0]};
 126 }
 127
 128 # But only this sub name is visible to them.
 129 sub cacheout {
 130     my($mode, $file, $class, $ret, $ref, $narg);
 131     croak "Not enough arguments for cacheout"  unless $narg = scalar @_;
 132     croak "Too many arguments for cacheout"    if $narg > 2;
 133
 134     ($mode, $file) = @_;
 135     ($file, $mode) = ($mode, $file) if $narg == 1;
 136     croak "Invalid mode for cacheout" if $mode &&
 137       ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
 138
 139     # Mode changed?
 140     if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[2] ){
 141       &cacheout_close($file, 1);
 142     }
 143
 144     if( $isopen{$file}) {
 145       $ret = $file;
 146       $isopen{$file}->[0]++;
 147     }
 148     else{
 149       if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
 150         my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
 151         $cacheout_seq = 0;
 152         $isopen{$_}->[0] = $cacheout_seq++ for
 153           splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
 154         &cacheout_close($_, 1) for @lru;
 155       }
 156
 157       unless( $ref ){
 158         $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
 159       }
 160       #XXX should we just return the value from cacheout_open, no croak?
 161       $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
 162
 163       $isopen{$file} = [++$cacheout_seq, $mode];
 164     }
 165     return $ret;
 166 }
 167 1;