Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
File	[ DIR ]	drwxr-xr-x
Memory	[ DIR ]	drwxr-xr-x
Null	[ DIR ]	drwxr-xr-x
RemovalStrategy	[ DIR ]	drwxr-xr-x
BaseCache.pm	14.73 KB	-rw-r--r--
BaseCacheTester.pm	2.76 KB	-rw-r--r--
Cache.pm	8.22 KB	-rw-r--r--
CacheMetaData.pm	5.73 KB	-rw-r--r--
CacheSizer.pm	3.94 KB	-rw-r--r--
CacheTester.pm	13.05 KB	-rw-r--r--
CacheUtils.pm	2.85 KB	-rw-r--r--
Entry.pm	8.37 KB	-rw-r--r--
File.pm	16.72 KB	-rw-r--r--
FileBackend.pm	14.06 KB	-rw-r--r--
FileCache.pm	7.17 KB	-rw-r--r--
IOString.pm	3.24 KB	-rw-r--r--
Memory.pm	9.64 KB	-rw-r--r--
MemoryBackend.pm	2.57 KB	-rw-r--r--
MemoryCache.pm	2.76 KB	-rw-r--r--
Null.pm	2.27 KB	-rw-r--r--
NullCache.pm	2.21 KB	-rw-r--r--
Object.pm	3.4 KB	-rw-r--r--
RemovalStrategy.pm	1.03 KB	-rw-r--r--
SharedMemoryBackend.pm	4.72 KB	-rw-r--r--
SharedMemoryCache.pm	3.4 KB	-rw-r--r--
SizeAwareCache.pm	3.04 KB	-rw-r--r--
SizeAwareCacheTester.pm	5.66 KB	-rw-r--r--
SizeAwareFileCache.pm	3.68 KB	-rw-r--r--
SizeAwareMemoryCache.pm	3.35 KB	-rw-r--r--
SizeAwareSharedMemoryCache.pm	2.55 KB	-rw-r--r--
Tester.pm	13.44 KB	-rw-r--r--

Code Editor : 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 );
}

__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 $

=cut

${this.title}

Code Editor : FileBackend.pm