lib/perl5/5.6.1/FileCache.pm

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