lib/perl5/5.8.8/FileCache.pm

   1 package FileCache;
   2
   3 our $VERSION = '1.06';
   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 $mode, $path;
  16     # or
  17     cacheout $path;
  18     print $path @data;
  19
  20     $fh = cacheout $mode, $path;
  21     # or
  22     $fh = cacheout $path;
  23     print $fh @data;
  24
  25 =head1 DESCRIPTION
  26
  27 The C<cacheout> function will make sure that there's a filehandle open
  28 for reading or writing available as the pathname you give it. It
  29 automatically closes and re-opens files if you exceed your system's
  30 maximum number of file descriptors, or the suggested maximum I<maxopen>.
  31
  32 =over
  33
  34 =item cacheout EXPR
  35
  36 The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
  37 on it's first use, and appending (C<<< '>>' >>>) thereafter.
  38
  39 Returns EXPR on success for convenience. You may neglect the
  40 return value and manipulate EXPR as the filehandle directly if you prefer.
  41
  42 =item cacheout MODE, EXPR
  43
  44 The 2-argument form of cacheout will use the supplied mode for the initial
  45 and subsequent openings. Most valid modes for 3-argument C<open> are supported
  46 namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
  47 C< '|-' > and C< '-|' >
  48
  49 To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
  50 append them to the command string as you would system EXPR.
  51
  52 Returns EXPR on success for convenience. You may neglect the
  53 return value and manipulate EXPR as the filehandle directly if you prefer.
  54
  55 =back
  56
  57 =head1 CAVEATS
  58
  59 While it is permissible to C<close> a FileCache managed file,
  60 do not do so if you are calling C<FileCache::cacheout> from a package other
  61 than which it was imported, or with another module which overrides C<close>.
  62 If you must, use C<FileCache::cacheout_close>.
  63
  64 Although FileCache can be used with piped opens ('-|' or '|-') doing so is
  65 strongly discouraged.  If FileCache finds it necessary to close and then reopen
  66 a pipe, the command at the far end of the pipe will be reexecuted - the results
  67 of performing IO on FileCache'd pipes is unlikely to be what you expect.  The
  68 ability to use FileCache on pipes may be removed in a future release.
  69
  70 FileCache does not store the current file offset if it finds it necessary to
  71 close a file.  When the file is reopened, the offset will be as specified by the
  72 original C<open> file mode.  This could be construed to be a bug.
  73
  74 =head1 BUGS
  75
  76 F<sys/param.h> lies with its C<NOFILE> define on some systems,
  77 so you may have to set I<maxopen> yourself.
  78
  79 =cut
  80
  81 require 5.006;
  82 use Carp;
  83 use Config;
  84 use strict;
  85 no strict 'refs';
  86
  87 # These are not C<my> for legacy reasons.
  88 # Previous versions requested the user set $cacheout_maxopen by hand.
  89 # Some authors fiddled with %saw to overcome the clobber on initial open.
  90 use vars qw(%saw $cacheout_maxopen);
  91 $cacheout_maxopen = 16;
  92
  93 use base 'Exporter';
  94 our @EXPORT = qw[cacheout cacheout_close];
  95
  96
  97 my %isopen;
  98 my $cacheout_seq = 0;
  99
 100 sub import {
 101     my ($pkg,%args) = @_;
 102
 103     # Use Exporter. %args are for us, not Exporter.
 104     # Make sure to up export_to_level, or we will import into ourselves,
 105     # rather than our calling package;
 106
 107     __PACKAGE__->export_to_level(1);
 108     Exporter::import( $pkg );
 109
 110     # Truth is okay here because setting maxopen to 0 would be bad
 111     return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
 112
 113     # XXX This code is crazy.  Why is it a one element foreach loop?
 114     # Why is it using $param both as a filename and filehandle?
 115     foreach my $param ( '/usr/include/sys/param.h' ){
 116       if (open($param, '<', $param)) {
 117         local ($_, $.);
 118         while (<$param>) {
 119           if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
 120             $cacheout_maxopen = $1 - 4;
 121             close($param);
 122             last;
 123           }
 124         }
 125         close $param;
 126       }
 127     }
 128     $cacheout_maxopen ||= 16;
 129 }
 130
 131 # Open in their package.
 132 sub cacheout_open {
 133   return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
 134 }
 135
 136 # Close in their package.
 137 sub cacheout_close {
 138   # Short-circuit in case the filehandle disappeared
 139   my $pkg = caller($_[1]||0);
 140   fileno(*{$pkg . '::' . $_[0]}) &&
 141     CORE::close(*{$pkg . '::' . $_[0]});
 142   delete $isopen{$_[0]};
 143 }
 144
 145 # But only this sub name is visible to them.
 146 sub cacheout {
 147     my($mode, $file, $class, $ret, $ref, $narg);
 148     croak "Not enough arguments for cacheout"  unless $narg = scalar @_;
 149     croak "Too many arguments for cacheout"    if $narg > 2;
 150
 151     ($mode, $file) = @_;
 152     ($file, $mode) = ($mode, $file) if $narg == 1;
 153     croak "Invalid mode for cacheout" if $mode &&
 154       ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
 155
 156     # Mode changed?
 157     if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
 158       &cacheout_close($file, 1);
 159     }
 160
 161     if( $isopen{$file}) {
 162       $ret = $file;
 163       $isopen{$file}->[0]++;
 164     }
 165     else{
 166       if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
 167         my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
 168         $cacheout_seq = 0;
 169         $isopen{$_}->[0] = $cacheout_seq++ for
 170           splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
 171         &cacheout_close($_, 1) for @lru;
 172       }
 173
 174       unless( $ref ){
 175         $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
 176       }
 177       #XXX should we just return the value from cacheout_open, no croak?
 178       $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
 179
 180       $isopen{$file} = [++$cacheout_seq, $mode];
 181     }
 182     return $ret;
 183 }
 184 1;