perl/lib/FileCache.pm

package FileCache;

our $VERSION = '1.05';

=head1 NAME

FileCache - keep more files open than the system permits

=head1 SYNOPSIS

    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.

=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.

=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 Config;
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);
  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;
Revision:	1.1
Committed:	Thu Jun 30 14:27:08 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package FileCache;
2
3			our $VERSION = '1.05';
4
5			=head1 NAME
6
7			FileCache - keep more files open than the system permits
8
9			=head1 SYNOPSIS
10
11			use FileCache;
12			# or
13			use FileCache maxopen => 16;
14
15			cacheout $mode, $path;
16			# or
17			cacheout $path;
18			print $path @data;
19
20			$fh = cacheout $mode, $path;
21			# or
22			$fh = cacheout $path;
23			print $fh @data;
24
25			=head1 DESCRIPTION
26
27			The C<cacheout> function will make sure that there's a filehandle open
28			for reading or writing available as the pathname you give it. It
29			automatically closes and re-opens files if you exceed your system's
30			maximum number of file descriptors, or the suggested maximum I<maxopen>.
31
32			=over
33
34			=item cacheout EXPR
35
36			The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
37			on it's first use, and appending (C<<< '>>' >>>) thereafter.
38
39			Returns EXPR on success for convenience. You may neglect the
40			return value and manipulate EXPR as the filehandle directly if you prefer.
41
42			=item cacheout MODE, EXPR
43
44			The 2-argument form of cacheout will use the supplied mode for the initial
45			and subsequent openings. Most valid modes for 3-argument C<open> are supported
46			namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
47			C< '\|-' > and C< '-\|' >
48
49			To pass supplemental arguments to a program opened with C< '\|-' > or C< '-\|' >
50			append them to the command string as you would system EXPR.
51
52			Returns EXPR on success for convenience. You may neglect the
53			return value and manipulate EXPR as the filehandle directly if you prefer.
54
55			=head1 CAVEATS
56
57			While it is permissible to C<close> a FileCache managed file,
58			do not do so if you are calling C<FileCache::cacheout> from a package other
59			than which it was imported, or with another module which overrides C<close>.
60			If you must, use C<FileCache::cacheout_close>.
61
62			Although FileCache can be used with piped opens ('-\|' or '\|-') doing so is
63			strongly discouraged. If FileCache finds it necessary to close and then reopen
64			a pipe, the command at the far end of the pipe will be reexecuted - the results
65			of performing IO on FileCache'd pipes is unlikely to be what you expect. The
66			ability to use FileCache on pipes may be removed in a future release.
67
68			FileCache does not store the current file offset if it finds it necessary to
69			close a file. When the file is reopened, the offset will be as specified by the
70			original C<open> file mode. This could be construed to be a bug.
71
72			=head1 BUGS
73
74			F<sys/param.h> lies with its C<NOFILE> define on some systems,
75			so you may have to set I<maxopen> yourself.
76
77			=cut
78
79			require 5.006;
80			use Carp;
81			use Config;
82			use strict;
83			no strict 'refs';
84
85			# These are not C<my> for legacy reasons.
86			# Previous versions requested the user set $cacheout_maxopen by hand.
87			# Some authors fiddled with %saw to overcome the clobber on initial open.
88			use vars qw(%saw $cacheout_maxopen);
89			$cacheout_maxopen = 16;
90
91			use base 'Exporter';
92			our @EXPORT = qw[cacheout cacheout_close];
93
94
95			my %isopen;
96			my $cacheout_seq = 0;
97
98			sub import {
99			my ($pkg,%args) = @_;
100
101			# Use Exporter. %args are for us, not Exporter.
102			# Make sure to up export_to_level, or we will import into ourselves,
103			# rather than our calling package;
104
105			__PACKAGE__->export_to_level(1);
106			Exporter::import( $pkg );
107
108			# Truth is okay here because setting maxopen to 0 would be bad
109			return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
110
111			# XXX This code is crazy. Why is it a one element foreach loop?
112			# Why is it using $param both as a filename and filehandle?
113			foreach my $param ( '/usr/include/sys/param.h' ){
114			if (open($param, '<', $param)) {
115			local ($_, $.);
116			while (<$param>) {
117			if( /^\s#\sdefine\s+NOFILE\s+(\d+)/ ){
118			$cacheout_maxopen = $1 - 4;
119			close($param);
120			last;
121			}
122			}
123			close $param;
124			}
125			}
126			$cacheout_maxopen \|\|= 16;
127			}
128
129			# Open in their package.
130			sub cacheout_open {
131			return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
132			}
133
134			# Close in their package.
135			sub cacheout_close {
136			# Short-circuit in case the filehandle disappeared
137			my $pkg = caller($_[1]\|\|0);
138			fileno(*{$pkg . '::' . $_[0]}) &&
139			CORE::close(*{$pkg . '::' . $_[0]});
140			delete $isopen{$_[0]};
141			}
142
143			# But only this sub name is visible to them.
144			sub cacheout {
145			my($mode, $file, $class, $ret, $ref, $narg);
146			croak "Not enough arguments for cacheout" unless $narg = scalar @_;
147			croak "Too many arguments for cacheout" if $narg > 2;
148
149			($mode, $file) = @_;
150			($file, $mode) = ($mode, $file) if $narg == 1;
151			croak "Invalid mode for cacheout" if $mode &&
152			( $mode !~ /^\s(?:>>\|\+?>\|\+?<\|\\|\-\|)\|\-\\|\s$/ );
153
154			# Mode changed?
155			if( $isopen{$file} && ($mode\|\|'>') ne $isopen{$file}->[1] ){
156			&cacheout_close($file, 1);
157			}
158
159			if( $isopen{$file}) {
160			$ret = $file;
161			$isopen{$file}->[0]++;
162			}
163			else{
164			if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
165			my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
166			$cacheout_seq = 0;
167			$isopen{$_}->[0] = $cacheout_seq++ for
168			splice(@lru, int($cacheout_maxopen / 3)\|\|$cacheout_maxopen);
169			&cacheout_close($_, 1) for @lru;
170			}
171
172			unless( $ref ){
173			$mode \|\|= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
174			}
175			#XXX should we just return the value from cacheout_open, no croak?
176			$ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
177
178			$isopen{$file} = [++$cacheout_seq, $mode];
179			}
180			return $ret;
181			}
182			1;