This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to FileCache 1.04.
[perl5.git] / lib / FileCache.pm
index ee14d92..ecf7ed3 100644 (file)
@@ -1,6 +1,6 @@
 package FileCache;
 
-our $VERSION = '1.021';
+our $VERSION = 1.04;
 
 =head1 NAME
 
@@ -12,18 +12,22 @@ FileCache - keep more files open than the system permits
     # or
     use FileCache maxopen => 16;
 
+    cacheout $mode, $path;
+    # or
     cacheout $path;
     print $path @data;
 
-    cacheout $mode, $path;
-    print $path @data;
+    $fh = cacheout $mode, $path;
+    # or
+    $fh = cacheout $path;
+    print $fh @data;
 
 =head1 DESCRIPTION
 
 The C<cacheout> function will make sure that there's a filehandle open
 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.
+automatically closes and re-opens files if you exceed your system's
+maximum number of file descriptors, or the suggested maximum I<maxopen>.
 
 =over
 
@@ -32,6 +36,9 @@ maximum number of file descriptors, or the suggested maximum.
 The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
 on it's first use, and appending (C<<< '>>' >>>) thereafter.
 
+Returns EXPR on success for convenience. You may neglect the
+return value and manipulate EXPR as the filehandle directly if you prefer.
+
 =item cacheout MODE, EXPR
 
 The 2-argument form of cacheout will use the supplied mode for the initial
@@ -39,11 +46,13 @@ and subsequent openings. Most valid modes for 3-argument C<open> are supported
 namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
 C< '|-' > and C< '-|' >
 
-=head1 CAVEATS
+To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
+append them to the command string as you would system EXPR.
+
+Returns EXPR on success for convenience. You may neglect the
+return value and manipulate EXPR as the filehandle directly if you prefer.
 
-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 CAVEATS
 
 While it is permissible to C<close> a FileCache managed file,
 do not do so if you are calling C<FileCache::cacheout> from a package other
@@ -53,74 +62,109 @@ If you must, use C<FileCache::cacheout_close>.
 =head1 BUGS
 
 F<sys/param.h> lies with its C<NOFILE> define on some systems,
-so you may have to set maxopen (I<$FileCache::cacheout_maxopen>) yourself.
+so you may have to set I<maxopen> yourself.
+
+=head1 NOTES
+
+FileCache installs localized signal handlers for CHLD (a.k.a. CLD) and PIPE
+to handle deceased children from 2-arg C<cacheout> with C<'|-'> or C<'-|'>
+I<expediently>. The children would otherwise be reaped eventually, unless you
+terminated before repeatedly calling cacheout.
 
 =cut
 
 require 5.006;
 use Carp;
+use Config;
 use strict;
 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.
+use vars qw(%saw $cacheout_maxopen);
 my %isopen;
 my $cacheout_seq = 0;
 
 sub import {
     my ($pkg,%args) = @_;
-    *{caller(1).'::cacheout'} = \&cacheout;
-    *{caller(1).'::close'}    = \&cacheout_close;
+    $pkg = caller(1);
+    *{$pkg.'::cacheout'} = \&cacheout;
+    *{$pkg.'::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+)/;
+    return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
+    foreach my $param ( '/usr/include/sys/param.h' ){
+      if (open($param, '<', $param)) {
+       local ($_, $.);
+       while (<$param>) {
+         if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
+           $cacheout_maxopen = $1 - 4;
+           close($param);
+           last;
+         }
+       }
+       close $param;
       }
-      close PARAM;
     }
     $cacheout_maxopen ||= 16;
 }
 
 # Open in their package.
-
 sub cacheout_open {
-    open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]);
+  # Reap our children
+  local $SIG{CLD}  ||= 'IGNORE'if $Config{sig_name} =~ /\bCLD\b/;
+  local $SIG{CHLD} ||= 'IGNORE'if $Config{sig_name} =~ /\bCHLD\b/;
+  local $SIG{PIPE} ||= 'IGNORE'if $Config{sig_name} =~ /\bPIPE\b/;
+
+  return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
 }
 
 # Close in their package.
-
 sub cacheout_close {
-    fileno(*{caller(1) . '::' . $_[0]}) &&
-      CORE::close(*{caller(1) . '::' . $_[0]});
-    delete $isopen{$_[0]};
+  # Short-circuit in case the filehandle disappeared
+  my $pkg = caller($_[1]||0);
+  fileno(*{$pkg . '::' . $_[0]}) &&
+    CORE::close(*{$pkg . '::' . $_[0]});
+  delete $isopen{$_[0]};
 }
 
 # But only this sub name is visible to them.
 sub cacheout {
-    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*$/;
+    my($mode, $file, $class, $ret, $ref, $narg);
+    croak "Not enough arguments for cacheout"  unless $narg = scalar @_;
+    croak "Too many arguments for cacheout"    if $narg > 2;
+
+    ($mode, $file) = @_;
+    ($file, $mode) = ($mode, $file) if $narg == 1;
     croak "Invalid mode for cacheout" if $mode &&
-      ( $mode !~ /^\s*(?:>>)|(?:\+?>)|(?:\+?<)|(?:\|\-)|(?:\-\|)\s*$/ );
+      ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
 
-    unless( $isopen{$file}) {
+    # Mode changed?
+    if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[2] ){
+      &cacheout_close($file, 1);
+    }
+    
+    if( $isopen{$file}) {
+      $ret = $file;
+      $isopen{$file}->[0]++;
+    }
+    else{
       if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
-       my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
-       &cacheout_close($_) for splice(@lru, $cacheout_maxopen / 3);
+       my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
+       $cacheout_seq = 0;
+       $isopen{$_}->[0] = $cacheout_seq++ for
+         splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
+       &cacheout_close($_, 1) for @lru;
       }
-      $mode ||=  ( $saw{$file} = ! $saw{$file} ) ? '>': '>>';
-      cacheout_open($mode, $file) or croak("Can't create $file: $!");
+
+      unless( $ref ){
+       $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
+      }
+      #XXX should we just return the value from cacheout_open, no croak?
+      $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
+      
+      $isopen{$file} = [++$cacheout_seq, $mode];
     }
-    $isopen{$file} = ++$cacheout_seq;
+    return $ret;
 }
-
 1;