lib/FileCache.pm

   1 package FileCache;
   2
   3 our $VERSION = '1.02';
   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 =head1 BUGS
  49
  50 F<sys/param.h> lies with its C<NOFILE> define on some systems,
  51 so you may have to set maxopen (I<$FileCache::cacheout_maxopen>) yourself.
  52
  53 =cut
  54
  55 require 5.000;
  56 use Carp;
  57 use strict;
  58 no strict 'refs';
  59 use 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.
  63 my %isopen;
  64 my $cacheout_seq = 0;
  65
  66 sub 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
  84 # Open in their package.
  85
  86 sub cacheout_open {
  87     open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]);
  88 }
  89
  90 # Close in their package.
  91
  92 sub cacheout_close {
  93     fileno(*{caller(1) . '::' . $_[0]}) &&
  94       CORE::close(*{caller(1) . '::' . $_[0]});
  95     delete $isopen{$_[0]};
  96 }
  97
  98 # But only this sub name is visible to them.
  99
 100 sub cacheout {
 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: $!");
 117     }
 118     $isopen{$file} = ++$cacheout_seq;
 119 }
 120
 121 1;