From: Jarkko Hietaniemi Date: Mon, 15 Apr 2002 14:19:27 +0000 (+0000) Subject: FileCache 1.02, from Jerrad Pierce . X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c14fc35a124901bb0a7c6981001dbcf00006611d;p=p5sagit%2Fp5-mst-13.2.git FileCache 1.02, from Jerrad Pierce . p4raw-id: //depot/perl@15927 --- diff --git a/lib/FileCache.pm b/lib/FileCache.pm index 2cfa91e..2f8f1a6 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 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 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 lies with its C 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 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 () { + $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 () { - $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; } diff --git a/lib/FileCache.t b/lib/FileCache.t index a97fdd5..9e28270 100755 --- a/lib/FileCache.t +++ b/lib/FileCache.t @@ -5,21 +5,84 @@ BEGIN { @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 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";