Move FileCache from lib to ext

At the same time, remove PERL_CORE logic from tests and convert tests to
use Test::More instead of t/test.pl.

9 files changed, 369 insertions, 0 deletions

diff --git a/ext/.gitignore b/ext/.gitignore
index 775a62b059..78b4a02d3e 100644
--- a/ext/.gitignore
+++ b/ext/.gitignore
@@ -20,6 +20,7 @@ ppport.h
 /B-Deparse/Makefile.PL
 /B-Lint/Makefile.PL
 /Data-Dumper/Makefile.PL
+/FileCache/Makefile.PL
 /File-Fetch/Makefile.PL
 /Filter-Simple/Makefile.PL
 /Filter-Util-Call/Makefile.PL
diff --git a/ext/FileCache/lib/FileCache.pm b/ext/FileCache/lib/FileCache.pm
new file mode 100644
index 0000000000..09583b04af
--- /dev/null
+++ b/ext/FileCache/lib/FileCache.pm
@@ -0,0 +1,188 @@
+package FileCache;
+
+our $VERSION = '1.08';
+
+=head1 NAME
+
+FileCache - keep more files open than the system permits
+
+=head1 SYNOPSIS
+
+    no strict 'refs';
+
+    use FileCache;
+    # or
+    use FileCache maxopen => 16;
+
+    cacheout $mode, $path;
+    # or
+    cacheout $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 I<maxopen>.
+
+=over
+
+=item cacheout EXPR
+
+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
+and subsequent openings. Most valid modes for 3-argument C<open> are supported
+namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
+C< '|-' > and C< '-|' >
+
+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.
+
+=back
+
+=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
+than which it was imported, or with another module which overrides C<close>.
+If you must, use C<FileCache::cacheout_close>.
+
+Although FileCache can be used with piped opens ('-|' or '|-') doing so is
+strongly discouraged.  If FileCache finds it necessary to close and then reopen
+a pipe, the command at the far end of the pipe will be reexecuted - the results
+of performing IO on FileCache'd pipes is unlikely to be what you expect.  The
+ability to use FileCache on pipes may be removed in a future release.
+
+FileCache does not store the current file offset if it finds it necessary to
+close a file.  When the file is reopened, the offset will be as specified by the
+original C<open> file mode.  This could be construed to be a bug.
+
+The module functionality relies on symbolic references, so things will break
+under 'use strict' unless 'no strict "refs"' is also specified.
+
+=head1 BUGS
+
+F<sys/param.h> lies with its C<NOFILE> define on some systems,
+so you may have to set I<maxopen> yourself.
+
+=cut
+
+require 5.006;
+use Carp;
+use strict;
+no strict 'refs';
+
+# 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);
+$cacheout_maxopen = 16;
+
+use base 'Exporter';
+our @EXPORT = qw[cacheout cacheout_close];
+
+
+my %isopen;
+my $cacheout_seq = 0;
+
+sub import {
+    my ($pkg,%args) = @_;
+
+    # Use Exporter. %args are for us, not Exporter.
+    # Make sure to up export_to_level, or we will import into ourselves,
+    # rather than our calling package;
+
+    __PACKAGE__->export_to_level(1);
+    Exporter::import( $pkg );
+
+    # Truth is okay here because setting maxopen to 0 would be bad
+    return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
+
+    # XXX This code is crazy.  Why is it a one element foreach loop?
+    # Why is it using $param both as a filename and filehandle?
+    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;
+      }
+    }
+    $cacheout_maxopen ||= 16;
+}
+
+# Open in their package.
+sub cacheout_open {
+  return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
+}
+
+# Close in their package.
+sub cacheout_close {
+  # Short-circuit in case the filehandle disappeared
+  my $pkg = caller($_[1]||0);
+  defined fileno(*{$pkg . '::' . $_[0]}) &&
+    CORE::close(*{$pkg . '::' . $_[0]});
+  delete $isopen{$_[0]};
+}
+
+# But only this sub name is visible to them.
+sub cacheout {
+    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 changed?
+    if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
+      &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}->[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;
+      }
+
+      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];
+    }
+    return $ret;
+}
+1;
diff --git a/ext/FileCache/t/01open.t b/ext/FileCache/t/01open.t
new file mode 100644
index 0000000000..07e01bac86
--- /dev/null
+++ b/ext/FileCache/t/01open.t
@@ -0,0 +1,18 @@
+#!./perl
+
+use FileCache;
+
+use vars qw(@files);
+BEGIN { @files = qw(foo bar baz quux Foo_Bar) }
+END   { 1 while unlink @files }
+
+use Test::More tests => 1;
+
+{# Test 1: that we can open files
+     for my $path ( @files ){
+	 cacheout $path;
+	 print $path "$path 1\n";
+	 close $path;
+     }
+     ok(scalar(map { -f } @files) == scalar(@files));
+}
diff --git a/ext/FileCache/t/02maxopen.t b/ext/FileCache/t/02maxopen.t
new file mode 100644
index 0000000000..c95ba73bca
--- /dev/null
+++ b/ext/FileCache/t/02maxopen.t
@@ -0,0 +1,28 @@
+#!./perl
+
+use FileCache maxopen => 2;
+use vars qw(@files);
+BEGIN { @files = qw(foo bar baz quux) }
+END { 1 while unlink @files }
+
+use Test::More tests => 5;
+
+{# Test 2: that we actually adhere to maxopen
+  for my $path ( @files ){
+    cacheout $path;
+    print $path "$path 1\n";
+  }
+  
+  my @cat;
+  for my $path ( @files ){
+    ok(fileno($path) || $path =~ /^(?:foo|bar)$/);
+    next unless fileno($path);
+    print $path "$path 2\n";
+    close($path);
+    open($path, $path);
+    <$path>;
+    push @cat, <$path>;
+    close($path);
+  }
+  ok( grep(/^(?:baz|quux) 2$/, @cat) == 2 );
+}
diff --git a/ext/FileCache/t/03append.t b/ext/FileCache/t/03append.t
new file mode 100644
index 0000000000..f765d445ce
--- /dev/null
+++ b/ext/FileCache/t/03append.t
@@ -0,0 +1,39 @@
+#!./perl
+
+use FileCache maxopen => 2;
+use vars qw(@files);
+BEGIN { @files = qw(foo bar baz quux Foo_Bar) }
+END   { 1 while unlink @files }
+
+use Test::More tests => 2;
+
+{# 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 ){
+	 cacheout $path;
+	 print $path "$path 33\n";
+     }
+     for my $path ( @files ){
+	 open($path, '<', $path);
+	 push @cat, do{ local $/; <$path>};
+         close($path);
+     }
+
+     ok(scalar(grep/\b3$/m, @cat) == scalar(@files));
+
+     @cat = ();
+     for my $path ( @files ){
+	 cacheout $path;
+	 print $path "$path 333\n";
+     }
+     for my $path ( @files ){
+	 open($path, '<', $path);
+	 push @cat, do{ local $/; <$path>};
+         close($path);
+     }
+     ok(scalar(grep /\b33$/m, @cat) == scalar(@files));
+}
diff --git a/ext/FileCache/t/04twoarg.t b/ext/FileCache/t/04twoarg.t
new file mode 100644
index 0000000000..0189c46547
--- /dev/null
+++ b/ext/FileCache/t/04twoarg.t
@@ -0,0 +1,17 @@
+#!./perl
+
+use FileCache;
+
+END { unlink('foo') }
+
+use Test::More tests => 1;
+
+{# Test 4: that 2 arg format works, and that we cycle on mode change
+     cacheout '>', "foo";
+     print foo "foo 4\n";
+     cacheout '+>', "foo";
+     print foo "foo 44\n";
+     seek(foo, 0, 0);
+     ok(<foo> eq "foo 44\n");
+     close foo;
+}
diff --git a/ext/FileCache/t/05override.t b/ext/FileCache/t/05override.t
new file mode 100644
index 0000000000..7edd5a39b7
--- /dev/null
+++ b/ext/FileCache/t/05override.t
@@ -0,0 +1,14 @@
+#!./perl
+
+use FileCache;
+
+END { unlink("Foo_Bar") }
+
+use Test::More tests => 1;
+
+{# Test 5: that close is overridden properly within the caller
+     cacheout local $_ = "Foo_Bar";
+     print $_ "Hello World\n";
+     close($_);
+     ok(!fileno($_));
+}
diff --git a/ext/FileCache/t/06export.t b/ext/FileCache/t/06export.t
new file mode 100644
index 0000000000..0fafe3bcd6
--- /dev/null
+++ b/ext/FileCache/t/06export.t
@@ -0,0 +1,44 @@
+#!./perl
+use vars qw(@funcs $i);
+
+BEGIN {
+    # Functions exported by FileCache;
+    @funcs  = qw[cacheout cacheout_close];
+    $i      = 0;
+}
+
+use Test::More tests => 8;
+
+# Test 6: Test that exporting both works to package main and
+# other packages. Now using Exporter.
+
+# First, we shouldn't be able to have these in our namespace
+# Add them to BEGIN so the later 'use' doesn't influence this
+# test
+BEGIN {   
+    ok(not __PACKAGE__->can($_)) foreach @funcs;
+}
+
+# With an empty import list, we also shouldn't have them in
+# our namespace.
+# Add them to BEGIN so the later 'use' doesn't influence this
+# test
+BEGIN {   
+    use FileCache ();
+    ok(not __PACKAGE__->can($_)) foreach @funcs;
+}
+
+
+# Now, we use FileCache in 'main'
+{
+    use FileCache;
+    ok(__PACKAGE__->can($_)) foreach @funcs;
+}
+
+# Now we use them in another package
+{
+    package X;
+    use FileCache;
+    ::ok(__PACKAGE__->can($_)) foreach @main::funcs;
+}
+
diff --git a/ext/FileCache/t/07noimport.t b/ext/FileCache/t/07noimport.t
new file mode 100644
index 0000000000..0de92fe80a
--- /dev/null
+++ b/ext/FileCache/t/07noimport.t
@@ -0,0 +1,20 @@
+#!./perl -w
+
+use Test::More tests => 1;
+
+# Try using FileCache without importing to make sure everything's 
+# initialized without it.
+{
+    package Y;
+    use FileCache ();
+
+    my $file = 'foo';
+    END { unlink $file }
+    FileCache::cacheout($file);
+    print $file "bar";
+    close $file;
+
+    FileCache::cacheout("<", $file);
+    ::ok( <$file> eq "bar" );
+    close $file;
+}