/usr/share/perl5/Class/MakeMethods/Utility/DiskCache.pm is in libclass-makemethods-perl 1.01-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | package Class::MakeMethods::Utility::DiskCache;
$VERSION = 1.008;
@EXPORT_OK = qw( disk_cache );
sub import { require Exporter and goto &Exporter::import } # lazy Exporter
use strict;
use Carp;
use File::Spec;
use File::Path;
########################################################################
use vars qw( $DiskCacheDir );
my $IndexFile = "methods.ix"; # file also serves as timestamp
my $FileEnding = ".mm";
sub import {
my $package = shift;
if ( scalar @_ ) {
$DiskCacheDir = shift;
}
}
########################################################################
my %HaveCheckedFreshness;
# $result = disk_cache( $package, $file, $sub, @args );
sub disk_cache {
my ( $full_funct, $args_string, $function, @args ) = @_;
unless ( $DiskCacheDir and -e $DiskCacheDir ) {
return &$function( @args );
}
my ($package, $func_name) = ( $full_funct =~ /^(.+)::(\w+)$/ );
my $pack_dir = File::Spec->catdir( $DiskCacheDir, split /::/, $package );
if ( ! -e $pack_dir and -w $DiskCacheDir ) {
mkpath($pack_dir, 0, 07777);
}
unless ( defined $HaveCheckedFreshness{$package} ) {
my $idx = File::Spec->catfile( $pack_dir, $IndexFile );
my $signature = dependency_signature($package);
if ( -e $idx and read_file( $idx ) eq $signature ) {
$HaveCheckedFreshness{$package} = 1;
} else {
if ( ! -w $pack_dir ) {
# The index is out of date, but not writable -- abandon it
$HaveCheckedFreshness{ $package } = 0;
} else {
rmtree($pack_dir, 0, 1);
mkpath($pack_dir, 0, 07777);
write_file( $idx, $signature );
$HaveCheckedFreshness{$package} = 1;
}
}
}
unless ( $HaveCheckedFreshness{$package} ) {
return &$function( @args );
}
my $func_dir = File::Spec->catdir( $pack_dir, $func_name );
if ( ! -e $func_dir and -w $pack_dir ) {
mkpath($func_dir, 0, 07777);
}
my $file = File::Spec->catfile( $func_dir, $args_string . $FileEnding );
if ( -e $file ) {
return read_file( $file );
}
my $value = ( &$function( @args ) );
if ( -e $func_dir and -w $func_dir ) {
write_file( $file, $value );
} else {
warn "Can't cache: $file\n";
}
return $value;
}
########################################################################
sub dependency_signature {
my @sources = shift;
my @results;
no strict 'refs';
while ( my $class = shift @sources ) {
push @sources, @{"$class\::ISA"};
push @results, $class unless ( grep { $_ eq $class } @results );
}
foreach ( @results ) {
s!::!/!g;
$_ .= '.pm';
}
return join "\n", map { $_ . ' '. (stat($::INC{ $_ }))[9] } @results;
}
########################################################################
sub read_file {
my $file = shift;
# warn "Reading file: $file\n";
local *FILE;
open FILE, "$file" or die "Can't open $file: $!";
local $/ = undef;
return <FILE>;
}
sub write_file {
my $file = shift;
# warn "Writing file: $file \n";
local *FILE;
open FILE, ">$file" or die "Can't write to $file: $!";
print FILE shift();
}
sub read_dir {
my $dir = shift;
local *DIR;
opendir(DIR, $dir);
readdir(DIR);
}
########################################################################
1;
__END__
=head1 NAME
Class::MakeMethods::Utility::DiskCache - Optional Template feature
=head1 SYNOPSIS
use Class::MakeMethods::Utility::DiskCache qw( /my/code/dir );
=head1 DESCRIPTION
To enable disk caching of Class::MakeMethods::Template generated
code, create an empty directory and pass it to the DiskCache package:
use Class::MakeMethods::Utility::DiskCache qw( /my/code/dir );
This has a mixed effect on performance, but has the notable advantage of letting you view the subroutines that are being generated by your templates.
=head1 SEE ALSO
See L<Class::MakeMethods::Template> for more information.
=cut
|