view release on metacpan or  search on metacpan

Cache.pm  view on Meta::CPAN

@EXPORT_OK = qw($sSUCCESS $sFAILURE $sTRUE $sFALSE $sEXPIRES_NOW
		$sEXPIRES_NEVER $sNO_MAX_SIZE );

# -----------------------------------------------------------------------------

# Code notes:
# Internal subroutines (helper routines not supposed to be called by
# external clients) are preceded with an underscore ("_"). Subroutines
# (both internal and external) that are called as functions, as
# opposed to methods, are in ALL CAPS. The PURGE and CLEAR routines
# are object-independent, which means that any subroutines they call
# must also be object-independent.

# -----------------------------------------------------------------------------

# Constants

$sSUCCESS = 1;
$sFAILURE = 0;

$sTRUE = 1;
$sFALSE = 0;

$sEXPIRES_NOW = 0;
$sEXPIRES_NEVER = -1;

$sNO_MAX_SIZE = -1;

$sGET_STALE_ONLY = 1;
$sGET_FRESH_ONLY = 0;

# The default cache key is used inside the tmp filesystem (as defined
# by File::Spec)

my $sDEFAULT_CACHE_KEY;

$sDEFAULT_CACHE_KEY = ($^O eq 'dos' || $^O eq 'MSWin32') ?
  'FileCache' : 'File::Cache';


# if a namespace is not specified, use this as a default

my $sDEFAULT_NAMESPACE = "_default";


# by default, remove objects that have expired when then are requested

my $sDEFAULT_AUTO_REMOVE_STALE = $sTRUE;


# by default, the filemode is world read/writable

my $sDEFAULT_FILEMODE = 0777;


# by default, there is no max size to the cache

my $sDEFAULT_MAX_SIZE = $sNO_MAX_SIZE;


# if the OS does not support getpwuid, use this as a default username

my $sDEFAULT_USERNAME = 'nobody';


# by default, the objects in the cache never expire

my $sDEFAULT_GLOBAL_EXPIRES_IN = $sEXPIRES_NEVER;


# default cache depth

my $sDEFAULT_CACHE_DEPTH = 0;


# File::Cache supports either Storable or Data::Dumper as the
# persistence mechanism. The default persistence mechanism uses Storable

my $sDEFAULT_PERSISTENCE_MECHANISM = 'Storable';



# cache description filename

my $sCACHE_DESCRIPTION_FILENAME = '.description';


# Always use a global friendly umask for the .description files

my $sCACHE_DESCRIPTION_UMASK = 022;


# valid filepath characters for tainting. Be sure to accept DOS/Windows style
# path specifiers (C:\path) also

my $sUNTAINTED_FILE_PATH_REGEX = qr{^([-\@\w\\\\~./:]+|[\w]:[-\@\w\\\\~./]+)$};



# -----------------------------------------------------------------------------

# create a new Cache object that can be used to persist
# data across processes

sub new
{
    my ($proto, $options) = @_;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);


    # remove objects from the cache that have expired on retrieval
    # when this is set

    my $auto_remove_stale = defined $options->{auto_remove_stale} ?
	$options->{auto_remove_stale} : $sDEFAULT_AUTO_REMOVE_STALE;

    $self->set_auto_remove_stale($auto_remove_stale);

Cache.pm  view on Meta::CPAN

    return 0 unless -e $cache_key;

    return _RECURSIVE_DIRECTORY_SIZE($cache_key);
}

# -----------------------------------------------------------------------------

# walk down a directory structure and total the size of the files
# contained therein. Doesn't count the size of the cache description
# file

sub _RECURSIVE_DIRECTORY_SIZE
{
    my ($directory) = @_;

    defined($directory) or
	croak("directory required");

    my $size = 0;

    $directory = _UNTAINT_FILE_PATH($directory);

    opendir(DIR, $directory) or
	croak("Couldn't open directory $directory: $!");

    my @dirents = readdir(DIR);

    foreach my $dirent (@dirents) {

	next if $dirent eq '.' or $dirent eq '..';

	my $path = _BUILD_PATH($directory, $dirent);

	if (-d $path) {
	    $size += _RECURSIVE_DIRECTORY_SIZE($path);
	} else {
      # Don't count the cache description file
	    $size += -s $path if $dirent ne $sCACHE_DESCRIPTION_FILENAME;
	}

    }

    closedir(DIR);

    return $size;
}

# -----------------------------------------------------------------------------

# Find the username of the person running the process in an OS
# independent way

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

    my $username;

    my $success = eval {
	my $effective_uid = $>;
	$username = getpwuid($effective_uid);	
    };

    if ($success and $username) {
	return $username;
    } else {
	return $sDEFAULT_USERNAME;
    }
}

# -----------------------------------------------------------------------------


# Untaint a path to a file

sub _UNTAINT_FILE_PATH
{
    my ($file_path) = @_;

    return _UNTAINT_STRING($file_path, $sUNTAINTED_FILE_PATH_REGEX);
}



# Untaint a string

sub _UNTAINT_STRING
{
    my ($string, $untainted_regex) = @_;

    defined($untainted_regex) or
	croak("untainted regex required");

    defined($string) or
	croak("string required");

    my ($untainted_string) = $string =~ /$untainted_regex/;

    if (!defined $untainted_string || $untainted_string ne $string) {
	warn("String $string contains possible taint");
    }

    return $untainted_string;
}


# -----------------------------------------------------------------------------

# Returns the default root of the cache under the OS dependent temp dir

sub _BUILD_DEFAULT_CACHE_KEY
{
    my $tmpdir = tmpdir() or
	croak("No tmpdir on this system.  Bugs to the authors of File::Spec");

    my $default_cache_key = _BUILD_PATH($tmpdir, $sDEFAULT_CACHE_KEY);

    return $default_cache_key;
}