lib/FileCache.pm

   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;