package FileCache;
-our $VERSION = '1.01';
+our $VERSION = '1.02';
=head1 NAME
=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;
}
@INC = '../lib';
}
-print "1..1\n";
+print "1..5\n";
-use FileCache;
+use FileCache maxopen=>2;
+my @files = qw(foo bar baz quux);
-# This is really not a complete test as I don't bother to open enough
-# files to make real swapping of open filedescriptor happen.
+{# Test 1: that we can open files
+ for my $path ( @files ){
+ cacheout $path;
+ print $path "$path 1\n";
+ }
+ print "not " unless scalar map({ -f } @files) == 4;
+ print "ok 1\n";
+}
-$path = "foo";
-cacheout $path;
-print $path "\n";
+{# Test 2: that we actually adhere to maxopen
+ my @cat;
+ for my $path ( @files ){
+ print $path "$path 2\n";
+ close($path);
+ open($path, $path);
+ <$path>;
+ push @cat, <$path>;
+ close($path);
+ }
+ print "not " if (grep {/foo|bar/} @cat) && ! (grep {/baz|quux/} @cat);
+ print "ok 2\n" ;
+}
-close $path;
+{# Test 3: that we open for append on second viewing
+ my @cat;
+ for my $path ( @files ){
+ cacheout $path;
+ print $path "$path 3\n";
+ }
+ for my $path ( @files ){
+ open($path, $path);
+ push @cat, do{ local $/; <$path>};
+ close($path);
+ }
+ print "not " unless scalar map({ /3$/ } @cat) == 4;
+ print "ok 3\n";
+}
-print "not " unless -f $path;
-print "ok 1\n";
-unlink $path;
+{# Test 4: that 2 arg format works
+ cacheout '+<', "foo";
+ print foo "foo 2\n";
+ close foo;
+ cacheout '<', "foo";
+ print "not " unless <foo> eq "foo 2\n";
+ print "ok 4\n";
+}
+
+{# Test 5: that close is overridden properly
+ cacheout local $_ = "Foo::Bar";
+ print $_ "Hello World\n";
+ close($_);
+ open($_, "+>$_");
+ print $_ "$_\n";
+ seek($_, 0, 0);
+ print "not " unless <$_> eq "$_\n";
+ print "ok 5\n";
+}
+
+q(
+{# Test close override
+ package Bob;
+ use FileCache;
+ cacheout local $_ = "Foo'Bar";
+ print $_ "Hello World\n";
+ close($_);
+ open($_, "+>$_");
+ print $_ "$_\n";
+ seek($_, 0, 0);
+ print "not " unless <$_> eq "$_\n";
+ print "ok 5\n";
+}
+);
+
+unlink @files, "Foo'Bar";
projects / p5sagit/p5-mst-13.2.git / commitdiff