diff options
Diffstat (limited to 'lib/Class/MakeMethods/Utility/DiskCache.pm')
| -rw-r--r-- | lib/Class/MakeMethods/Utility/DiskCache.pm | 165 |
1 files changed, 165 insertions, 0 deletions
diff --git a/lib/Class/MakeMethods/Utility/DiskCache.pm b/lib/Class/MakeMethods/Utility/DiskCache.pm new file mode 100644 index 0000000..653303c --- /dev/null +++ b/lib/Class/MakeMethods/Utility/DiskCache.pm @@ -0,0 +1,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
\ No newline at end of file |