libcache-cache-perl 1.08-2 / usr / share / perl5 / Cache / FileBackend.pm

######################################################################
# $Id: FileBackend.pm,v 1.27 2005/03/17 19:31:27 dclinton Exp $
# Copyright (C) 2001-2003 DeWitt Clinton  All Rights Reserved
#
# Software distributed under the License is distributed on an "AS
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
# implied. See the License for the specific language governing
# rights and limitations under the License.
######################################################################

package Cache::FileBackend;

use strict;
use Cache::CacheUtils qw( Assert_Defined Build_Path Freeze_Data Thaw_Data );
use Digest::SHA qw( sha1_hex );
use Error;
use File::Path qw( mkpath );
use File::Temp qw( tempfile );


# the file mode for new directories, which will be modified by the
# current umask

my $DIRECTORY_MODE = 0777;


# regex for untainting directory and file paths. since all paths are
# generated by us or come from user via API, a tautological regex
# suffices.

my $UNTAINTED_PATH_REGEX = '^(.*)$';


sub new
{
  my ( $proto, $p_root, $p_depth, $p_directory_umask ) = @_;
  my $class = ref( $proto ) || $proto;
  my $self  = {};
  $self = bless( $self, $class );
  $self->set_root( $p_root );
  $self->set_depth( $p_depth );
  $self->set_directory_umask( $p_directory_umask );
  return $self;
}


sub delete_key
{
  my ( $self, $p_namespace, $p_key ) = @_;

  Assert_Defined( $p_namespace );
  Assert_Defined( $p_key );

  _Remove_File( $self->_path_to_key( $p_namespace, $p_key ) );
}


sub delete_namespace
{
  my ( $self, $p_namespace ) = @_;

  Assert_Defined( $p_namespace );

  _Recursively_Remove_Directory( Build_Path( $self->get_root( ),
                                             $p_namespace ) );
}


sub get_keys
{
  my ( $self, $p_namespace ) = @_;

  Assert_Defined( $p_namespace );

  my @keys;

  foreach my $unique_key ( $self->_get_unique_keys( $p_namespace ) )
  {
    my $key = $self->_get_key_for_unique_key( $p_namespace, $unique_key ) or
      next;

    push( @keys, $key );
  }

  return @keys;

}


sub get_namespaces
{
  my ( $self ) = @_;

  my @namespaces;

  _List_Subdirectories( $self->get_root( ), \@namespaces );

  return @namespaces;
}


sub get_size
{
  my ( $self, $p_namespace, $p_key ) = @_;

  Assert_Defined( $p_namespace );
  Assert_Defined( $p_key );

  if ( -e $self->_path_to_key( $p_namespace, $p_key ) )
  {
    return -s $self->_path_to_key( $p_namespace, $p_key );

  }
  else
  {
    return 0;
  }
}


sub restore
{
  my ( $self, $p_namespace, $p_key ) = @_;

  Assert_Defined( $p_namespace );
  Assert_Defined( $p_key );

  return $self->_read_data( $self->_path_to_key($p_namespace, $p_key) )->[1];
}


sub store
{
  my ( $self, $p_namespace, $p_key, $p_data ) = @_;

  Assert_Defined( $p_namespace );
  Assert_Defined( $p_key );

  $self->_write_data( $self->_path_to_key( $p_namespace, $p_key ),
                      [ $p_key, $p_data ] );

}


sub get_depth
{
  my ( $self ) = @_;

  return $self->{_Depth};
}


sub set_depth
{
  my ( $self, $depth ) = @_;

  $self->{_Depth} = $depth;
}


sub get_root
{
  my ( $self ) = @_;

  return $self->{_Root};
}


sub set_root
{
  my ( $self, $root ) = @_;

  $self->{_Root} = $root;
}


sub get_directory_umask
{
  my ( $self ) = @_;

  return $self->{_Directory_Umask};
}


sub set_directory_umask
{
  my ( $self, $directory_umask ) = @_;

  $self->{_Directory_Umask} = $directory_umask;
}


# Take an human readable key, and create a unique key from it

sub _Build_Unique_Key
{
  my ( $p_key ) = @_;

  Assert_Defined( $p_key );

  return sha1_hex( $p_key );
}


# create a directory with optional mask, building subdirectories as
# needed.

sub _Create_Directory
{
  my ( $p_directory, $p_optional_new_umask ) = @_;

  Assert_Defined( $p_directory );

  my $old_umask = umask( ) if defined $p_optional_new_umask;

  umask( $p_optional_new_umask ) if defined $p_optional_new_umask;

  my $directory = _Untaint_Path( $p_directory );

  $directory =~ s|/$||;

  mkpath( $directory, 0, $DIRECTORY_MODE );

  -d $directory or
    throw Error::Simple( "Couldn't create directory: $directory: $!" );

  umask( $old_umask ) if defined $old_umask;
}



# list the names of the subdirectories in a given directory, without the
# full path

sub _List_Subdirectories
{
  my ( $p_directory, $p_subdirectories_ref ) = @_;

  foreach my $dirent ( _Read_Dirents( $p_directory ) )
  {
    next if $dirent eq '.' or $dirent eq '..';

    my $path = Build_Path( $p_directory, $dirent );

    next unless -d $path;

    push( @$p_subdirectories_ref, $dirent );
  }
}


# read the dirents from a directory

sub _Read_Dirents
{
  my ( $p_directory ) = @_;

  Assert_Defined( $p_directory );

  -d $p_directory or
    return ( );

  local *Dir;

  opendir( Dir, _Untaint_Path( $p_directory ) ) or
    throw Error::Simple( "Couldn't open directory $p_directory: $!" );

  my @dirents = readdir( Dir );

  closedir( Dir ) or
    throw Error::Simple( "Couldn't close directory $p_directory: $!" );

  return @dirents;
}


# read in a file. returns a reference to the data read

sub _Read_File
{
  my ( $p_path ) = @_;

  Assert_Defined( $p_path );

  local *File;

  open( File, _Untaint_Path( $p_path ) ) or
    return undef;

  binmode( File );

  local $/ = undef;

  my $data_ref;

  $$data_ref = <File>;

  close( File );

  return $data_ref;
}


# read in a file. returns a reference to the data read, without
# modifying the last accessed time

sub _Read_File_Without_Time_Modification
{
  my ( $p_path ) = @_;

  Assert_Defined( $p_path );

  -e $p_path or
    return undef;

  my ( $file_access_time, $file_modified_time ) =
    ( stat( _Untaint_Path( $p_path ) ) )[8,9];

  my $data_ref = _Read_File( $p_path );

  utime( $file_access_time, $file_modified_time, _Untaint_Path( $p_path ) );

  return $data_ref;
}


# remove a file

sub _Remove_File
{
  my ( $p_path ) = @_;

  Assert_Defined( $p_path );

  if ( -f _Untaint_Path( $p_path ) )
  {
    # We don't catch the error, because this may fail if two
    # processes are in a race and try to remove the object

    unlink( _Untaint_Path( $p_path ) );
  }
}


# remove a directory

sub _Remove_Directory
{
  my ( $p_directory ) = @_;

  Assert_Defined( $p_directory );

  if ( -d _Untaint_Path( $p_directory ) )
  {
    # We don't catch the error, because this may fail if two
    # processes are in a race and try to remove the object

    rmdir( _Untaint_Path( $p_directory ) );
  }
}


# recursively list the files of the subdirectories, without the full paths

sub _Recursively_List_Files
{
  my ( $p_directory, $p_files_ref ) = @_;

  return unless -d $p_directory;

  foreach my $dirent ( _Read_Dirents( $p_directory ) )
  {
    next if $dirent eq '.' or $dirent eq '..';

    my $path = Build_Path( $p_directory, $dirent );

    if ( -d $path )
    {
      _Recursively_List_Files( $path, $p_files_ref );
    }
    else
    {
      push( @$p_files_ref, $dirent );
    }
  }
}


# recursively list the files of the subdirectories, with the full paths

sub _Recursively_List_Files_With_Paths
{
  my ( $p_directory, $p_files_ref ) = @_;

  foreach my $dirent ( _Read_Dirents( $p_directory ) )
  {
    next if $dirent eq '.' or $dirent eq '..';

    my $path = Build_Path( $p_directory, $dirent );

    if ( -d $path )
    {
      _Recursively_List_Files_With_Paths( $path, $p_files_ref );
    }
    else
    {
      push( @$p_files_ref, $path );
    }
  }
}



# remove a directory and all subdirectories and files

sub _Recursively_Remove_Directory
{
  my ( $p_root ) = @_;

  return unless -d $p_root;

  foreach my $dirent ( _Read_Dirents( $p_root ) )
  {
    next if $dirent eq '.' or $dirent eq '..';

    my $path = Build_Path( $p_root, $dirent );

    if ( -d $path )
    {
      _Recursively_Remove_Directory( $path );
    }
    else
    {
      _Remove_File( _Untaint_Path( $path ) );
    }
  }

  _Remove_Directory( _Untaint_Path( $p_root ) );
}



# walk down a directory structure and total the size of the files
# contained therein.

sub _Recursive_Directory_Size
{
  my ( $p_directory ) = @_;

  Assert_Defined( $p_directory );

  return 0 unless -d $p_directory;

  my $size = 0;

  foreach my $dirent ( _Read_Dirents( $p_directory ) )
  {
    next if $dirent eq '.' or $dirent eq '..';

    my $path = Build_Path( $p_directory, $dirent );

    if ( -d $path )
    {
      $size += _Recursive_Directory_Size( $path );
    }
    else
    {
      $size += -s $path;
    }
  }

  return $size;
}


# Untaint a file path

sub _Untaint_Path
{
  my ( $p_path ) = @_;

  return _Untaint_String( $p_path, $UNTAINTED_PATH_REGEX );
}


# Untaint a string

sub _Untaint_String
{
  my ( $p_string, $p_untainted_regex ) = @_;

  Assert_Defined( $p_string );
  Assert_Defined( $p_untainted_regex );

  my ( $untainted_string ) = $p_string =~ /$p_untainted_regex/;

  if ( not defined $untainted_string || $untainted_string ne $p_string )
  {
    throw Error::Simple( "String $p_string contains possible taint" );
  }

  return $untainted_string;
}


# create a directory with the optional umask if it doesn't already
# exist

sub _Make_Path
{
  my ( $p_path, $p_optional_new_umask ) = @_;

  my ( $volume, $directory, $filename ) = File::Spec->splitpath( $p_path );

  if ( defined $directory and defined $volume )
  {
    $directory = File::Spec->catpath( $volume, $directory, "" );
  }

  if ( defined $directory and not -d $directory )
  {
    _Create_Directory( $directory, $p_optional_new_umask );
  }
}


# return a list of the first $depth letters in the $word

sub _Split_Word
{
  my ( $p_word, $p_depth ) = @_;

  Assert_Defined( $p_word );
  Assert_Defined( $p_depth );

  my @split_word_list;

  for ( my $i = 0; $i < $p_depth; $i++ )
  {
    push ( @split_word_list, substr( $p_word, $i, 1 ) );
  }

  return @split_word_list;
}


# write a file atomically

sub _Write_File
{
  my ( $p_path, $p_data_ref, $p_optional_mode, $p_optional_umask ) = @_;

  Assert_Defined( $p_path );
  Assert_Defined( $p_data_ref );

  my $old_umask = umask if $p_optional_umask;

  umask( $p_optional_umask ) if $p_optional_umask;

  my ( $volume, $directory, $filename ) = File::Spec->splitpath( $p_path );
 
  if ( defined $directory and defined $volume )
  {
    $directory = File::Spec->catpath( $volume, $directory, "" );
  }

  my ( $temp_fh, $temp_filename ) = tempfile( DIR => $directory );

  binmode( $temp_fh );

  print $temp_fh $$p_data_ref;

  close( $temp_fh );

  -e $temp_filename or
    throw Error::Simple( "Temp file '$temp_filename' does not exist: $!" );
  
  rename( $temp_filename, _Untaint_Path( $p_path ) ) or
    throw Error::Simple( "Couldn't rename $temp_filename to $p_path: $!" );

  if ( -e $temp_filename ) 
  {
    _Remove_File( $temp_filename );
    warn( "Temp file '$temp_filename' shouldn't still exist" );
  }

  $p_optional_mode ||= 0666 - umask( );

  chmod( $p_optional_mode, _Untaint_Path($p_path) );

  umask( $old_umask ) if $old_umask;
}


sub _get_key_for_unique_key
{
  my ( $self, $p_namespace, $p_unique_key ) = @_;

  return $self->_read_data( $self->_path_to_unique_key( $p_namespace,
                                                        $p_unique_key ) )->[0];
}


sub _get_unique_keys
{
  my ( $self, $p_namespace ) = @_;

  Assert_Defined( $p_namespace );

  my @unique_keys;

  _Recursively_List_Files( Build_Path( $self->get_root( ), $p_namespace ),
                           \@unique_keys );

  return @unique_keys;
}


sub _path_to_key
{
  my ( $self, $p_namespace, $p_key ) = @_;

  Assert_Defined( $p_namespace );
  Assert_Defined( $p_key );

  return $self->_path_to_unique_key( $p_namespace,
                                     _Build_Unique_Key( $p_key ) );
}


sub _path_to_unique_key
{
  my ( $self, $p_namespace, $p_unique_key ) = @_;

  Assert_Defined( $p_unique_key );
  Assert_Defined( $p_namespace );

  return Build_Path( $self->get_root( ),
                     $p_namespace,
                     _Split_Word( $p_unique_key, $self->get_depth( ) ),
                     $p_unique_key );
}

# the data is returned as reference to an array ( key, data )

sub _read_data
{
  my ( $self, $p_path ) = @_;

  Assert_Defined( $p_path );

  my $frozen_data_ref = _Read_File_Without_Time_Modification( $p_path ) or
    return [ undef, undef ];

  my $data_ref = eval{ Thaw_Data( $$frozen_data_ref ) };
  
  if ( $@ || ( ref( $data_ref ) ne 'ARRAY' ) ) 
  {
    unlink _Untaint_Path( $p_path );
    return [ undef, undef ];
  }
  else
  {
    return $data_ref;
  }
}


# the data is passed as reference to an array ( key, data )

sub _write_data
{
  my ( $self, $p_path, $p_data ) = @_;

  Assert_Defined( $p_path );
  Assert_Defined( $p_data );

  _Make_Path( $p_path, $self->get_directory_umask( ) );

  my $frozen_file = Freeze_Data( $p_data );

  _Write_File( $p_path, \$frozen_file );
}


1;


__END__

=pod

=head1 NAME

Cache::FileBackend -- a filesystem based persistence mechanism

=head1 DESCRIPTION

The FileBackend class is used to persist data to the filesystem

=head1 SYNOPSIS

  my $backend = new Cache::FileBackend( '/tmp/FileCache', 3, 000 );

  See Cache::Backend for the usage synopsis.

  $backend->store( 'namespace', 'foo', 'bar' );

  my $bar = $backend->restore( 'namespace', 'foo' );

  my $size_of_bar = $backend->get_size( 'namespace', 'foo' );

  foreach my $key ( $backend->get_keys( 'namespace' ) )
  {
    $backend->delete_key( 'namespace', $key );
  }

  foreach my $namespace ( $backend->get_namespaces( ) )
  {
    $backend->delete_namespace( $namespace );
  }

=head1 METHODS

See Cache::Backend for the API documentation.

=over

=item B<new( $root, $depth, $directory_umask )>

Construct a new FileBackend that writes data to the I<$root>
directory, automatically creates subdirectories I<$depth> levels deep,
and uses the umask of I<$directory_umask> when creating directories.

=back

=head1 PROPERTIES

=over

=item B<(get|set)_root>

The location of the parent directory in which to store the files

=item B<(get|set)_depth>

The branching factor of the subdirectories created to store the files

=item B<(get|set)_directory_umask>

The umask to be used when creating directories

=back

=head1 SEE ALSO

Cache::Backend, Cache::MemoryBackend, Cache::SharedMemoryBackend

=head1 AUTHOR

Original author: DeWitt Clinton <dewitt@unto.net>

Last author:     $Author: dclinton $

Copyright (C) 2001-2003 DeWitt Clinton

=cut