oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'memcached' into WebGUI8

Browse source 
Conflicts:
	lib/WebGUI/Cache.pm
This commit is contained in:
JT Smith 2009-09-28 17:54:15 -05:00
commit 814bde6b93
49 changed files with 943 additions and 555 deletions
Download patch file Download diff file Expand all files Collapse all files

3
docs/changelog/8.x.x.txt
View file

@ -1 +1,4 @@
8.0.0
- Replaced the existing caching mechanism with memcached, which results in a 400% improvement to cache speed. See migration.txt for API changes and gotcha.txt for prereq changes.
- Added "hot sessions" so sessions interact with the database less.

12
docs/gotcha.txt
View file

@ -7,6 +7,18 @@ upgrading from one version to the next, or even between multiple
versions. Be sure to heed the warnings contained herein as they will
save you many hours of grief.
8.0.0
--------------------------------------------------------------------
* WebGUI 8 is not API compatible with WebGUI 7. If you have custom
code, chances are you'll need to update it to make it work with
WebGUI 8.
* WebGUI now requires memcached.
* WebGUI now requires the following Perl Modules:
- Memcached::libmemcached (0.3102)
7.8.0
--------------------------------------------------------------------

9
docs/migration.txt
View file

@ -4,3 +4,12 @@ WebGUI 8 Migration Guide
The information contained herein documents the API changes that have occurred in the WebGUI 8 development effort and how to migrate your code to accomodate the new APIs.
WebGUI::Cache
=============
WebGUI::Cache has been completely rewritten. If you were using the cache API in the past, you'll need to update your code to reflect the changes. NOTE: you can get a cached reference to the cache object from WebGUI::Session, which will be substantially faster than instantiating the object yourself.
my $cache = $session->cache;

23
docs/upgrades/upgrade_7.8.1-8.0.0.pl
View file

@ -18,6 +18,7 @@ BEGIN {
}
use strict;
use File::Path qw/rmtree/;
use Getopt::Long;
use WebGUI::Session;
use WebGUI::Storage;
@ -31,10 +32,32 @@ my $quiet; # this line required
my $session = start(); # this line required
moveMaintenance($session);
migrateToNewCache($session);
finish($session); # this line required
#----------------------------------------------------------------------------
sub migrateToNewCache {
my $session = shift;
print "\tMigrating to new cache " unless $quiet;
rmtree "../../lib/WebGUI/Cache";
unlink "../../lib/WebGUI/Workflow/Activity/CleanDatabaseCache.pm";
unlink "../../lib/WebGUI/Workflow/Activity/CleanFileCache.pm";
my $config = $session->config;
$config->set("cacheServers", [ { "socket" => "/data/wre/var/memcached.sock", "host" => "127.0.0.1", "port" => "11211" } ]);
$config->set("hotSessionFlushToDb", 600);
$config->delete("disableCache");
$config->delete("cacheType");
$config->delete("fileCacheRoot");
$config->deleteFromArray("workflowActivities/None", "WebGUI::Workflow::Activity::CleanDatabaseCache");
$config->deleteFromArray("workflowActivities/None", "WebGUI::Workflow::Activity::CleanFileCache");
my $db = $session->db;
$db->write("drop table cache");
$db->write("delete from WorkflowActivity where className in ('WebGUI::Workflow::Activity::CleanDatabaseCache','WebGUI::Workflow::Activity::CleanFileCache')");
print "DONE!\n" unless $quiet;
}
#----------------------------------------------------------------------------
sub moveMaintenance {
my $session = shift;

36
etc/WebGUI.conf.original
View file

@ -88,24 +88,28 @@
#"webServerPort" : 80,
# What kind of cache do you wish to use? Available types are
# WebGUI::Cache::FileCache and WebGUI::Cache::Database.
# We highly recommend the database cache if you are running
# sites with more than a few hundred pages, or if you're
# running in a multi-server environment. The file cache is better
# for very small sites.
# The cacheServers directive tells WebGUI how to connect to
# memcached. If a "socket" is specified it will be used instead
# of the host and port info, and this should be the
# path to the unix socket that you started memcached with. "host"
# and "port" are used to tell WebGUI how to connect to
# memcached over TCP. And since this is an array you can specify
# as many server connections as you have memcached servers
"cacheType" : "WebGUI::Cache::FileCache",
"cacheServers" : [
{ "socket" : "/tmp/memcached.sock", "host" : "127.0.0.1", "port" : "11211" }
],
# Tell WebGUI where to store cached files. Defaults to the
# /tmp or c:\temp folder depending upon your operating system.
# Sessions that are "hot", those that are not only not expired,
# but that are currently active on the site are kept in memory
# to make them exceptionally fast. The hotSessionFlushToDb
# directive allows you to say how often (in seconds) those
# sessions should be pushed down to the database. On most sites
# 10 minutes is a good duration. If you have an exceptionally
# short session timeout (in the settings) then you may wish to
# set it lower.
# "fileCacheRoot" : "/path/to/cache",
# Set this to 1 to disable WebGUI's caching subsystems. This is
# mainly useful for developers.
"disableCache" : 0,
"hotSessionFlushToDb" : 600,
# The database connection string. It usually takes the form of
# DBI:<driver>:<db>;host:<hostname>
@ -857,8 +861,6 @@
"WebGUI::Workflow::Activity::ArchiveOldStories",
"WebGUI::Workflow::Activity::ArchiveOldThreads",
"WebGUI::Workflow::Activity::CalendarUpdateFeeds",
"WebGUI::Workflow::Activity::CleanDatabaseCache",
"WebGUI::Workflow::Activity::CleanFileCache",
"WebGUI::Workflow::Activity::CleanLoginHistory",
"WebGUI::Workflow::Activity::CleanTempStorage",
"WebGUI::Workflow::Activity::CreateCronJob",

21
lib/WebGUI/Asset.pm
View file

@ -31,7 +31,6 @@ use WebGUI::AssetVersioning;
use strict;
use Tie::IxHash;
use WebGUI::AdminConsole;
use WebGUI::Cache;
use WebGUI::Form;
use WebGUI::HTML;
use WebGUI::HTMLForm;
@ -1778,19 +1777,16 @@ sub new {
return undef unless $revisionDate;
}
my $cache = WebGUI::Cache->new($session, ["asset",$assetId,$revisionDate]);
my $properties = $cache->get;
if (exists $properties->{assetId}) {
# got properties from cache
}
else {
my $properties = eval{$session->cache->get(["asset",$assetId,$revisionDate])};
unless (exists $properties->{assetId}) {
$properties = WebGUI::Asset->assetDbProperties($session, $assetId, $class, $revisionDate);
unless (exists $properties->{assetId}) {
$session->errorHandler->error("Asset $assetId $class $revisionDate is missing properties. Consult your database tables for corruption. ");
return undef;
}
$cache->set($properties,60*60*24);
eval{ $session->cache->set(["asset",$assetId,$revisionDate], $properties, 60*60*24) };
}
if (defined $properties) {
my $object = { _session=>$session, _properties => $properties };
bless $object, $class;
@ -2345,10 +2341,11 @@ sub publish {
my $idList = $self->session->db->quoteAndJoin($assetIds);
$self->session->db->write("update asset set state='published', stateChangedBy=".$self->session->db->quote($self->session->user->userId).", stateChanged=".$self->session->datetime->time()." where assetId in (".$idList.")");
my $cache = WebGUI::Cache->new($self->session);
foreach my $id (@{$assetIds}) {
# we do the purge directly cuz it's a lot faster than instantiating all these assets
$cache->deleteChunk(["asset",$id]);
my $asset = WebGUI::Asset->newByDynamicClass($self->session, $id);
if (defined $asset) {
$asset->purgeCache;
}
}
$self->{_properties}{state} = "published";
@ -2378,7 +2375,7 @@ sub purgeCache {
$stow->delete('assetLineage');
$stow->delete('assetClass');
$stow->delete('assetRevision');
WebGUI::Cache->new($self->session,["asset",$self->getId,$self->get("revisionDate")])->deleteChunk(["asset",$self->getId]);
eval{$self->session->cache->delete(["asset",$self->getId,$self->get("revisionDate")])};
}

7
lib/WebGUI/Asset/File.pm
View file

@ -17,7 +17,6 @@ package WebGUI::Asset::File;
use strict;
use base 'WebGUI::Asset';
use Carp;
use WebGUI::Cache;
use WebGUI::Storage;
use WebGUI::SQL;
use WebGUI::Utility;
@ -448,7 +447,7 @@ Extends the master method to clear the view cache.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->SUPER::purgeCache;
}
@ -608,7 +607,7 @@ Generate the view method for the Asset, and handle caching.
sub view {
my $self = shift;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$self->session->cache->get("view_".$self->getId)};
return $out if $out;
}
my %var = %{$self->get};
@ -618,7 +617,7 @@ sub view {
$var{fileSize} = formatBytes($self->get("assetSize"));
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
eval{$self->session->cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}

14
lib/WebGUI/Asset/File/Image.pm
View file

@ -222,8 +222,9 @@ Renders this asset.
sub view {
my $self = shift;
my $cache = $self->session->cache;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
my %var = %{$self->get};
@ -247,7 +248,7 @@ sub view {
my $form = $self->session->form;
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}
@ -310,16 +311,7 @@ sub www_undo {
my $previous = (@{$self->getRevisions()})[1];
# instantiate assetId
if ($previous) {
# my $session = $self->session;
# my $cache = WebGUI::Cache->new($self->session, ["asset",$self->getId,$self->getRevisionDate]);
# $cache->flush;
# my $cache = WebGUI::Cache->new($previous->session, ["asset",$previous->getId,$previous->getRevisionDate]);
# $cache->flush;
$self = $self->purgeRevision();
# $self = undef;
# $self = WebGUI::Asset->new($previous->session, $previous->getId, ref $previous, $previous->getRevisionDate);
$self = $previous;
$self->generateThumbnail;
}

5
lib/WebGUI/Asset/File/ZipArchive.pm
View file

@ -220,8 +220,9 @@ used to show the file to administrators.
sub view {
my $self = shift;
my $cache = $self->session->cache;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
my %var = %{$self->get};
@ -244,7 +245,7 @@ sub view {
$var{noFileSpecified} = $i18n->get('noFileSpecified');
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}

3
lib/WebGUI/Asset/Post.pm
View file

@ -16,7 +16,6 @@ use Tie::IxHash;
use WebGUI::Asset;
use WebGUI::Asset::Template;
use WebGUI::Asset::Post::Thread;
use WebGUI::Cache;
use WebGUI::Group;
use WebGUI::HTML;
use WebGUI::HTMLForm;
@ -1188,7 +1187,7 @@ Extend the base class to handle caching.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getThread->getId)->delete if ($self->getThread);
eval{$self->session->cache->delete("view_".$self->getThread->getId)} if ($self->getThread);
$self->SUPER::purgeCache;
}

6
lib/WebGUI/Asset/Post/Thread.pm
View file

@ -13,7 +13,6 @@ package WebGUI::Asset::Post::Thread;
use strict;
use WebGUI::Asset::Template;
use WebGUI::Asset::Post;
use WebGUI::Cache;
use WebGUI::Group;
use WebGUI::International;
use WebGUI::Paginator;
@ -1026,8 +1025,9 @@ sub view {
my $currentPost = shift || $self;
$self->markRead;
$self->incrementViews unless ($self->session->form->process("func") eq 'rate');
my $cache = $self->session->cache;
if ($self->session->user->isVisitor && !$self->session->form->process("layout")) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
$self->session->scratch->set("discussionLayout",$self->session->form->process("layout")) if ($self->session->form->process("layout"));
@ -1134,7 +1134,7 @@ sub view {
my $out = $self->processTemplate($var,undef,$self->{_viewTemplate});
if ($self->session->user->isVisitor && !$self->session->form->process("layout")) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->getThread->getParent->get("visitorCacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->getThread->getParent->get("visitorCacheTimeout"))};
}
return $out;
}

8
lib/WebGUI/Asset/Shortcut.pm
View file

@ -481,10 +481,10 @@ expired, or if the user's profile field has changed.
sub getOverrides {
my $self = shift;
my $session = $self->session;
my $cache = WebGUI::Cache->new($self->session,$self->_overridesCacheTag);
my $cache = $session->cache;
my $u = WebGUI::User->new($self->session, $self->discernUserId);
my $overridesRef = $cache->get;
my $overridesRef = eval{$cache->get($self->_overridesCacheTag)};
##If admin mode is not on, and the cache is valid, and not expired, and the user object was not updated,
##return the cached value.
if ( ! $session->var->isAdminOn
@ -532,7 +532,7 @@ sub getOverrides {
}
}
$overrides{userLastUpdated} = $session->user->get('lastUpdated');
$cache->set(\%overrides, 60*60);
eval{$cache->set($self->_overridesCacheTag, \%overrides, 60*60)};
$overridesRef = \%overrides;
return %{ $overridesRef };
}
@ -879,7 +879,7 @@ Delete any cached overrides.
sub uncacheOverrides {
my $self = shift;
WebGUI::Cache->new($self->session,$self->_overridesCacheTag)->delete;
eval{$self->session->cache->delete($self->_overridesCacheTag)};
}
#-------------------------------------------------------------------

8
lib/WebGUI/Asset/Sku/Product.pm
View file

@ -13,7 +13,6 @@ package WebGUI::Asset::Sku::Product;
use strict;
use Tie::CPHash;
use Tie::IxHash;
use WebGUI::Cache;
use WebGUI::HTMLForm;
use WebGUI::Storage;
use WebGUI::SQL;
@ -789,7 +788,7 @@ Extends the base class to handle cleaning up the cache for this asset.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
$self->session->cache->delete("view_".$self->getId);
$self->SUPER::purgeCache;
}
@ -1674,8 +1673,9 @@ sub view {
my $self = shift;
my $error = shift;
my $session = $self->session;
my $cache = $session->cache;
if (!$session->var->isAdminOn && $self->get("cacheTimeout") > 10){
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = $cache->get("view_".$self->getId);
return $out if $out;
}
my (%data, $segment, %var, @featureloop, @benefitloop, @specificationloop, @accessoryloop, @relatedloop);
@ -1878,7 +1878,7 @@ sub view {
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10 && $self->{_hasAddedToCart} != 1){
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"));
}
return $out;
}

12
lib/WebGUI/Asset/Snippet.pm
View file

@ -250,9 +250,11 @@ Extending purgeCache to handle caching of the rendered snippet
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view__".$self->getId)->delete;
WebGUI::Cache->new($self->session,"view_1_".$self->getId)->delete;
my $cache = $self->session->cache;
eval {
$cache->delete("view__".$self->getId);
$cache->delete("view_1_".$self->getId);
};
$self->SUPER::purgeCache();
}
@ -279,7 +281,7 @@ sub view {
|| $self->get("cacheTimeout") <= 10
|| ($versionTag && $versionTag->getId eq $self->get("tagId"));
unless ($noCache) {
my $out = WebGUI::Cache->new($session,"view_".$calledAsWebMethod."_".$self->getId)->get;
my $out = eval{$session->cache->get("view_".$calledAsWebMethod."_".$self->getId)};
return $out if $out;
}
my $output = $self->get('usePacked')
@ -292,7 +294,7 @@ sub view {
}
WebGUI::Macro::process($session,\$output);
unless ($noCache) {
WebGUI::Cache->new($session,"view_".$calledAsWebMethod."_".$self->getId)->set($output,$self->get("cacheTimeout"));
eval{$session->cache->set("view_".$calledAsWebMethod."_".$self->getId, $output, $self->get("cacheTimeout"))};
}
return $output;
}

8
lib/WebGUI/Asset/Wobject/Article.pm
View file

@ -13,7 +13,6 @@ package WebGUI::Asset::Wobject::Article;
use strict;
use Tie::IxHash;
use WebGUI::International;
use WebGUI::Cache;
use WebGUI::Paginator;
use WebGUI::Asset::Wobject;
use WebGUI::Storage;
@ -319,7 +318,7 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->SUPER::purgeCache;
}
@ -348,9 +347,10 @@ returns the output.
sub view {
my $self = shift;
my $cache = $self->session->cache;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10 && !$self->session->form->process("overrideTemplateId") &&
!$self->session->form->process($self->paginateVar) && !$self->session->form->process("makePrintable")) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
my %var;
@ -414,7 +414,7 @@ sub view {
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10 && !$self->session->form->process("overrideTemplateId") &&
!$self->session->form->process($self->paginateVar) && !$self->session->form->process("makePrintable")) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}

13
lib/WebGUI/Asset/Wobject/Collaboration.pm
View file

@ -13,7 +13,6 @@ package WebGUI::Asset::Wobject::Collaboration;
use strict;
use Tie::IxHash;
use WebGUI::Group;
use WebGUI::Cache;
use WebGUI::HTML;
use WebGUI::International;
use WebGUI::Paginator;
@ -1404,8 +1403,11 @@ Extend the base method to delete view and visitor caches.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
WebGUI::Cache->new($self->session,$self->_visitorCacheKey)->delete;
my $cache = $self->session->cache;
eval {
$cache->delete("view_".$self->getId);
$cache->delete($self->_visitorCacheKey);
};
$self->next::method;
}
@ -1549,8 +1551,9 @@ Render the CS, and handle local caching.
sub view {
my $self = shift;
my $cache = $self->session->cache;
if ($self->_visitorCacheOk) {
my $out = WebGUI::Cache->new($self->session,$self->_visitorCacheKey)->get;
my $out = eval{$cache->get($self->_visitorCacheKey)};
$self->session->errorHandler->debug("HIT") if $out;
return $out if $out;
}
@ -1561,7 +1564,7 @@ sub view {
$self->prepareView unless ($self->{_viewTemplate});
my $out = $self->processTemplate($self->getViewTemplateVars,undef,$self->{_viewTemplate});
if ($self->_visitorCacheOk) {
WebGUI::Cache->new($self->session,$self->_visitorCacheKey)->set($out,$self->get("visitorCacheTimeout"));
eval{$cache->set($self->_visitorCacheKey, $out, $self->get("visitorCacheTimeout"))};
}
return $out;
}

1
lib/WebGUI/Asset/Wobject/EventManagementSystem.pm
View file

@ -25,7 +25,6 @@ use WebGUI::Asset::Sku::EMSBadge;
use WebGUI::Asset::Sku::EMSTicket;
use WebGUI::Asset::Sku::EMSRibbon;
use WebGUI::Asset::Sku::EMSToken;
use WebGUI::Cache;
use WebGUI::Exception;
use WebGUI::FormValidator;
use WebGUI::HTMLForm;

9
lib/WebGUI/Asset/Wobject/Folder.pm
View file

@ -16,7 +16,6 @@ package WebGUI::Asset::Wobject::Folder;
use strict;
use WebGUI::Asset::Wobject;
use WebGUI::Cache;
use WebGUI::Utility;
our @ISA = qw(WebGUI::Asset::Wobject);
@ -208,7 +207,7 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->SUPER::purgeCache;
}
@ -225,8 +224,9 @@ sub view {
my $self = shift;
# Use cached version for visitors
my $cache = $self->session->cache;
if ($self->session->user->isVisitor) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
@ -291,8 +291,7 @@ sub view {
# Update the cache
if ($self->session->user->isVisitor) {
WebGUI::Cache->new($self->session,"view_".$self->getId)
->set($out,$self->get("visitorCacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("visitorCacheTimeout"))};
}
return $out;

26
lib/WebGUI/Asset/Wobject/HttpProxy.pm
View file

@ -20,7 +20,6 @@ use WebGUI::International;
use WebGUI::Storage;
use WebGUI::Asset::Wobject;
use WebGUI::Asset::Wobject::HttpProxy::Parse;
use WebGUI::Cache;
use WebGUI::Macro;
use Apache2::Upload;
@ -277,8 +276,11 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,$self->get("proxiedUrl"),"URL")->delete;
WebGUI::Cache->new($self->session,$self->get("proxiedUrl"),"HEADER")->delete;
my $cache = $self->session->cache;
eval {
$cache->delete([$self->get("proxiedUrl"),"URL"]);
$cache->delete([$self->get("proxiedUrl"),"HEADER"]);
};
$self->SUPER::purgeCache;
}
@ -320,12 +322,12 @@ sub view {
my $requestMethod = $self->session->env->get("REQUEST_METHOD") || "GET";
### Do we have cached content to get?
my $cacheContent = WebGUI::Cache->new($self->session,$proxiedUrl,"URL");
my $cacheHeader = WebGUI::Cache->new($self->session,$proxiedUrl,"HEADER");
if ($requestMethod =~ /^GET$/i)
{
$var{header} = $cacheHeader->get;
$var{content} = $cacheContent->get;
my $cache = $self->session->cache;
if ($requestMethod =~ /^GET$/i) {
eval {
$var{header} = $cache->get([$proxiedUrl,'HEADER']);
$var{content} = $cache->get([$proxiedUrl,"URL"]);
};
}
# Unless we have cached content
@ -465,8 +467,10 @@ sub view {
$var{content} = sprintf $i18n->get('fetch page error'), $proxiedUrl, $proxiedUrl, $response->status_line;
}
unless ($self->get("cacheTimeout") <= 10) {
$cacheContent->set($var{content},$self->get("cacheTimeout"));
$cacheHeader->set($var{header},$self->get("cacheTimeout"));
eval{
$cache->set([$proxiedUrl,'URL'], $var{content}, $self->get("cacheTimeout"));
$cache->set([$proxiedUrl,'HEADER'], $var{header}, $self->get("cacheTimeout"));
};
}
}

7
lib/WebGUI/Asset/Wobject/Layout.pm
View file

@ -18,7 +18,6 @@ use strict;
use WebGUI::AdSpace;
use WebGUI::Asset::Wobject;
use WebGUI::Utility;
use WebGUI::Cache;
our @ISA = qw(WebGUI::Asset::Wobject);
@ -413,13 +412,13 @@ sub www_view {
if ($session->env->sslRequest) {
$cacheKey .= '_ssl';
}
my $cache = WebGUI::Cache->new($session, $cacheKey);
my $out = $cache->get if defined $cache;
my $cache = $session->cache;
my $out = eval{$cache->get($cacheKey)};
unless ($out) {
$self->prepareView;
$session->stow->set("cacheFixOverride", 1);
$out = $self->processStyle($self->view, { noHeadTags => 1 });
$cache->set($out, 60);
eval{$cache->set($cacheKey, $out, 60)};
$session->stow->delete("cacheFixOverride");
}
# keep those ads rotating even though the output is cached

14
lib/WebGUI/Asset/Wobject/Matrix.pm
View file

@ -505,8 +505,9 @@ sub getListings {
$session->var->isAdminOn
|| $self->get("listingsCacheTimeout") <= 10
|| ($versionTag && $versionTag->getId eq $self->get("tagId"));
my $cache = $session->cache;
unless ($noCache) {
$listingsEncoded = WebGUI::Cache->new($session,"matrixListings_".$self->getId)->get;
$listingsEncoded = eval{$cache->get("matrixListings_".$self->getId)};
}
if ($listingsEncoded){
@ -546,9 +547,7 @@ assetData.revisionDate
}
$listingsEncoded = JSON->new->encode($listings);
WebGUI::Cache->new($session,"matrixListings_".$self->getId)->set(
$listingsEncoded,$self->get("listingsCacheTimeout")
);
eval{$cache->set("matrixListings_".$self->getId, $listingsEncoded, $self->get("listingsCacheTimeout"))};
}
return $listings;
}
@ -687,8 +686,9 @@ sub view {
$session->var->isAdminOn
|| $self->get("statisticsCacheTimeout") <= 10
|| ($versionTag && $versionTag->getId eq $self->get("tagId"));
my $cache = $session->cache;
unless ($noCache) {
$varStatisticsEncoded = WebGUI::Cache->new($session,"matrixStatistics_".$self->getId)->get;
$varStatisticsEncoded = eval{$cache->get("matrixStatistics_".$self->getId)};
}
if ($varStatisticsEncoded){
@ -837,9 +837,7 @@ sub view {
[$self->getId]);
$varStatisticsEncoded = JSON->new->encode($varStatistics);
WebGUI::Cache->new($session,"matrixStatistics_".$self->getId)->set(
$varStatisticsEncoded,$self->get("statisticsCacheTimeout")
);
eval{$cache->set("matrixStatistics_".$self->getId, $varStatisticsEncoded, $self->get("statisticsCacheTimeout"))};
}
foreach my $statistic (keys %{$varStatistics}) {

8
lib/WebGUI/Asset/Wobject/MessageBoard.pm
View file

@ -12,7 +12,6 @@ package WebGUI::Asset::Wobject::MessageBoard;
use strict;
use Tie::IxHash;
use WebGUI::Cache;
use WebGUI::Asset::Wobject;
use WebGUI::International;
use WebGUI::SQL;
@ -91,7 +90,7 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->SUPER::purgeCache;
}
@ -105,8 +104,9 @@ See WebGUI::Asset::view() for details.
sub view {
my $self = shift;
my $cache = $self->session->cache;
if ($self->session->user->isVisitor) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
my %var;
@ -171,7 +171,7 @@ sub view {
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if ($self->session->user->isVisitor) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("visitorCacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("visitorCacheTimeout"))};
}
return $out;
}

8
lib/WebGUI/Asset/Wobject/MultiSearch.pm
View file

@ -24,7 +24,6 @@ use Tie::IxHash;
use JSON;
use WebGUI::International;
use WebGUI::SQL;
use WebGUI::Cache;
use WebGUI::Asset::Wobject;
use WebGUI::Utility;
@ -114,7 +113,7 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->SUPER::purgeCache;
}
@ -129,8 +128,9 @@ to be displayed within the page style
sub view {
my $self = shift;
my $cache = $self->session->cache;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
my $i18n = WebGUI::International->new($self->session, 'Asset_MultiSearch');
@ -143,7 +143,7 @@ sub view {
my $out = $self->processTemplate(\%var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}

8
lib/WebGUI/Asset/Wobject/SQLReport.pm
View file

@ -18,7 +18,6 @@ use WebGUI::Paginator;
use WebGUI::SQL;
use WebGUI::Utility;
use WebGUI::Asset::Wobject;
use WebGUI::Cache;
use WebGUI::Text qw(:csv);
our @ISA = qw(WebGUI::Asset::Wobject);
@ -518,7 +517,7 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->SUPER::purgeCache;
}
@ -533,8 +532,9 @@ if the user is not in Admin Mode.
sub view {
my $self = shift;
my $cache = $self->session->cache;
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
my $out = WebGUI::Cache->new($self->session,"view_".$self->getId)->get;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if $out;
}
# Initiate an empty debug loop
@ -560,7 +560,7 @@ sub view {
my $out = $self->processTemplate($var,undef,$self->{_viewTemplate});
if (!$self->session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
WebGUI::Cache->new($self->session,"view_".$self->getId)->set($out,$self->get("cacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}

1
lib/WebGUI/Asset/Wobject/Survey.pm
View file

@ -1378,7 +1378,6 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new( $self->session, 'view_' . $self->getId )->delete;
return $self->SUPER::purgeCache;
}

15
lib/WebGUI/Asset/Wobject/SyndicatedContent.pm
View file

@ -13,7 +13,6 @@ package WebGUI::Asset::Wobject::SyndicatedContent;
use strict;
use HTML::Entities;
use Tie::IxHash;
use WebGUI::Cache;
use WebGUI::Exception;
use WebGUI::HTML;
use WebGUI::International;
@ -136,16 +135,16 @@ sub generateFeed {
# build one feed out of many
my $newlyCached = 0;
my $cache = $self->session->cache;
foreach my $url (split(/\s+/, $self->get('rssUrl'))) {
$log->info("Processing FEED: ".$url);
$url =~ s/^feed:/http:/;
if ($self->get('processMacroInRssUrl')) {
WebGUI::Macro::process($self->session, \$url);
}
my $cache = WebGUI::Cache->new($self->session, $url, "RSS");
my $value = $cache->get;
my $value = eval{$cache->get($url)};
unless ($value) {
$value = $cache->setByHTTP($url, $self->get("cacheTimeout"));
$value = eval{$cache->setByHttp($url, $self->get("cacheTimeout"))};
$newlyCached = 1;
}
# if the content can be downgraded, it is either valid latin1 or didn't have
@ -328,7 +327,7 @@ See WebGUI::Asset::purgeCache() for details.
sub purgeCache {
my $self = shift;
WebGUI::Cache->new($self->session,"view_".$self->getId)->delete;
eval{$self->session->cache->delete("view_".$self->getId)};
$self->next::method;
}
@ -345,8 +344,8 @@ sub view {
my $session = $self->session;
# try the cached version
my $cache = WebGUI::Cache->new($session,"view_".$self->getId);
my $out = $cache->get;
my $cache = $session->cache;
my $out = eval{$cache->get("view_".$self->getId)};
return $out if ($out ne "" && !$session->var->isAdminOn);
#return $out if $out;
@ -354,7 +353,7 @@ sub view {
my $feed = $self->generateFeed;
$out = $self->processTemplate($self->getTemplateVariables($feed),undef,$self->{_viewTemplate});
if (!$session->var->isAdminOn && $self->get("cacheTimeout") > 10) {
$cache->set($out,$self->get("cacheTimeout"));
eval{$cache->set("view_".$self->getId, $out, $self->get("cacheTimeout"))};
}
return $out;
}

4
lib/WebGUI/Asset/Wobject/Thingy.pm
View file

@ -2662,7 +2662,7 @@ sub www_export {
push(@fieldLabels,@metaDataFields)
}
$query = WebGUI::Cache->new($self->session,"query_".$thingId)->get;
$query = eval{$session->cache->get("query_".$thingId)};
$sth = $session->db->read($query);
### Loop through the returned structure and put it through Text::CSV
@ -3307,7 +3307,7 @@ sequenceNumber');
}
# store query in cache for thirty minutes
WebGUI::Cache->new($self->session,"query_".$thingId)->set($query,30*60);
eval{$self->session->cache->set("query_".$thingId, $query, 30*60)};
$paginatePage = $self->session->form->param('pn') || 1;
$currentUrl = $self->session->url->append($currentUrl, "orderBy=".$orderBy) if $orderBy;

14
lib/WebGUI/AssetLineage.pm
View file

@ -147,14 +147,16 @@ sub cascadeLineage {
"UPDATE asset SET lineage=CONCAT(?,SUBSTRING(lineage,?)) WHERE lineage LIKE ?",
[$newLineage, length($oldLineage) + 1, $oldLineage . '%']
);
my $cache = WebGUI::Cache->new($self->session);
if ($records > 20) {
$cache->flush;
eval{$self->session->cache->flush};
}
else {
my $descendants = $self->session->db->read("SELECT assetId FROM asset WHERE lineage LIKE ?", [$newLineage . '%']);
while (my ($assetId, $lineage) = $descendants->array) {
$cache->deleteChunk(["asset",$assetId]);
my $asset = WebGUI::Asset->newByDynamicClass($self->session, $assetId);
if (defined $asset) {
$asset->purgeCache;
}
}
$descendants->finish;
}
@ -265,10 +267,8 @@ sub getFirstChild {
my $lineage = $assetLineage->{firstChild}{$self->getId};
unless ($lineage) {
($lineage) = $self->session->db->quickArray("select min(asset.lineage) from asset,assetData where asset.parentId=? and asset.assetId=assetData.assetId and asset.state='published'",[$self->getId]);
unless ($self->session->config->get("disableCache")) {
$assetLineage->{firstChild}{$self->getId} = $lineage;
$self->session->stow->set("assetLineage", $assetLineage);
}
$assetLineage->{firstChild}{$self->getId} = $lineage;
$self->session->stow->set("assetLineage", $assetLineage);
}
$child = WebGUI::Asset->newByLineage($self->session,$lineage);
$self->cacheChild(first => $child);

1
lib/WebGUI/AssetTrash.pm
View file

@ -191,7 +191,6 @@ sub purge {
# clean up cache
$outputSub->($i18n->get('Clearing cache'));
WebGUI::Cache->new($session)->deleteChunk(["asset",$self->getId]);
$self->purgeCache;
# delete stuff out of the asset tables

400
lib/WebGUI/Cache.pm
View file

@ -19,7 +19,17 @@ use File::Path ();
use HTTP::Headers;
use HTTP::Request;
use LWP::UserAgent;
use Digest::MD5;
use Memcached::libmemcached;
use Storable ();
use WebGUI::Exception;
use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub {
my $error = shift;
warn "Error in Cache params: ".$error;
WebGUI::Error::InvalidParam->throw( error => $error );
} );
=head1 NAME
@ -39,11 +49,12 @@ A base class for all Cache modules to extend.
$cache->set($value);
$cache->setByHTTP("http://www.google.com/");
my $value = $cache->get;
my $value = $cache->get($name);
my ($val1, $val2) = @{$cache->mget([$name1, $name2])};
$cache->delete;
$cache->deleteChunk("my app cache");
$cache->deleteChunk([ "my app", $assetId ]);
$cache->delete($name);
$cache->flush;
=head1 METHODS
@ -54,14 +65,99 @@ These methods are available from this class:
#-------------------------------------------------------------------
=head2 delete ( )
=head2 delete ( name )
Delete a key from the cache.
Throws WebGUI::Error::InvalidParam, WebGUI::Error::Connection and WebGUI::Error.
=head3 name
Delete a key from the cache. Must be overridden.
=cut
sub delete {
my $self = shift;
my $debug = $self->withDebug;
my ($name) = ($debug) ? validate_pos(@_, { type => SCALAR | ARRAYREF }) : @_;
my $key = $self->parseKey($name);
if ($debug) {
$self->session->log->debug("Called delete() on cache key $key.");
}
my $memcached = $self->getMemcached;
Memcached::libmemcached::memcached_delete($memcached, $key);
if ($debug) {
my $log = $self->session->log;
if ($memcached->errstr eq 'SYSTEM ERROR Unknown error: 0') {
$log->debug("Cannot connect to memcached server.");
WebGUI::Error::Connection->throw(
error => "Cannot connect to memcached server."
);
}
elsif ($memcached->errstr eq 'NOT FOUND' ) {
$log->debug("The cache key $key has no value.");
WebGUI::Error::ObjectNotFound->throw(
error => "The cache key $key has no value.",
id => $key,
);
}
elsif ($memcached->errstr eq 'NO SERVERS DEFINED') {
$log->warn("No memcached servers specified in config file.");
WebGUI::Error->throw(
error => "No memcached servers specified in config file."
);
}
elsif ($memcached->errstr ne 'SUCCESS' # deleted
&& $memcached->errstr ne 'PROTOCOL ERROR' # doesn't exist to delete
) {
$log->debug("Couldn't delete $key from cache because ".$memcached->errstr);
WebGUI::Error->throw(
error => "Couldn't delete $key from cache because ".$memcached->errstr
);
}
}
}
#-------------------------------------------------------------------
=head2 flush ( )
Empties the caching system.
Throws WebGUI::Error::Connection and WebGUI::Error.
=cut
sub flush {
my ($self) = @_;
my $debug = $self->withDebug;
if ($debug) {
$self->session->log->debug("Called flush() on cache.");
}
my $memcached = $self->getMemcached;
Memcached::libmemcached::memcached_flush($memcached);
if ($debug) {
my $log = $self->session->log;
if ($memcached->errstr eq 'SYSTEM ERROR Unknown error: 0') {
$log->debug("Cannot connect to memcached server.");
WebGUI::Error::Connection->throw(
error => "Cannot connect to memcached server."
);
}
elsif ($memcached->errstr eq 'NO SERVERS DEFINED') {
$log->warn("No memcached servers specified in config file.");
WebGUI::Error->throw(
error => "No memcached servers specified in config file."
);
}
elsif ($memcached->errstr ne 'SUCCESS') {
$log->debug("Couldn't flush cache because ".$memcached->errstr);
WebGUI::Error->throw(
error => "Couldn't flush cache because ".$memcached->errstr
);
}
}
}
#-------------------------------------------------------------------
@ -70,15 +166,62 @@ sub delete {
Deletes a bunch of keys from the cache based upon a partial composite key. Unless overridden by the cache subclass this will just flush the whole cache.
=head3 key
Throws WebGUI::Error::InvalidObject, WebGUI::Error::InvalidParam, WebGUI::Error::ObjectNotFound, WebGUI::Error::Connection and WebGUI::Error.
=head3 name
An array reference representing the portion of the key to delete. So if you have a key like ["asset","abc","def"] and you want to delete all items that match abc, you'd specify ["asset","abc"].
=cut
sub deleteChunk {
my $self = shift;
$self->flush;
sub get {
my $self = shift;
my $debug = $self->withDebug;
my ($name) = ($debug) ? validate_pos(@_, { type => SCALAR | ARRAYREF }) : @_;
my $key = $self->parseKey($name);
if ($debug) {
$self->session->log->debug("Called get() on cache key $key.");
}
my $memcached = $self->getMemcached;
my $content = Memcached::libmemcached::memcached_get($memcached, $key);
$content = Storable::thaw($content);
if ($debug) {
my $log = $self->session->log;
if ($memcached->errstr eq 'SUCCESS') {
unless (ref $content) {
$log->debug("Couldn't thaw value for $key.");
WebGUI::Error::InvalidObject->throw(
error => "Couldn't thaw value for $key."
);
}
return ${$content};
}
elsif ($memcached->errstr eq 'NOT FOUND' ) {
$log->debug("The cache key $key has no value.");
WebGUI::Error::ObjectNotFound->throw(
error => "The cache key $key has no value.",
id => $key,
);
}
elsif ($memcached->errstr eq 'NO SERVERS DEFINED') {
$log->warn("No memcached servers specified in config file.");
WebGUI::Error->throw(
error => "No memcached servers specified in config file."
);
}
elsif ($memcached->errstr eq 'SYSTEM ERROR Unknown error: 0') {
$log->debug("Cannot connect to memcached server.");
WebGUI::Error::Connection->throw(
error => "Cannot connect to memcached server."
);
}
$log->debug("Couldn't get $key from cache because ".$memcached->errstr);
WebGUI::Error->throw(
error => "Couldn't get $key from cache because ".$memcached->errstr
);
return undef;
}
return (ref $content) ? ${$content} : undef;
}
#-------------------------------------------------------------------
@ -96,49 +239,99 @@ sub flush {
#-------------------------------------------------------------------
=head2 get ( )
=head2 mget ( names )
Retrieves multiple values from cache at once, which is much faster than retrieving one at a time. Returns an array reference containing the values in the order they were requested.
Throws WebGUI::Error::InvalidParam, WebGUI::Error::Connection and WebGUI::Error.
=head3 names
Retrieves a key value from the cache. Must be overridden.
=cut
sub get {
sub mget {
my $self = shift;
my $debug = $self->withDebug;
my ($names) = ($debug) ? validate_pos(@_, { type => ARRAYREF }) : @_;
my @keys = map { $self->parseKey($_) } @{ $names };
my $log = $self->session->log;
if ($debug) {
$log->debug("Called mget() for keys (".join(", ",@keys).") on cache.");
}
my %result;
my $memcached = $self->getMemcached;
$memcached->mget_into_hashref(\@keys, \%result);
if ($debug) {
if ($memcached->errstr eq 'SYSTEM ERROR Unknown error: 0') {
$log->debug("Cannot connect to memcached server.");
WebGUI::Error::Connection->throw(
error => "Cannot connect to memcached server."
);
}
elsif ($memcached->errstr eq 'NO SERVERS DEFINED') {
$log->warn("No memcached servers specified in config file.");
WebGUI::Error->throw(
error => "No memcached servers specified in config file."
);
}
}
# no other useful status messages are returned
my @values;
foreach my $key (@keys) {
my $content = Storable::thaw($result{$key});
unless (ref $content) {
$log->debug("Cannot thaw key $key.") if ($debug);
next;
}
push @values, ${$content};
}
return \@values;
}
#-------------------------------------------------------------------
=head2 new ( session, key, [ namespace ] )
=head2 new ( session, withDebug )
The new method will return a handler for the configured caching mechanism. Defaults to WebGUI::Cache::FileCache. You must override this method when building your own cache plug-in.
Constructor. Will return a handler for the configured caching mechanism. Defaults to WebGUI::Cache::FileCache. You must override this method when building your own cache plug-in.
Throws WebGUI::Error::InvalidParam.
=head3 session
A reference to the current session.
=head3 key
=head3 withDebug
A key to store the value under or retrieve it from. Can either be a scalar or an array reference of pieces (called
a composite key). Composite keys are useful for deleting a chunk (see deleteChunk()) of cache data all at once, and
for using multi-level identifiers like assetId/revisionDate.
=head3 namespace
A subdivider to store this cache under. When building your own cache plug-in default this to the WebGUI config file.
A boolean indicating you want to enable parameter validation, exception handling, and debug logging. Note that this will make the cahe system up to 3 times slower. It will still be very fast, but not production fast.
=cut
sub new {
my $class = shift;
my $session = shift;
if ($session->config->get("cacheType") eq "WebGUI::Cache::Database") {
require WebGUI::Cache::Database;
return WebGUI::Cache::Database->new($session,@_);
} else {
require WebGUI::Cache::FileCache;
return WebGUI::Cache::FileCache->new($session,@_);
}
my ($class, $session, $withDebug) = validate_pos(@_,
1,
{ isa => 'WebGUI::Session' },
{ type => SCALAR | UNDEF, optional=>1, default=>0 },
);
if ($withDebug) {
my $log = $session->log;
$log->debug("Instanciated cache object.");
$log->debug("Cache debugging ".($withDebug ? "enabled" : "disabled").".");
}
my $config = $session->config;
my $namespace = $config->getFilename;
my $memcached = Memcached::libmemcached::memcached_create(); # no exception because always returns success
foreach my $server (@{$config->get('cacheServers')}) {
if (exists $server->{socket}) {
Memcached::libmemcached::memcached_server_add_unix_socket($memcached, $server->{socket}); # no exception because always returns success
}
else {
Memcached::libmemcached::memcached_server_add($memcached, $server->{host}, $server->{port}); # no exception because always returns success
}
}
bless {_memcached => $memcached, _namespace => $namespace, _session => $session, _withDebug=>$withDebug}, $class;
}
#-------------------------------------------------------------------
@ -147,24 +340,27 @@ sub new {
Returns a formatted string version of the key. A class method.
=head3 key
Throws WebGUI::Error::InvalidParam.
=head3 name
Can either be a text key, or a composite key. If it's a composite key, it will be an array reference of strings that can be joined together to create a key. You might want to use a composite key in order to be able to delete large portions of cache all at once. For instance, if you have a key of ["asset","abc","def"] you can delete all cache matching ["asset","abc"].
=cut
sub parseKey {
my $class = shift;
my $self = shift;
my ($name) = ($self->withDebug) ? validate_pos(@_, { type => SCALAR | ARRAYREF }) : @_;
# prepend namespace to the key
my @key = ($self->{_namespace});
# check for composite or simple key, make array from either
my @key;
if (! $_[0]) {
return;
}
elsif (ref $_[0] eq 'ARRAY') {
@key = @{ +shift };
if (ref $name eq 'ARRAY') {
push @key, @{ $name };
}
else {
@key = shift;
push @key, $name;
}
foreach my $part (@key) {
# convert to octets, then md5 them
@ -191,7 +387,11 @@ sub session {
=head2 set ( value [, ttl] )
Sets a key value to the cache. Must be overridden.
Throws WebGUI::Error::InvalidParam, WebGUI::Error::Connection, and WebGUI::Error.
=head3 name
The name of the key to set.
=head3 value
@ -204,19 +404,54 @@ A time in seconds for the cache to exist. When you override default it to 60 sec
=cut
sub set {
my $self = shift;
my $debug = $self->withDebug;
my ($name, $value, $ttl) = ($debug) ? validate_pos(@_, { type => SCALAR | ARRAYREF }, { type => SCALAR | ARRAYREF | HASHREF }, { type => SCALAR | UNDEF, optional => 1 }) : @_;
$ttl ||= 60;
my $key = $self->parseKey($name);
if ($debug) {
$self->session->log->debug("Called set() on cache key $key with $value as the value.");
}
my $frozenValue = Storable::nfreeze(\(scalar $value)); # Storable doesn't like non-reference arguments, so we wrap it in a scalar ref.
my $memcached = $self->getMemcached;
Memcached::libmemcached::memcached_set($memcached, $key, $frozenValue, $ttl);
if ($debug) {
my $log = $self->session->log;
if ($memcached->errstr eq 'SUCCESS') {
return $value;
}
elsif ($memcached->errstr eq 'SYSTEM ERROR Unknown error: 0') {
$log->debug("Cannot connect to memcached server.");
WebGUI::Error::Connection->throw(
error => "Cannot connect to memcached server."
);
}
elsif ($memcached->errstr eq 'NO SERVERS DEFINED') {
$log->warn("No memcached servers specified in config file.");
WebGUI::Error->throw(
error => "No memcached servers specified in config file."
);
}
$log->debug("Couldn't set $key to cache because ".$memcached->errstr);
WebGUI::Error->throw(
error => "Couldn't set $key to cache because ".$memcached->errstr
);
}
return $value;
}
#-------------------------------------------------------------------
=head2 setByHTTP ( url [, ttl ] )
=head2 setByHttp ( url [, ttl ] )
Retrieves a document via HTTP and stores it in the cache and returns the content as a string. No need to override.
Throws WebGUI::Error::InvalidParam, WebGUI::Error::Connection, and WebGUI::Error.
=head3 url
The URL of the document to retrieve. It must begin with the standard "http://".
The URL of the document to retrieve. It must begin with the standard "http://". This will be used as the key for this cache entry.
=head3 ttl
@ -224,11 +459,14 @@ The time to live for this content. This is the amount of time (in seconds) that
=cut
sub setByHTTP {
my $self = shift;
my $url = shift;
my $ttl = shift;
my $userAgent = new LWP::UserAgent;
sub setByHttp {
my $self = shift;
my $debug = $self->withDebug;
my ($url, $ttl) = ($debug) ? validate_pos(@_, { type => SCALAR }, { type => SCALAR, optional => 1 }) : @_;
if ($debug) {
$self->session->log->debug("Called setByHttp() with URL $url.");
}
my $userAgent = new LWP::UserAgent;
$userAgent->env_proxy;
$userAgent->agent("WebGUI/".$WebGUI::VERSION);
$userAgent->timeout(30);
@ -239,27 +477,71 @@ sub setByHTTP {
my $request = HTTP::Request->new(GET => $url, $header);
my $response = $userAgent->request($request);
if ($response->is_error) {
$self->session->errorHandler->error($url." could not be retrieved.");
$self->session->log->error("$url could not be retrieved.");
if ($debug) {
WebGUI::Error::Connection->throw(
error => "Couldn't fetch $url because ".$response->message,
resource => $url,
);
}
}
else {
$self->set($response->decoded_content,$ttl);
}
return $response->decoded_content;
return $self->set($url, $response->decoded_content, $ttl);
}
#-------------------------------------------------------------------
=head2 stats ( )
=head2 withDebug ()
Return a formatted text string describing cache usage. Must be overridden.
Returns a boolean indicating whether the cache system should log debug, validate parameters, and throw exceptions.
=cut
sub stats {
sub withDebug {
my $self = shift;
return $self->{_withDebug};
}
=head1 EXCEPTIONS
This class throws a lot of inconvenient exceptions. However, because cache should be treated as optional, none of them matter except for testing, debugging, or in very specific use cases. Therefore the best practice is to simply call each method with an eval wrapper, and then not even bother testing for specific exceptions like this:
my $value = eval { $session->cache->get($key) };
unless (defined $value) {
$value = $db->fetchValueFromTheDatabase;
}
If you want to see what exceptions are being thrown, or anything else about the internal operations of the cache system, simply turn on DEBUG mode in your log. Everything you want will be there.
NOTE: In order for exceptions to be thrown and logged with debug must be passed into the constructor.
The exceptions that can be thrown are:
=head2 WebGUI::Error
When an uknown exception happens, or there are no configured memcahed servers in the cacheServers directive in your config file.
=head2 WebGUI::Error::Connection
When it can't connect to the memcached servers that are configured, or to the http server in the case of the setByHttp method.
=head2 WebGUI::Error::InvalidParam
When you pass in the wrong arguments.
=head2 WebGUI::Error::ObjectNotFound
When you request a cache key that doesn't exist on any configured memcached server.
=head2 WebGUI::Error::InvalidObject
When an object can't be thawed from cache due to corruption of some sort.
=cut
1;

204
lib/WebGUI/Exception.pm
View file

@ -15,51 +15,6 @@ package WebGUI::Exception;
=cut
use strict;
use Exception::Class (
'WebGUI::Error' => {
description => "A general error occured.",
},
'WebGUI::Error::OverrideMe' => {
isa => 'WebGUI::Error',
description => 'This method should be overridden by subclasses.',
},
'WebGUI::Error::MethodNotFound' => {
isa => 'WebGUI::Error',
description => q|Called a method that doesn't exist.|,
fields => 'method'
},
'WebGUI::Error::InvalidObject' => {
isa => 'WebGUI::Error::InvalidParam',
description => "Expected to get a reference to an object type that wasn't gotten.",
fields => ["expected","got"],
},
'WebGUI::Error::InvalidParam' => {
isa => 'WebGUI::Error',
description => "Expected to get a param we didn't get.",
fields => ["param"],
},
'WebGUI::Error::ObjectNotFound' => {
isa => 'WebGUI::Error',
description => "The object you were trying to retrieve does not exist.",
fields => ["id"],
},
'WebGUI::Error::ObjectNotFound::Template' => {
isa => 'WebGUI::Error',
description => "The template an asset was trying to retrieve does not exist.",
fields => [qw/templateId assetId/],
},
'WebGUI::Error::InvalidFile' => {
isa => 'WebGUI::Error',
description => "The file you have provided has errors.",
fields => [qw{ brokenFile brokenLine }],
},
'WebGUI::Error::Template' => {
isa => 'WebGUI::Error',
description => "A template has errors that prevent it from being processed.",
},
);
=head1 NAME
@ -94,6 +49,9 @@ B<NOTE>: Though the package name is WebGUI::Exception, the handler objects that
These exception classes are defined in this class:
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error
@ -123,6 +81,30 @@ A read only exception method that returns the line number where the exception wa
A read only exception method that returns the package name where the exception was thrown.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::OverrideMe
An interface was not overriden as expected.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::MethodNotFound
Tried calling a method that doesn't exist.
=head3 method
The method called.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::InvalidObject
Used when looking to make sure objects are passed in that you expect. ISA WebGUI::Error::InvalidParam.
@ -135,6 +117,10 @@ The type of object expected ("HASH", "ARRAY", "WebGUI::User", etc).
The object type we got.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::InvalidParam
Used when an invalid parameter is passed into a subroutine.
@ -143,6 +129,10 @@ Used when an invalid parameter is passed into a subroutine.
Used to return the bad parameter, if present.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::ObjectNotFound
Used when an object is trying to be retrieved, but does not exist. ISA WebGUI::Error.
@ -151,20 +141,132 @@ Used when an object is trying to be retrieved, but does not exist. ISA WebGUI::E
The id of the object to be retrieved.
=head2 WebGUI::Error::MethodNotFound
=cut
Tried calling a method that doesn't exist.
#-------------------------------------------------------------------
=head3 method
=head2 WebGUI::Error::ObjectNotFound::Template
The method called.
Used when a template is trying to be retrieved, but does not exist. ISA WebGUI::Error::ObjectNotFound.
=head2 WebGUI::Error::OverrideMe
=head3 templateId | id | assetId
An interface was not overriden as expected.
The id of the object to be retrieved.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::InvalidFile
Used when accessing a file and there are formatting or data problems found in the file. ISA WebGUI::Error.
=head3 brokenFile
The filename.
=head3 brokenLine
The line the error was found on.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::Template
Used when a template has parsing errors. ISA WebGUI::Error.
=cut
#-------------------------------------------------------------------
=head2 WebGUI::Error::Connection
Used when connecting to an external resource and it fails for some reason. ISA WebGUI::Error.
=head3 resource
The name or configuration or URL of the resource trying to be accessed.
=cut
use Exception::Class (
'WebGUI::Error' => {
description => "A general error occured.",
},
'WebGUI::Error::OverrideMe' => {
isa => 'WebGUI::Error',
description => 'This method should be overridden by subclasses.',
},
'WebGUI::Error::MethodNotFound' => {
isa => 'WebGUI::Error',
description => q|Called a method that doesn't exist.|,
fields => 'method'
},
'WebGUI::Error::InvalidObject' => {
isa => 'WebGUI::Error::InvalidParam',
description => "Expected to get a reference to an object type that wasn't gotten.",
fields => ["expected","got"],
},
'WebGUI::Error::InvalidParam' => {
isa => 'WebGUI::Error',
description => "Expected to get a param we didn't get.",
fields => ["param"],
},
'WebGUI::Error::ObjectNotFound' => {
isa => 'WebGUI::Error',
description => "The object you were trying to retrieve does not exist.",
fields => ["id"],
},
'WebGUI::Error::ObjectNotFound::Template' => {
isa => 'WebGUI::Error',
description => "The template an asset was trying to retrieve does not exist.",
fields => [qw/templateId assetId/],
},
'WebGUI::Error::InvalidFile' => {
isa => 'WebGUI::Error',
description => "The file you have provided has errors.",
fields => [qw{ brokenFile brokenLine }],
},
'WebGUI::Error::Template' => {
isa => 'WebGUI::Error',
description => "A template has errors that prevent it from being processed.",
},
'WebGUI::Error::Connection' => {
isa => 'WebGUI::Error',
description => "Couldn't establish a connection.",
fields => [qw{ resource }],
},
);
1;

18
lib/WebGUI/Group.pm
View file

@ -127,7 +127,7 @@ not be added to any group. Groups may not be added to themselves.
sub addGroups {
my $self = shift;
my $groups = shift;
WebGUI::Cache->new($self->session, $self->getId)->delete;
eval{$self->session->cache->delete($self->getId)};
GROUP: foreach my $gid (@{$groups}) {
next if ($gid eq '1');
next if ($gid eq $self->getId);
@ -232,12 +232,14 @@ sub clearCaches {
my $self = shift;
##Clear my cache and the cache of all groups above me.
my $groups = $self->getAllGroupsFor();
my $cache = $self->session->cache;
foreach my $group ( $self->getId, @{ $groups } ) {
WebGUI::Cache->new($self->session, $group)->delete;
eval{$cache->delete($group)};
}
$self->session->stow->delete("groupObj");
$self->session->stow->delete("isInGroup");
$self->session->stow->delete("gotGroupsInGroup");
my $stow = $self->session->stow;
$stow->delete("groupObj");
$stow->delete("isInGroup");
$stow->delete("gotGroupsInGroup");
}
#-------------------------------------------------------------------
@ -560,8 +562,8 @@ sub getAllUsers {
my $withoutExpired = shift;
my $loopCount = shift;
my $expireTime = 0;
my $cache = WebGUI::Cache->new($self->session, $self->getId);
my $value = $cache->get;
my $cache = $self->session->cache;
my $value = eval{$cache->get($self->getId)};
return $value if defined $value;
my @users = ();
push @users,
@ -586,7 +588,7 @@ sub getAllUsers {
}
my %users = map { $_ => 1 } @users;
@users = keys %users;
$cache->set(\@users, $self->groupCacheTimeout);
eval{$cache->set($self->getId, \@users, $self->groupCacheTimeout)};
return \@users;
}

16
lib/WebGUI/Operation/Cache.pm
View file

@ -12,7 +12,6 @@ package WebGUI::Operation::Cache;
use strict;
use WebGUI::AdminConsole;
use WebGUI::Cache;
use WebGUI::International;
use WebGUI::Form;
@ -93,7 +92,7 @@ sub www_flushCache {
return $session->privilege->adminOnly unless canView($session);
# Flush the cache
WebGUI::Cache->new($session)->flush;
eval{$session->cache->flush};
return www_manageCache($session);
}
@ -110,20 +109,15 @@ provides an option to clear the cache.
sub www_manageCache {
my $session = shift;
return $session->privilege->adminOnly unless canView($session);
my $cache = WebGUI::Cache->new($session);
my $flushURL = $session->url->page('op=flushCache');
my $i18n = WebGUI::International->new($session);
my $output
= '<table>'
. '<tr><td align="right" class="tableHeader">'.$i18n->get('cache type').':</td><td class="tableData">'.ref($cache).'</td></tr>'
. '<tr><td align="right" valign="top" class="tableHeader">'.$i18n->get('cache statistics').':</td><td class="tableData"><pre>'.$cache->stats.'</pre></td></tr>'
. '<tr><td align="right" valign="top" class="tableHeader">&nbsp;</td><td class="tableData">'
. WebGUI::Form::button($session, {
my $output =
WebGUI::Form::formHeader($session)
.WebGUI::Form::button($session, {
value => $i18n->get("clear cache"),
extras => qq{onclick="document.location.href='$flushURL';"},
})
. '</td></tr>'
. '</table>'
.WebGUI::Form::formFooter($session)
;
return _submenu($session,$output);

3
lib/WebGUI/Operation/Settings.pm
View file

@ -726,8 +726,7 @@ sub www_saveSettings {
$session->db->write(
"UPDATE userProfileData SET showMessageOnLoginSeen=0"
);
# Delete the user cache
WebGUI::Cache->new( $session, [ "user" ] )->deleteChunk( [ "user" ] );
eval{$session->cache->flush};
}
return www_editSettings($session, { errors => \@errors, message => $i18n->get("editSettings done") });

7
lib/WebGUI/Operation/Statistics.pm
View file

@ -12,7 +12,6 @@ package WebGUI::Operation::Statistics;
use strict;
use WebGUI::AdminConsole;
use WebGUI::Cache;
use WebGUI::International;
use WebGUI::Workflow::Cron;
use WebGUI::DateTime;
@ -180,10 +179,10 @@ sub www_viewStatistics {
my ($output, $data);
my $i18n = WebGUI::International->new($session);
my $url = "http://update.webgui.org/latest-version.txt";
my $cache = WebGUI::Cache->new($session,$url,"URL");
my $version = $cache->get;
my $cache = $session->cache;
my $version = eval{$cache->get($url)};
if (not defined $version) {
$version = $cache->setByHTTP($url,43200);
$version = eval{$cache->setByHttp($url, 43200)};
}
chomp $version;
$output .= '<table>';

26
lib/WebGUI/Session.pm
View file

@ -15,6 +15,7 @@ package WebGUI::Session;
=cut
use strict;
use WebGUI::Cache;
use WebGUI::Config;
use WebGUI::SQL;
use WebGUI::User;
@ -109,6 +110,28 @@ sub asset {
#-------------------------------------------------------------------
=head2 cache ( )
Returns a WebGUI::Cache object, which is connected to the WebGUI memcached server.
=cut
sub cache {
my $self = shift;
unless (exists $self->{_cache}) {
my $cache = WebGUI::Cache->new($self);
if (defined $cache) {
$self->{_cache} = $cache;
}
else {
$self->log->fatal("Couldn't connect to WebGUI memcached server, and can't continue without it.");
}
}
return $self->{_cache};
}
#-------------------------------------------------------------------
=head2 close
Cleans up a WebGUI session information from memory and disconnects from any resources opened by the session.
@ -121,7 +144,7 @@ sub close {
# Kill circular references. The literal list is so that the order
# can be explicitly shuffled as necessary.
foreach my $key (qw/_asset _datetime _icon _slave _db _env _form _http _id _output _os _privilege _scratch _setting _stow _style _url _user _var _errorHandler/) {
foreach my $key (qw/_asset _datetime _icon _slave _db _env _form _http _id _output _os _privilege _scratch _setting _stow _style _url _user _var _cache _errorHandler/) {
delete $self->{$key};
}
}
@ -445,7 +468,6 @@ sub open {
$sessionId = $self->id->generate unless $self->id->valid($sessionId);
my $noFuss = shift;
$self->{_var} = WebGUI::Session::Var->new($self,$sessionId, $noFuss);
$self->errorHandler->warn("You've disabled cache in your config file and that can cause many problems on a production site.") if ($config->get("disableCache"));
return $self;
}

40
lib/WebGUI/Session/Scratch.pm
View file

@ -62,7 +62,10 @@ sub delete {
my $name = shift;
return undef unless ($name);
my $value = delete $self->{_data}{$name};
$self->session->db->write("delete from userSessionScratch where name=? and sessionId=?", [$name, $self->session->getId]);
my $session = $self->session;
my $id = $session->getId;
eval{$session->cache->set(["sessionscratch",$id], $self->{_data}, $session->setting->get('sessionTimeout'))};
$session->db->write("delete from userSessionScratch where name=? and sessionId=?", [$name, $id]);
return $value;
}
@ -78,7 +81,10 @@ Deletes all scratch variables for this session.
sub deleteAll {
my $self = shift;
delete $self->{_data};
$self->session->db->write("delete from userSessionScratch where sessionId=?", [$self->session->getId]);
my $session = $self->session;
my $id = $session->getId;
eval{$session->cache->delete(["sessionscratch",$id])};
$session->db->write("delete from userSessionScratch where sessionId=?", [$id]);
}
@ -99,7 +105,9 @@ sub deleteName {
my $name = shift;
return undef unless ($name);
delete $self->{_data}{$name};
$self->session->db->write("delete from userSessionScratch where name=?", [$name]);
my $session = $self->session;
eval{$session->cache->flush};
$session->db->write("delete from userSessionScratch where name=?", [$name]);
}
#-------------------------------------------------------------------
@ -124,7 +132,9 @@ sub deleteNameByValue {
my $value = shift;
return undef unless ($name and defined $value);
delete $self->{_data}{$name} if ($self->{_data}{$name} eq $value);
$self->session->db->write("delete from userSessionScratch where name=? and value=?", [$name,$value]);
my $session = $self->session;
eval{$session->cache->flush};
$session->db->write("delete from userSessionScratch where name=? and value=?", [$name,$value]);
}
@ -155,8 +165,7 @@ The name of the variable.
=cut
sub get {
my $self = shift;
my $var = shift;
my ($self, $var) = @_;
return $self->{_data}{$var};
}
@ -174,10 +183,12 @@ The current session.
=cut
sub new {
my $class = shift;
my $session = shift;
my $data = $session->db->buildHashRef("select name,value from userSessionScratch where sessionId=?",[$session->getId], {noOrder => 1});
bless {_session=>$session, _data=>$data}, $class;
my ($class, $session) = @_;
my $scratch = eval{$session->cache->get(["sessionscratch",$session->getId])};
unless (ref $scratch eq "HASH") {
$scratch = $session->db->buildHashRef("select name,value from userSessionScratch where sessionId=?",[$session->getId], {noOrder => 1});
}
bless {_session=>$session, _data=>$scratch}, $class;
}
@ -212,12 +223,13 @@ The value of the scratch variable. Must be a string no longer than 16000 charac
=cut
sub set {
my $self = shift;
my $name = shift;
my $value = shift;
my ($self, $name, $value) = @_;
return undef unless ($name);
$self->{_data}{$name} = $value;
$self->session->db->write("insert into userSessionScratch (sessionId, name, value) values (?,?,?) on duplicate key update value=VALUES(value)", [$self->session->getId, $name, $value]);
my $session = $self->session;
my $id = $session->getId;
eval{$session->cache->set(["sessionscratch",$id], $self->{_data}, $session->setting->get('sessionTimeout'))};
$session->db->write("replace into userSessionScratch (sessionId, name, value) values (?,?,?)", [$id, $name, $value]);
}

3
lib/WebGUI/Session/Stow.pm
View file

@ -118,7 +118,6 @@ sub get {
my $self = shift;
my $var = shift;
my $opt = shift || {};
return undef if $self->session->config->get("disableCache");
my $value = $self->{_data}{$var};
return undef unless defined $value;
my $ref = ref $value;
@ -190,8 +189,6 @@ The value of the stow variable. Any scalar or reference.
sub set {
my $self = shift;
$self->session->errorHandler->debug('Stow->set() is being called but cache has been disabled')
if $self->session->config->get("disableCache");
my $name = shift;
my $value = shift;
return undef unless ($name);

76
lib/WebGUI/Session/Var.pm
View file

@ -56,7 +56,6 @@ Deconstructor.
sub DESTROY {
my $self = shift;
undef $self;
}
@ -69,10 +68,13 @@ Removes the specified user session from memory and database.
=cut
sub end {
my $self = shift;
$self->session->scratch->deleteAll;
$self->session->db->write("delete from userSession where sessionId=?",[$self->getId]);
delete $self->session->{_user};
my $self = shift;
my $session = $self->session;
my $id = $self->getId;
eval{$session->cache->delete(['session',$id])};
$session->scratch->deleteAll;
$session->db->write("delete from userSession where sessionId=?",[$id]);
delete $session->{_user};
$self->DESTROY;
}
@ -168,16 +170,16 @@ normally be used by anyone.
=cut
sub new {
my $class = shift;
my $session = shift;
my ($class, $session, $sessionId, $noFuss) = @_;
my $self = bless {_session=>$session}, $class;
my $sessionId = shift;
my $noFuss = shift;
if ($sessionId eq "") { ##New session
$self->start(1);
}
else { ##existing session requested
$self->{_var} = $session->db->quickHashRef("select * from userSession where sessionId=?",[$sessionId]);
$self->{_var} = eval{$session->cache->get(['session',$sessionId])};
unless ($self->{_var}{sessionId} eq $sessionId) {
$self->{_var} = $session->db->quickHashRef("select * from userSession where sessionId=?",[$sessionId]);
}
##We have to make sure that the session variable has a sessionId, otherwise downstream users of
##the object will break
if ($noFuss && $self->{_var}{sessionId}) {
@ -189,11 +191,20 @@ sub new {
$self->start(1,$sessionId);
}
elsif ($self->{_var}{sessionId} ne "") { ##Fetched an existing session. Update variables with recent data.
$self->{_var}{lastPageView} = $session->datetime->time();
my $time = $session->datetime->time();
my $timeout = $session->setting->get("sessionTimeout");
$self->{_var}{lastPageView} = $time;
$self->{_var}{lastIP} = $session->env->getIp;
$self->{_var}{expires} = $session->datetime->time() + $session->setting->get("sessionTimeout");
$self->{_var}{expires} = $time + $timeout;
if ($self->{_var}{nextCacheFlush} > 0 && $self->{_var}{nextCacheFlush} < $time) {
delete $self->{_var}{nextCacheFlush};
$session->db->setRow("userSession","sessionId",$self->{_var});
}
else {
$self->{_var}{nextCacheFlush} = $time + $session->config->get("hotSessionFlushToDb");
eval{$session->cache->set(['session',$sessionId], $self->{_var}, $timeout)};
}
$self->session->{_sessionId} = $self->{_var}{sessionId};
$session->db->setRow("userSession","sessionId",$self->{_var});
return $self;
}
else { ##Start a new default session with the requested, non-existant id.
@ -240,19 +251,24 @@ sub start {
my $userId = shift;
$userId = 1 if ($userId eq "");
my $sessionId = shift;
$sessionId = $self->session->id->generate if ($sessionId eq "");
my $time = $self->session->datetime->time();
my $session = $self->session;
my $id = $session->id;
$sessionId = $id->generate if ($sessionId eq "");
my $timeout = $session->setting->get('sessionTimeout');
my $time = $session->datetime->time();
$self->{_var} = {
expires => $time + $self->session->setting->get("sessionTimeout"),
expires => $time + $timeout,
lastPageView => $time,
lastIP => $self->session->env->getIp,
lastIP => $session->env->getIp,
adminOn => 0,
userId => $userId
};
$self->{_var}{sessionId} = $sessionId;
$self->session->db->setRow("userSession","sessionId",$self->{_var},$sessionId);
$self->session->{_sessionId} = $sessionId;
$self->session->scratch->set('webguiCsrfToken', $self->session->id->generate);
$self->session->{_sessionId} = $sessionId;
eval{$session->cache->set(['session',$sessionId], $self->{_var}, $timeout)};
delete $self->{_var}{nextCacheFlush};
$session->db->setRow("userSession","sessionId",$self->{_var},$sessionId);
$self->{_sessionId} = $sessionId;
$session->scratch->set('webguiCsrfToken', $id->generate); # create cross site request forgery token
}
#-------------------------------------------------------------------
@ -264,9 +280,12 @@ Disables admin mode.
=cut
sub switchAdminOff {
my $self = shift;
$self->{_var}{adminOn} = 0;
$self->session->db->setRow("userSession","sessionId", $self->{_var});
my $self = shift;
$self->{_var}{adminOn} = 0;
my $session = $self->session;
eval{$session->cache->set(['session',$self->getId], $self->{_var}, $session->setting->get('sessionTimeout'))};
delete $self->{_var}{nextCacheFlush};
$session->db->setRow("userSession","sessionId", $self->{_var});
}
#-------------------------------------------------------------------
@ -278,9 +297,12 @@ Enables admin mode.
=cut
sub switchAdminOn {
my $self = shift;
$self->{_var}{adminOn} = 1;
$self->session->db->setRow("userSession","sessionId", $self->{_var});
my $self = shift;
$self->{_var}{adminOn} = 1;
my $session = $self->session;
eval{$session->cache->set(['session',$self->getId], $self->{_var}, $session->setting->get('sessionTimeout'))};
delete $self->{_var}{nextCacheFlush};
$self->session->db->setRow("userSession","sessionId", $self->{_var});
}

10
lib/WebGUI/User.pm
View file

@ -15,7 +15,6 @@ package WebGUI::User;
=cut
use strict;
use WebGUI::Cache;
use WebGUI::Group;
use WebGUI::DatabaseLink;
use WebGUI::Exception;
@ -282,13 +281,12 @@ Saves the user object into the cache.
sub cache {
my $self = shift;
my $cache = WebGUI::Cache->new($self->session,["user",$self->userId]);
# copy user object
my %userData;
for my $k (qw(_userId _user _profile)) {
$userData{$k} = $self->{$k};
}
$cache->set(\%userData, 60*60*24);
eval{$self->session->cache->set(["user",$self->userId], \%userData, 60*60*24)};
}
#-------------------------------------------------------------------
@ -1062,8 +1060,7 @@ sub new {
my $userId = shift || 1;
my $overrideId = shift;
$userId = _create($session, $overrideId) if ($userId eq "new");
my $cache = WebGUI::Cache->new($session,["user",$userId]);
my $self = $cache->get || {};
my $self = eval{$session->cache->get(["user",$userId])} || {};
bless $self, $class;
$self->{_session} = $session;
unless ($self->{_userId} && $self->{_user}{username}) {
@ -1337,8 +1334,7 @@ Deletes this user object out of the cache.
sub uncache {
my $self = shift;
my $cache = WebGUI::Cache->new($self->session,["user",$self->userId]);
$cache->delete;
eval{$self->session->cache->delete(["user",$self->userId])};
}
#----------------------------------------------------------------------------

94
lib/WebGUI/Workflow/Activity/CleanDatabaseCache.pm
View file

@ -1,94 +0,0 @@
package WebGUI::Workflow::Activity::CleanDatabaseCache;
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=cut
use strict;
use base 'WebGUI::Workflow::Activity';
use WebGUI::Cache::Database;
=head1 NAME
Package WebGUI::Workflow::Activity::CleanDatabaseCache
=head1 DESCRIPTION
This activity deletes entries from the database cache if the cache size has gotten too big.
=head1 SYNOPSIS
See WebGUI::Workflow::Activity for details on how to use any activity.
=head1 METHODS
These methods are available from this class:
=cut
#-------------------------------------------------------------------
=head2 definition ( session, definition )
See WebGUI::Workflow::Activity::definition() for details.
=cut
sub definition {
my $class = shift;
my $session = shift;
my $definition = shift;
my $i18n = WebGUI::International->new($session, "Workflow_Activity_CleanDatabaseCache");
push(@{$definition}, {
name=>$i18n->get("activityName"),
properties=> {
sizeLimit => {
fieldType=>"integer",
label=>$i18n->get("size limit"),
subtext=>$i18n->get("bytes"),
defaultValue=>100000000,
hoverHelp=>$i18n->get("size limit help")
}
}
});
return $class->SUPER::definition($session,$definition);
}
#-------------------------------------------------------------------
=head2 execute ( )
See WebGUI::Workflow::Activity::execute() for details.
=cut
sub execute {
my $self = shift;
my $size = $self->get("sizeLimit") + 10;
my $expiresModifier = 0;
my $cache = WebGUI::Cache::Database->new($self->session);
while ($size > $self->get("sizeLimit")) {
$size = $cache->getNamespaceSize($expiresModifier);
$expiresModifier += 60 * 30; # add 30 minutes each pass
}
return $self->COMPLETE;
}
1;

107
lib/WebGUI/Workflow/Activity/CleanFileCache.pm
View file

@ -1,107 +0,0 @@
package WebGUI::Workflow::Activity::CleanFileCache;
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=cut
use strict;
use base 'WebGUI::Workflow::Activity';
use WebGUI::Cache::FileCache;
=head1 NAME
Package WebGUI::Workflow::Activity::CleanFileCache
=head1 DESCRIPTION
This activity deletes files from the file cache if the file cache has gotten too big.
=head1 SYNOPSIS
See WebGUI::Workflow::Activity for details on how to use any activity.
=head1 METHODS
These methods are available from this class:
=cut
#-------------------------------------------------------------------
=head2 definition ( session, definition )
See WebGUI::Workflow::Activity::definition() for details.
=cut
sub definition {
my $class = shift;
my $session = shift;
my $definition = shift;
my $i18n = WebGUI::International->new($session, "Workflow_Activity_CleanFileCache");
push(@{$definition}, {
name=>$i18n->get("activityName"),
properties=> {
sizeLimit => {
fieldType=>"integer",
label=>$i18n->get("size limit"),
subtext=>$i18n->get("bytes"),
defaultValue=>100000000,
hoverHelp=>$i18n->get("size limit help")
}
}
});
return $class->SUPER::definition($session,$definition);
}
#-------------------------------------------------------------------
=head2 execute ( )
See WebGUI::Workflow::Activity::execute() for details.
=cut
sub execute {
my $self = shift;
my $size = $self->get("sizeLimit") + 10;
my $expiresModifier = 0;
# Purge expired content cache
my $cache = WebGUI::Cache::FileCache->new($self->session);
while ($size > $self->get("sizeLimit")) {
$size = $cache->getNamespaceSize($expiresModifier);
$expiresModifier += 60 * 30; # add 30 minutes each pass
}
$size = $self->get("sizeLimit") + 10;
$expiresModifier = 0;
# Purge expired rss cache
my $rssCache = WebGUI::Cache::FileCache->new($self->session, undef, 'RSS');
while ($size > $self->get("sizeLimit")) {
$size = $rssCache->getNamespaceSize($expiresModifier);
$expiresModifier += 60 * 30; # add 30 minutes each pass
}
return $self->COMPLETE;
}
1;

8
lib/WebGUI/i18n/English/WebGUI.pm
View file

@ -3463,14 +3463,6 @@ a user.|,
message => q|Cache|,
lastUpdated => 1031514049
},
'cache type' => {
message => q|Cache type|,
lastUpdated => 1031514049
},
'cache statistics' => {
message => q|Cache Statistics|,
lastUpdated => 1031514049
},
'clear cache' => {
message => q|Clear Cache|,
lastUpdated => 1031514049

1
sbin/preload.exclude.example
View file

@ -2,7 +2,6 @@
# that you don't want to be loaded by modperl. This will decrease the overall
# size of your modperl instances, which will increase performance, and reduce
# memory use.
WebGUI::Cache::Database
WebGUI::Auth::LDAP
WebGUI::Asset::Wobject::WSClient
WebGUI::Asset::File::ZipArchive

1
sbin/testEnvironment.pl
View file

@ -133,6 +133,7 @@ checkModule('Digest::SHA', '5.47' );
checkModule("CSS::Minifier::XS", "0.03" );
checkModule("JavaScript::Minifier::XS", "0.05" );
checkModule("Readonly", "1.03" );
checkModule("Memcached::libmemcached", "0.3102" );
failAndExit("Required modules are missing, running no more checks.") if $missingModule;

145
t/Cache.t Normal file
View file

@ -0,0 +1,145 @@
# vim:syntax=perl
#-------------------------------------------------------------------
# WebGUI is Copyright 2001-2009 Plain Black Corporation.
#-------------------------------------------------------------------
# Please read the legal notices (docs/legal.txt) and the license
# (docs/license.txt) that came with this distribution before using
# this software.
#------------------------------------------------------------------
# http://www.plainblack.com info@plainblack.com
#------------------------------------------------------------------
# Write a little about what this script tests.
#
#
use FindBin;
use strict;
use lib "$FindBin::Bin/lib";
use Test::More;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
use WebGUI::Cache;
#----------------------------------------------------------------------------
# Init
my $session = WebGUI::Test->session;
#----------------------------------------------------------------------------
# Tests
plan tests => 11; # Increment this number for each test you create
#----------------------------------------------------------------------------
my $cache = WebGUI::Cache->new($session, 1);
isa_ok($cache, 'WebGUI::Cache');
is($cache->parseKey("andy"), $session->config->getFilename.":andy", "parseKey single key");
is($cache->parseKey(["andy","red"]), $session->config->getFilename.":andy:red", "parseKey composite key");
$cache->set("Shawshank","Prison");
is($cache->get("Shawshank"), "Prison", "set/get");
$cache->set(["andy", "dufresne"], "Prisoner");
is($cache->get(["andy", "dufresne"]), "Prisoner", "set/get composite");
my ($a, $b) = @{$cache->mget(["Shawshank",["andy", "dufresne"]])};
is($a, "Prison", "mget first value");
is($b, "Prisoner", "mget second value");
$cache->delete("Shawshank");
is(eval{$cache->get("Shawshank")}, undef, 'delete');
$cache->flush;
is(eval{$cache->get(["andy", "dufresne"])}, undef, 'flush');
$cache->setByHttp("http://www.google.com/");
cmp_ok($cache->get("http://www.google.com/"), 'ne', '', 'setByHttp');
my $longValue ='abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
abcdefghijklmnopqrstuvwxyz 0123456789 !@#$%^&*(
';
$cache->set("really-long-value",$longValue);
is($cache->get("really-long-value"), $longValue, "set/get really long value");
#----------------------------------------------------------------------------
# Cleanup
END {
}
#vim:ft=perl

22
t/Session/Stow.t
View file

@ -15,7 +15,7 @@ use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::Session;
use Test::More tests => 35; # increment this value for each test you create
use Test::More tests => 33; # increment this value for each test you create
my $session = WebGUI::Test->session;
@ -25,9 +25,6 @@ my $stow = $session->stow;
my $count = 0;
my $maxCount = 20;
my $disableCache = $session->config->get('disableCache');
$session->config->set('disableCache',0);
for (my $count = 1; $count <= $maxCount; $count++){
$stow->set("Test$count",$count);
}
@ -41,22 +38,8 @@ is($stow->get("Test1"), undef, "delete()");
$stow->deleteAll;
is($stow->get("Test2"), undef, "deleteAll()");
####################################################
#
# get, set with disableCache
#
####################################################
$session->config->set('disableCache', 1);
is($stow->get('Test2'), undef, 'get: when config->disableCache is set get returns undef');
WebGUI::Test->interceptLogging();
$stow->set('unavailableVariable', 'too bad');
is($WebGUI::Test::logger_debug, 'Stow->set() is being called but cache has been disabled', 'debug emitted by set when disableCache is true');
$session->config->set('disableCache', 0);
is($session->stow->set('', 'null string'), undef, 'set returns undef when name is empty string');
is($session->stow->set(0, 'zero'), undef, 'set returns undef when name is zero');
@ -99,6 +82,3 @@ is( $session->stow->get( 'possibilities', { noclone => 1 } ), $arr,
"With noclone returns same reference"
);
END {
$session->config->set('disableCache',$disableCache);
}

6
t/Session/Var.t
View file

@ -129,10 +129,16 @@ $var->end;
##by looking for admin status and userId
$var2 = WebGUI::Session::Var->new($session);
$var2->switchAdminOn;
# jury rig the database and the cache to expire
$session->db->write("update userSession set userId=? where sessionId=?",
[3, $var2->getId]);
$session->db->write("update userSession set expires=? where sessionId=?",
[$var2->get('lastPageView')-1, $var2->getId]);
my %copyOfVar2 = %{$var2->{_var}};
$copyOfVar2{expires} = $var2->get('lastPageView')-1;
$copyOfVar2{userId} = 3;
$session->cache->set(['session',$var2->getId], \%copyOfVar2);
my $var3 = WebGUI::Session::Var->new($session, $var2->getId);
is($var3->getId, $var2->getId, 'new Var object has correct id');

7
t/lib/WebGUI/Test.pm
View file

@ -32,9 +32,10 @@ BEGIN {
if ( $^O eq 'darwin' && $Config::Config{osvers} lt '8.0.0' ) {
unshift @INC, sub {
return undef unless $_[1] =~ m/^Apache2|APR/;
my $buffer = '1';
open my $fh, '<', \$buffer;
return $fh;
return IO::File->new( $INC{'Class/Null.pm'}, &IO::File::O_RDONLY );
#my $buffer = '1';
#open my $fh, '<', \$buffer;
#return $fh;
};
no warnings 'redefine';