FileCache 1.02, from Jerrad Pierce <belg4mit@MIT.EDU>.

p4raw-id: //depot/perl@15927

1 files changed, 74 insertions, 51 deletions

diff --git a/lib/FileCache.pm b/lib/FileCache.pm
index 2cfa91e04d..2f8f1a6986 100644
--- a/lib/FileCache.pm
+++ b/lib/FileCache.pm
@@ -1,6 +1,6 @@
 package FileCache;
 
-our $VERSION = '1.01';
+our $VERSION = '1.02';
 
 =head1 NAME
 
@@ -8,89 +8,112 @@ FileCache - keep more files open than the system permits
 
 =head1 SYNOPSIS
 
+    use FileCache;
+    # or
+    use FileCache maxopen => 16;
+
     cacheout $path;
     print $path @data;
 
+    cacheout $mode, $path;
+    print $path @data;
+
 =head1 DESCRIPTION
 
 The C<cacheout> function will make sure that there's a filehandle open
-for writing available as the pathname you give it.  It automatically
-closes and re-opens files if you exceed your system file descriptor
-maximum.
+for reading or writing available as the pathname you give it. It
+automatically closes and re-opens files if you exceed  your system's
+maximum number of file descriptors, or the suggested maximum.
 
-=head1 CAVEATS
+=over
 
-If the argument passed to cacheout does not begin with a valid mode
-(>, +>, <, +<, >>, |) then the file will be clobbered the first time
-it is opened.
+=item cacheout EXPR
 
-    cacheout '>>' . $path;
-    print $path @data;
+The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
+on it's first use, and appending (C<<< '>>' >>>) thereafter.
+
+=item cacheout MODE, EXPR
+
+The 2-argument form of cacheout will use the supplied mode for the initial
+and subsequent openings. Most valid modes for 3-argument C<open> are supported
+namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
+C< '|-' > and C< '-|' >
+
+=head1 CAVEATS
 
-If $path includes the filemode the filehandle will not be accessible
-as $path.
+If you use cacheout with C<'|-'> or C<'-|'> you should catch SIGPIPE
+and explicitly close the filehandle., when it is closed from the
+other end some cleanup needs to be done.
 
 =head1 BUGS
 
 F<sys/param.h> lies with its C<NOFILE> define on some systems,
-so you may have to set $FileCache::cacheout_maxopen yourself.
+so you may have to set maxopen (I<$FileCache::cacheout_maxopen>) yourself.
 
 =cut
 
 require 5.000;
 use Carp;
-use Exporter;
 use strict;
-use vars qw(@ISA @EXPORT %saw $cacheout_maxopen);
-
-@ISA = qw(Exporter);
-@EXPORT = qw(
-    cacheout
-);
-
+no strict 'refs';
+use vars qw(%saw $cacheout_maxopen);
+# These are not C<my> for legacy reasons.
+# Previous versions requested the user set $cacheout_maxopen by hand.
+# Some authors fiddled with %saw to overcome the clobber on initial open.
 my %isopen;
 my $cacheout_seq = 0;
 
+sub import {
+    my ($pkg,%args) = @_;
+    *{caller(1).'::cacheout'} = \&cacheout;
+    *{caller(1).'::close'}    = \&cacheout_close;
+
+    # Truth is okay here because setting maxopen to 0 would be bad
+    return $cacheout_maxopen = $args{maxopen} if $args{maxopen} ;
+    if (open(PARAM,'/usr/include/sys/param.h')) {
+      local ($_, $.);
+      while (<PARAM>) {
+	$cacheout_maxopen = $1 - 4
+	  if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+      }
+      close PARAM;
+    }
+    $cacheout_maxopen ||= 16;
+}
+
 # Open in their package.
 
 sub cacheout_open {
-    my $pack = caller(1);
-    no strict 'refs';
-    open(*{$pack . '::' . $_[0]}, $_[1]);
+    open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]);
 }
 
+# Close in their package.
+
 sub cacheout_close {
-    my $pack = caller(1);
-    close(*{$pack . '::' . $_[0]});
+    fileno(*{caller(1) . '::' . $_[0]}) &&
+      CORE::close(*{caller(1) . '::' . $_[0]});
+    delete $isopen{$_[0]};
 }
 
 # But only this sub name is visible to them.
-
+ 
 sub cacheout {
-    my($file) = @_;
-    unless (defined $cacheout_maxopen) {
-	if (open(PARAM,'/usr/include/sys/param.h')) {
-	    local ($_, $.);
-	    while (<PARAM>) {
-		$cacheout_maxopen = $1 - 4
-		    if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
-	    }
-	    close PARAM;
-	}
-	$cacheout_maxopen = 16 unless $cacheout_maxopen;
-    }
-    if (!$isopen{$file}) {
-	if ( scalar keys(%isopen) + 1 > $cacheout_maxopen) {
-	    my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
-	    splice(@lru, $cacheout_maxopen / 3);
-	    for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
-	}
-	my $symbol = $file;
-	unless( $symbol =~ s/^(\s?(?:>>)|(?:\+?>)|(?:\+?<)|\|)// ){
-	  $file = ($saw{$file}++ ? '>>' : '>') . $file;
-	}
-	cacheout_open($symbol, $file)
-	    or croak("Can't create $file: $!");
+    croak "Not enough arguments for cacheout"  unless @_;
+    croak "Too many arguments for cacheout" if scalar @_ > 2;
+    my($mode, $file)=@_;
+    ($file, $mode) = ($mode, $file) if scalar @_ == 1;
+    # We don't want children
+    croak "Invalid file for cacheout" if $file =~ /^\s*(?:\|\-)|(?:\-\|)\s*$/;
+    croak "Invalid mode for cacheout" if $mode &&
+      ( $mode !~ /^\s*(?:>>)|(?:\+?>)|(?:\+?<)|(?:\|\-)|(?:\-\|)\s*$/ );
+
+    unless( $isopen{$file}) {
+      if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
+	my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
+	&cacheout_close($_) for splice(@lru, $cacheout_maxopen / 3);
+      }
+      $mode ||=  ( $saw{$file} = ! $saw{$file} ) ? '>': '>>';
+      cacheout_open($mode, $file) or croak("Can't create $file: $!");
     }
     $isopen{$file} = ++$cacheout_seq;
 }