package Bric::App::Cache; =head1 NAME Bric::App::Cache - Object for managing Application-wide global data. =head1 VERSION $LastChangedRevision$ =cut # Grab the Version Number. require Bric; our $VERSION = Bric->VERSION; =head1 DATE $LastChangedDate: 2006-03-18 01:26:34 +0100 (Sat, 18 Mar 2006) $ =head1 SYNOPSIS use Bric::App::Cache; my $c = Bric::App::Cache->new; $c = $c->set($key, $val); my $val = $c->get($key); my $time = $c->get_lmu_time; $c = $c->set_lmu_time; my $site_id = $c->get_user_cx($user_id); $c = $c->set_user_cx($user_id, $site_id); =head1 DESCRIPTION This module provides a cache object to cache data that needs to persist across all processes and across all requests, through time and space. The cache is cleared on server restart - for more permenant storage see L. A Bric::App::Cache object is available from Mason components in the global variable C<$c>. =head1 IMPLEMENTATION This module is implemented as a two-level cache in order to provide the best possible performance. The first level is provided by Cache::Mmap. Cache::Mmap is a very fast, shared, file-based cache. However, it is also a fixed-size cache that will drop items from the cache when the cache becomes full or the item to be stored is too large. When an object cannot be stored in the first-level cache it is passed to the second-level. The second-level cache (also known as a backing store) is provided by Cache::Cache. Cache::Cache is quite a bit slower than Cache::Mmap but has the advantage of being variable-sized. As such it grows dynamically and won't refuse to store an object unless it runs out of disk space. The C procedure is: =over 4 =item * Look in first-level cache for item. If found, return it and finish. =item * Look in second-level cache for item. If found, return it and finish. =item * Note in first-level cache that item is not in second-level cache. This will prevent a look in the second-level cache on the next request for this item. =back And the C prodedure is: =over 4 =item * Try to set the item in the first-level cache. If success, finish. If fail, delete old item if it exists. =item * Set the item in the second-level cache. This must succeed or a fatal error will result. =back NOTE: Under C all Cs are sent to the secondary-cache to allow the cache to be debugged. Cache::Mmap lacks the ability to list all keys in the cache which is used by the C code. =cut ############################################################################## # Dependencies ############################################################################## # Standard Dependencies use strict; ############################################################################## # Programmatic Dependences use Bric::Util::Fault qw(throw_dp throw_gen throw_da throw_mni); use Bric::Util::Fault::Exception::GEN; use Bric::Util::Trans::FS; use Cache::Mmap; use Cache::FileCache; use Bric::Config qw(TEMP_DIR SYS_USER SYS_GROUP QA_MODE); use File::Path qw(mkpath rmtree); ############################################################################## # Inheritance ############################################################################## ############################################################################## # Function and Closure Prototypes ############################################################################## ############################################################################## # Constants ############################################################################## use constant CACHE_ROOT => Bric::Util::Trans::FS->cat_dir(TEMP_DIR, 'bricolage', 'cache'); use constant CACHE_MMAP => Bric::Util::Trans::FS->cat_file(CACHE_ROOT, 'mmap'); unless (-d CACHE_ROOT) { mkpath(CACHE_ROOT, 0, 0777); # Let the Apache user own it unless $ENV{BRIC_TEMP_DIR} is set, in which # case we're running tests and want to keep the current user as owner. chown SYS_USER, SYS_GROUP, CACHE_ROOT unless $ENV{BRIC_TEMP_DIR}; } # these could be made into bricolage.conf directives if we decide people will # want to change them. These values yeild a maximum cache size of 40MB. See # the Cache::Mmap docs for details. use constant CACHE_MMAP_BUCKETS => 10 * 1024; use constant CACHE_MMAP_BUCKET_SIZE => 4 * 1024; use constant CACHE_MMAP_PAGE_SIZE => 4 * 1024; ############################################################################## # Fields ############################################################################## # Public Class Fields ############################################################################## # Private Class Fields # We store the cache object in a package-wide lexical so that this # class can function as a singleton. new() will always return the same # object. my $cache; # The Cache::FileCache object is a package global so that the QA_MODE # code in debug.mc can get at it our $STORE; ############################################################################## ############################################################################## # Instance Fields ############################################################################## # Class Methods ############################################################################## =head1 INTERFACE =head2 Constructors =over 4 =item my $c = Bric::App::Cache->new() Instantiates a Bric::App::Cache object. No initial values may be passed. B =over 4 =item * Unable to instantiate cache. =back B NONE. B NONE. =cut sub new { return $cache if $cache; # return singleton object if available my $pkg = shift; # create a new cache object my $mmap; # creating a new cache? my $exists = -e CACHE_MMAP; eval { # initialize Cache::Cache backing store $STORE = Cache::FileCache->new({ namespace => 'Bricolage_Cache', cache_root => CACHE_ROOT }); # initialze mmap cache $mmap = Cache::Mmap->new(CACHE_MMAP, { buckets => 1024, bucket_size => 1024 * 4, page_size => 1024 * 4, permissions => 0777, read => \&_read_backing_store, write => \&_write_backing_store, context => $STORE, writethrough => (QA_MODE ? 1 : 0), cachenegative => 1, }); }; throw_gen error => 'Unable to instantiate cache.', payload => $@ if $@; # chown if creating cache file chown(SYS_USER, SYS_GROUP, CACHE_MMAP) unless $exists or $ENV{BRIC_TEMP_DIR}; # bless ref to cache object into this class and return return $cache = bless \$mmap, $pkg; } ############################################################################## =item my $org = Bric::App::Cache->lookup() Not implemented - not needed. B =over =item * Bric::App::Cache::lookup() method not implemented. =back B NONE. B NONE. =cut sub lookup { throw_mni __PACKAGE__."::lookup() method not implemented." } ############################################################################## =item Bric::App::Cache->list() Not implemented - not needed. B =over =item * Bric::App::Cache::list() method not implemented. =back B NONE. B NONE. =cut sub list { throw_mni __PACKAGE__."::list() method not implemented." } ############################################################################## =back =head2 Destructors =over 4 =item $org->DESTROY Dummy method to prevent wasting time trying to AUTOLOAD DESTROY. B NONE. B NONE. B NONE. =back =cut sub DESTROY {} ############################################################################## =head2 Public Class Methods =over 4 =item Bric::App::Cache->list_ids() Not implemented - not needed. B =over =item * Bric::App::Cache::list_ids() method not implemented. =back B NONE. B NONE. =cut sub list_ids { throw_mni __PACKAGE__."::list_ids() method not implemented." } ############################################################################## =item Bric::App::Cache->clear() Clears the cache of all stored data. Throws: NONE. Side Effects: NONE. Notes: NONE. =cut sub clear { rmtree(CACHE_ROOT); mkpath(CACHE_ROOT, 0, 0777); chown(SYS_USER, SYS_GROUP, CACHE_ROOT) unless $ENV{BRIC_TEMP_DIR}; undef $cache; return 1; } =back =head2 Public Instance Methods =over 4 =item my $val = $c->get($key) Returns a value for the specified key. Call $c->set($key, $value) to store a value. B =over 4 =item * Unable to fetch value from the cache. =back B NONE. B NONE. =cut sub get { my ($self, $key) = @_; my $ret; eval { $ret = $$self->read($key) }; return if not defined $ret; return $$ret unless $@; throw_da error => "Unable to fetch value from the cache.", payload => $@; } ############################################################################## =item $self = $c->set($key, $value); Stores $value as referenced by $key. Call $c->get($key) to retrieve $value. B =over 4 =item * Unable to cache value. =back B NONE. B NONE. =cut sub set { my ($self, $key, $val) = @_; eval { $$self->write($key, \$val) }; return $self unless $@; throw_dp error => "Unable to cache value.", payload => $@; } ############################################################################## =item my $lmu_time = $c->get_lmu_time Returns the epoch time when a user object was last modified. B =over 4 =item * Unable to fetch value from the cache. =back B NONE. B NONE. =cut sub get_lmu_time { get($_[0], 'lmu_time') } ############################################################################## =item $self = $c->set_lmu_time($lmu_time) Sets the epoch time when a user object was last modified. B =over 4 =item * Unable to cache value. =back B NONE. B NONE. =cut sub set_lmu_time { set($_[0], 'lmu_time', time) } ############################################################################## =item my $site_id = $c->get_user_cx($user_id) Returns the current site context for the user with the C<$user_id> ID. A value of 0 (zero) means that there is no context, in which case the user can see all the workflows from all the sites to which she has access. If the value is undefined, then the context isn't set. B If C is enabled, then C<$user_id> and C<$site_id> will be checked to ensure that they are proper arguments. =cut sub get_user_cx { if (QA_MODE) { throw_da "Must pass in a valid user ID" unless defined $_[1] and $_[1] =~ /^\d+$/; } $_[0]->get('CX_' . $_[1]) } =item $c = $c->set_user_cx($user_id, $site_id) Sets the site context for the user with the C<$user_id> ID. Pass in C to indicate an unknown context. Pass in 0 (zero) to indicate that the user has no context, and so can access all of the workflows in all of the sites to which she has access. Otherwise, simply pass in the site ID the user has selected. B If C is enabled, then C<$user_id> and C<$site_id> will be checked to ensure that they are proper arguments. =cut sub set_user_cx { if (QA_MODE) { throw_dp "Must pass in a valid user ID" unless defined $_[1] and $_[1] =~ /^\d+$/; throw_dp "Must pass in a valid site ID" unless ! defined $_[2] or $_[2] =~ /^\d+$/; } $_[0]->set('CX_' . $_[1], $_[2]) } ############################################################################## =back =head1 PRIVATE =head2 Private Class Methods NONE. =head2 Private Instance Methods NONE. =head2 Private Functions =over 4 =item $val = _read_backing_store($key) Reads a value from the backing store. See the IMPLEMENTATION section avove for details. B =over 4 =item * Unable to fetch value from the backing cache. =back B NONE. B NONE. =cut sub _read_backing_store { my $ret; eval { $ret = $STORE->get($_[0]) }; return $ret unless $@; throw_da error => "Unable to fetch value from the backing cache.", payload => $@; } =item _write_backing_store($key, $val) Writes a value to the backing store. See the IMPLEMENTATION section avove for details. B =over 4 =item * Unable to cache value in the backing cache. =back B NONE. B NONE. =cut sub _write_backing_store { eval { $STORE->set($_[0], $_[1]) }; return unless $@; throw_dp error => "Unable to cache value in the backing cache.", payload => $@; } 1; __END__ =back =head1 NOTES NONE. =head1 AUTHOR David Wheeler Sam Tregar =head1 SEE ALSO L, L, L =cut