fixed a few things in the new caching system

docs/changelog/6.x.x.txt

@@ -21,6 +21,8 @@
  - Enhanced aggregation features of the SyndicatedContent wobject, including
    keyword filtering, content republishing, XSLT stylesheet support and 
    different "display modes".
+ - Wrote a whole new caching system for WebGUI that is up to 10 times more
+   efficient than the old caching system.
 
 
 6.6.3

lib/WebGUI/Asset.pm

@@ -318,14 +318,12 @@ sub cascadeLineage {
 	my $now = time();
         my $prepared = WebGUI::SQL->prepare("update asset set lineage=? where assetId=?");
 	my $descendants = WebGUI::SQL->read("select assetId,lineage from asset where lineage like ".quote($oldLineage.'%'));
+	my $cache = WebGUI::Cache->new;
 	while (my ($assetId, $lineage) = $descendants->array) {
 		my $fixedLineage = $newLineage.substr($lineage,length($oldLineage));
 		$prepared->execute([$fixedLineage,$assetId]);
-		my $sth = WebGUI::SQL->read("select assetId,revisionDate from assetData where asset=".quote($assetId));
+                # we do the purge directly cuz it's a lot faster than instanciating all these assets
-		while (my ($id,$version) = $sth->array) {
+                $cache->deleteChunk(["asset",$assetId]);
-			WebGUI::Cache->new("asset_".$id."/".$version)->delete;
-		}
-		$sth->finish;
 	}
 	$descendants->finish;
 }
@@ -1153,11 +1151,7 @@ Returns the highest rank, top of the highest rank Asset under current Asset.
 sub getFirstChild {
 	my $self = shift;
 	unless (exists $self->{_firstChild}) {
-		my $lineage = WebGUI::Cache->new("firstchild_".$self->getId)->get;
+		my ($lineage) = WebGUI::SQL->quickArray("select min(lineage) from asset where parentId=".quote($self->getId));
-		unless ($lineage) {
-			($lineage) = WebGUI::SQL->quickArray("select min(lineage) from asset where parentId=".quote($self->getId));
-			WebGUI::Cache->new("firstchild_".$self->getId)->set($lineage);
-		}
 		$self->{_firstChild} = WebGUI::Asset->newByLineage($lineage);
 	}
 	return $self->{_firstChild};
@@ -1232,11 +1226,7 @@ Returns the lowest rank, bottom of the lowest rank Asset under current Asset.
 sub getLastChild {
 	my $self = shift;
 	unless (exists $self->{_lastChild}) {
-		my $lineage = WebGUI::Cache->new("lastchild_".$self->getId)->get;
+		my ($lineage) = WebGUI::SQL->quickArray("select max(lineage) from asset where parentId=".quote($self->getId));
-		unless ($lineage) {
-			($lineage) = WebGUI::SQL->quickArray("select max(lineage) from asset where parentId=".quote($self->getId));
-			WebGUI::Cache->new("lastchild_".$self->getId)->set($lineage);
-		}
 		$self->{_lastChild} = WebGUI::Asset->newByLineage($lineage);
 	}
 	return $self->{_lastChild};
@@ -1871,11 +1861,8 @@ sub new {
 		}
 		$class = $className;
 	}
-	my $properties = $session{assetprops}{$assetId}{$revisionDate};
+	my $cache = WebGUI::Cache->new(["asset",$assetId,$revisionDate]);
-	#	$properties = WebGUI::Cache->new("asset_".$assetId."/".$revisionDate)->get;
+	my $properties = $cache->get;
-#	if ( $session{assetcache}{$assetId}{$revisionDate}) {
-#		return $session{assetcache}{$assetId}{$revisionDate};
-#	}
 	if (exists $properties->{assetId}) {
 		# got properties from cache
 	} else { 
@@ -1887,13 +1874,11 @@ sub new {
 		$sql .= " where asset.assetId=".quote($assetId);
 		$properties = WebGUI::SQL->quickHashRef($sql);
 		return undef unless (exists $properties->{assetId});
-	#	WebGUI::Cache->new("asset_".$assetId."/".$revisionDate)->set($properties,60*60*24);
+		$cache->set($properties,60*60*24);
-		$session{assetprops}{$assetId}{$revisionDate} = $properties;
 	}
 	if (defined $properties) {
 		my $object = { _properties => $properties };
 		bless $object, $class;
-	#	$session{assetcache}{$assetId}{$revisionDate} = $object;
 		return $object;
 	}	
 	return undef;
@@ -2038,12 +2023,11 @@ sub paste {
 		my $assetIds = WebGUI::SQL->buildArrayRef("select assetId from asset where lineage like ".quote($self->get("lineage").'%')." and (state='clipboard' or state='clipboard-limbo')");
 		my $idList = quoteAndJoin($assetIds);
 		WebGUI::SQL->write("update asset set state='published', stateChangedBy=".quote($session{user}{userId}).", stateChanged=".time()." where assetId in (".$idList.")");
-		my $sth = WebGUI::SQL->read("select assetId,revisionDate from assetData where assetId in (".$idList.")");
+		my $cache = WebGUI::Cache->new;
-		while ( my ($id,$version) = $sth->array) {
+		foreach my $id (@{$assetIds}) {
 			# we do the purge directly cuz it's a lot faster than instanciating all these assets
-			WebGUI::Cache->new("asset_".$id."/".$version)->delete;
+			$cache->deleteChunk(["asset",$id]);
 		}
-		$sth->finish;
 		$pastedAsset->updateHistory("pasted to parent ".$self->getId);
 		return 1;
 	}
@@ -2177,12 +2161,11 @@ sub publish {
 	my $assetIds = WebGUI::SQL->buildArrayRef("select assetId from asset where lineage like ".quote($self->get("lineage").'%'));
         my $idList = quoteAndJoin($assetIds);
         WebGUI::SQL->write("update asset set state='published', stateChangedBy=".quote($session{user}{userId}).", stateChanged=".time()." where assetId in (".$idList.")");
-        my $sth = WebGUI::SQL->read("select assetId,revisionDate from assetData where assetId in (".$idList.")");
+	my $cache = WebGUI::Cache->new;
-        while ( my ($id,$version) = $sth->array) {
+        foreach my $id (@{$assetIds}) {
         	# we do the purge directly cuz it's a lot faster than instanciating all these assets
-                WebGUI::Cache->new("asset_".$id."/".$version)->delete;
+                $cache->deleteChunk(["asset",$id]);
         }
-        $sth->finish;
 	$self->{_properties}{state} = "published";
 }
 
@@ -2204,6 +2187,7 @@ sub purge {
 	WebGUI::SQL->write("delete from asset where assetId=".quote($self->getId));
 	WebGUI::SQL->commit;
 	$self->purgeCache;
+	WebGUI::Cache->new->deleteChunk(["asset",$self->getId]);
 	$self->updateHistory("purged");
 	$self = undef;
 }
@@ -2234,17 +2218,15 @@ sub purgeRevision {
 
 #-------------------------------------------------------------------
 
-=head2 purgeTree ( )
+=head2 purgeCache ( )
 
-Purges all cache entries associated with this asset.
+Purges all cache entries associated with this revision.
 
 =cut
 
 sub purgeCache {
 	my $self = shift;
-	WebGUI::Cache->new("asset_".$self->getId."/".$self->get("revisionDate"))->delete;
+	WebGUI::Cache->new(["asset",$self->getId,$self->get("revisionDate")])->delete;
-	delete $session{assetcache}{$self->getId};
-	delete $session{assetprops}{$self->getId};
 }
 
 #-------------------------------------------------------------------

lib/WebGUI/Cache/FileCache.pm

@@ -52,7 +52,7 @@ Remove content from the filesystem cache.
 
 sub delete {
 	my $self = shift;
-	rmtree($self->{_cachefolder});
+	rmtree($self->getFolder());
 }
 
 #-------------------------------------------------------------------
@@ -70,7 +70,7 @@ A partial composite key to remove.
 sub deleteChunk {
 	my $self = shift;
 	my $key = $self->parseKey(shift);
-	rmtree($self->getCacheRoot()."/".$self->{_namespace}."/".$key);
+	rmtree($self->getNamespaceRoot()."/".$key);
 }
 
 #-------------------------------------------------------------------
@@ -84,7 +84,7 @@ Remove all objects from the filecache system.
 sub flush {
 	my $self = shift;
 	$self->SUPER::flush();
-	rmtree($self->getCacheRoot."/".$self->{_namespace});
+	rmtree($self->getNamespaceRoot);
 }
 
 #-------------------------------------------------------------------
@@ -98,25 +98,44 @@ Retrieve content from the filesystem cache.
 sub get {
 	my $self = shift;
 	return undef if ($session{config}{disableCache});
-	if (open(FILE,"<".$self->{_cachefolder}."/expires")) {
+	if (open(FILE,"<".$self->getFolder()."/expires")) {
 		my $expires = <FILE>;
 		close(FILE);
 		return undef if ($expires < time());
-		return retrieve($self->{_cachefolder}."/cache");
+		my $value;
+		eval {$value = retrieve($self->getFolder()."/cache")};
+		if (ref $value eq "SCALAR") {
+			return $$value;
+		} else {
+			return $value;
+		}
 	}
 	return undef;
 }
 
 #-------------------------------------------------------------------
 
-=head2 getCacheRoot ( )
+=head getFolder ( )
 
-Figures out what the cache root should be. A class method.
+Returns the path to the cache folder for this key.
 
 =cut
 
-sub getCacheRoot {
+sub getFolder {
-	my $class = shift;
+	my $self = shift;
+	return $self->getNamespaceRoot()."/".$self->{_key};
+}
+
+#-------------------------------------------------------------------
+
+=head2 getNamepsaceRoot ( )
+
+Figures out what the cache root for this namespace should be. A class method.
+
+=cut
+
+sub getNamespaceRoot {
+	my $self = shift;
 	my $root = $session{config}{fileCacheRoot};
 	unless ($root) {
 		if ($session{os}{windowsish}) {
@@ -126,9 +145,45 @@ sub getCacheRoot {
 		}
 		$root .= "/WebGUICache";
 	}
+	$root .= "/".$self->{_namespace};
 	return $root;	
 }
 
+#-------------------------------------------------------------------
+
+=head2 getNamespaceSize ( )
+
+Returns the size (in bytes) of the current cache under this namespace. Consequently it also cleans up expired cache items.
+
+=cut
+
+sub getNamespaceSize {
+        my $self = shift;
+        my $expiresModifier = shift || 0;
+        my $path = shift || $self->getNamespaceRoot;
+        my $filesRmaining;
+        if (opendir(DIR,$path)) {
+                my @files = readdir(DIR);
+                foreach my $file (@files) {
+                        unless ($file eq "." || $file eq "..") {
+                                if (open(FILE,"<".$path."/expires")) {
+                                        my $expires = <FILE>;
+                                        close(FILE);
+                                        if ($expires < time()+$expiresModifier) {
+                                                rmtree($path); 
+                                        } else {
+                                                my (@attributes) = stat($self->getPath($filename));
+                                                $filesRemaining += $attributes[7];
+                                        }
+                                } else {
+                                        $filesRemaining += $self->getNamespaceSize($expiresModifier,$path."/".$file);
+                                }
+                        }
+                }
+                closedir(DIR);
+        }
+        return $filesRemaining;
+}
 
 #-------------------------------------------------------------------
 
@@ -151,8 +206,7 @@ sub new {
 	my $class = shift;
 	my $key = $class->parseKey(shift);
 	my $namespace = shift || $session{config}{configFile};
-	my $path = $class->getCacheRoot()."/".$namespace."/".$key;
+	bless {_key=>$key, _namespace=>$namespace}, $class;
-	bless {_cachefolder => $path, _key=>$key, _namespace=>$namespace}, $class;
 }
 
 
@@ -176,7 +230,7 @@ sub set {
 	my $self = shift;
 	my $content = shift;
 	my $ttl = shift || 60;
-	my $path = $self->{_cachefolder};
+	my $path = $self->getFolder();
 	unless (-e $path) {
 		eval {mkpath($path)};
 		if ($@) {
@@ -184,7 +238,13 @@ sub set {
 			return;
 		}
 	}
-	nstore($content, $path."/cache");
+	my $value;
+	unless (ref $content) {
+		$value = \$content;
+	} else {
+		$value = $content;
+	}
+	nstore($value, $path."/cache");
 	open(FILE,">".$path."/expires");
 	print FILE time()+$ttl;
 	close(FILE);
@@ -201,7 +261,7 @@ Returns statistic information about the caching system.
 
 sub stats {
         my $self = shift;
-	return undef;
+	return $self->getNamespaceSize." bytes";
 }
 
 1;

sbin/Hourly/CleanFileCache.pm

@@ -13,32 +13,18 @@ package Hourly::CleanFileCache;
 use strict;
 use WebGUI::Session;
 use WebGUI::Cache::FileCache;
-use File::Path;
 
 #-------------------------------------------------------------------
 sub process {
-	traverse(WebGUI::Cache::FileCache->getCacheRoot);	
+	my $size = $session{config}{fileCacheSizeLimit} + 10;
+	my $expiresModifier = 0;
+	my $cache = WebGUI::Cache::FileCache->new;
+	while ($size > $session{config}{fileCacheSizeLimit}) {
+		$size = $cache->getNamespaceSize($expiresModifier);	
+		$expiresModifier += 600; # add 10 minutes each pass
+	}
 }
 
-#-------------------------------------------------------------------
-sub traverse {
-	my $path = shift;
-	if (opendir(DIR,$path)) {
-        	my @files = readdir(DIR);
-                foreach my $file (@files) {
-                        unless ($file eq "." || $file eq "..") {
-				if (open(FILE,"<".$path."/expires")) {
-					my $expires = <FILE>;
-					close(FILE);
-					rmtree($path) if ($expires < time());
-				} else {
-                                	traverse($path."/".$file);
-				}
-                        }
-                }
-                closedir(DIR);
-        }
-}
 
 1;