lib/FileCache.pm

   1 package FileCache;
   2
   3 our $VERSION = '1.01';
   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 CAVEATS
  22
  23 If the argument passed to cacheout does not begin with a valid mode
  24 (>, +>, <, +<, >>, |) then the file will be clobbered the first time
  25 it is opened.
  26
  27     cacheout '>>' . $path;
  28     print $path @data;
  29
  30 If $path includes the filemode the filehandle will not be accessible
  31 as $path.
  32
  33 =head1 BUGS
  34
  35 F<sys/param.h> lies with its C<NOFILE> define on some systems,
  36 so you may have to set $FileCache::cacheout_maxopen yourself.
  37
  38 =cut
  39
  40 require 5.000;
  41 use Carp;
  42 use Exporter;
  43 use strict;
  44 use vars qw(@ISA @EXPORT %saw $cacheout_maxopen);
  45
  46 @ISA = qw(Exporter);
  47 @EXPORT = qw(
  48     cacheout
  49 );
  50
  51 my %isopen;
  52 my $cacheout_seq = 0;
  53
  54 # Open in their package.
  55
  56 sub cacheout_open {
  57     my $pack = caller(1);
  58     no strict 'refs';
  59     open(*{$pack . '::' . $_[0]}, $_[1]);
  60 }
  61
  62 sub cacheout_close {
  63     my $pack = caller(1);
  64     close(*{$pack . '::' . $_[0]});
  65 }
  66
  67 # But only this sub name is visible to them.
  68
  69 sub cacheout {
  70     my($file) = @_;
  71     unless (defined $cacheout_maxopen) {
  72         if (open(PARAM,'/usr/include/sys/param.h')) {
  73             local ($_, $.);
  74             while (<PARAM>) {
  75                 $cacheout_maxopen = $1 - 4
  76                     if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
  77             }
  78             close PARAM;
  79         }
  80         $cacheout_maxopen = 16 unless $cacheout_maxopen;
  81     }
  82     if (!$isopen{$file}) {
  83         if ( scalar keys(%isopen) + 1 > $cacheout_maxopen) {
  84             my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
  85             splice(@lru, $cacheout_maxopen / 3);
  86             for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
  87         }
  88         my $symbol = $file;
  89         unless( $symbol =~ s/^(\s?(?:>>)|(?:\+?>)|(?:\+?<)|\|)// ){
  90           $file = ($saw{$file}++ ? '>>' : '>') . $file;
  91         }
  92         cacheout_open($symbol, $file)
  93             or croak("Can't create $file: $!");
  94     }
  95     $isopen{$file} = ++$cacheout_seq;
  96 }
  97
  98 1;