lib/FileCache.pm

   1 package FileCache;
   2
   3 our $VERSION = '1.00';
   4
   5 =head1 NAME
   6
   7 FileCache - keep more files open than the system permits
   8
   9 =head1 SYNOPSIS
  10
  11     cacheout $path;
  12     print $path @data;
  13
  14 =head1 DESCRIPTION
  15
  16 The C<cacheout> function will make sure that there's a filehandle open
  17 for writing available as the pathname you give it.  It automatically
  18 closes and re-opens files if you exceed your system file descriptor
  19 maximum.
  20
  21 =head1 BUGS
  22
  23 F<sys/param.h> lies with its C<NOFILE> define on some systems,
  24 so you may have to set $FileCache::cacheout_maxopen yourself.
  25
  26 =cut
  27
  28 require 5.000;
  29 use Carp;
  30 use Exporter;
  31
  32 @ISA = qw(Exporter);
  33 @EXPORT = qw(
  34     cacheout
  35 );
  36
  37 # Open in their package.
  38
  39 sub cacheout_open {
  40     my $pack = caller(1);
  41     open(*{$pack . '::' . $_[0]}, $_[1]);
  42 }
  43
  44 sub cacheout_close {
  45     my $pack = caller(1);
  46     close(*{$pack . '::' . $_[0]});
  47 }
  48
  49 # But only this sub name is visible to them.
  50
  51 $cacheout_seq = 0;
  52 $cacheout_numopen = 0;
  53
  54 sub cacheout {
  55     ($file) = @_;
  56     unless (defined $cacheout_maxopen) {
  57         if (open(PARAM,'/usr/include/sys/param.h')) {
  58             local ($_, $.);
  59             while (<PARAM>) {
  60                 $cacheout_maxopen = $1 - 4
  61                     if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
  62             }
  63             close PARAM;
  64         }
  65         $cacheout_maxopen = 16 unless $cacheout_maxopen;
  66     }
  67     if (!$isopen{$file}) {
  68         if (++$cacheout_numopen > $cacheout_maxopen) {
  69             my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
  70             splice(@lru, $cacheout_maxopen / 3);
  71             $cacheout_numopen -= @lru;
  72             for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
  73         }
  74         cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
  75             or croak("Can't create $file: $!");
  76     }
  77     $isopen{$file} = ++$cacheout_seq;
  78 }
  79
  80 1;