patch for FileCache in 5.7.3

Message-Id: <200204140438.AAA30812@calloway.mit.edu>

p4raw-id: //depot/perl@15908

1 files changed, 26 insertions, 8 deletions

diff --git a/lib/FileCache.pm b/lib/FileCache.pm
index 78a3e67c31..2cfa91e04d 100644
--- a/lib/FileCache.pm
+++ b/lib/FileCache.pm
@@ -1,6 +1,6 @@
 package FileCache;
 
-our $VERSION = '1.00';
+our $VERSION = '1.01';
 
 =head1 NAME
 
@@ -18,6 +18,18 @@ for writing available as the pathname you give it.  It automatically
 closes and re-opens files if you exceed your system file descriptor
 maximum.
 
+=head1 CAVEATS
+
+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.
+
+    cacheout '>>' . $path;
+    print $path @data;
+
+If $path includes the filemode the filehandle will not be accessible
+as $path.
+
 =head1 BUGS
 
 F<sys/param.h> lies with its C<NOFILE> define on some systems,
@@ -28,16 +40,22 @@ so you may have to set $FileCache::cacheout_maxopen yourself.
 require 5.000;
 use Carp;
 use Exporter;
+use strict;
+use vars qw(@ISA @EXPORT %saw $cacheout_maxopen);
 
 @ISA = qw(Exporter);
 @EXPORT = qw(
     cacheout
 );
 
+my %isopen;
+my $cacheout_seq = 0;
+
 # Open in their package.
 
 sub cacheout_open {
     my $pack = caller(1);
+    no strict 'refs';
     open(*{$pack . '::' . $_[0]}, $_[1]);
 }
 
@@ -48,11 +66,8 @@ sub cacheout_close {
 
 # But only this sub name is visible to them.
 
-$cacheout_seq = 0;
-$cacheout_numopen = 0;
-
 sub cacheout {
-    ($file) = @_;
+    my($file) = @_;
     unless (defined $cacheout_maxopen) {
 	if (open(PARAM,'/usr/include/sys/param.h')) {
 	    local ($_, $.);
@@ -65,13 +80,16 @@ sub cacheout {
 	$cacheout_maxopen = 16 unless $cacheout_maxopen;
     }
     if (!$isopen{$file}) {
-	if (++$cacheout_numopen > $cacheout_maxopen) {
+	if ( scalar keys(%isopen) + 1 > $cacheout_maxopen) {
 	    my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
 	    splice(@lru, $cacheout_maxopen / 3);
-	    $cacheout_numopen -= @lru;
 	    for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
 	}
-	cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+	my $symbol = $file;
+	unless( $symbol =~ s/^(\s?(?:>>)|(?:\+?>)|(?:\+?<)|\|)// ){
+	  $file = ($saw{$file}++ ? '>>' : '>') . $file;
+	}
+	cacheout_open($symbol, $file)
 	    or croak("Can't create $file: $!");
     }
     $isopen{$file} = ++$cacheout_seq;