diff --git a/lib/WebGUI/Asset.pm b/lib/WebGUI/Asset.pm index 52192e255..f1b671c1d 100644 --- a/lib/WebGUI/Asset.pm +++ b/lib/WebGUI/Asset.pm @@ -16,7 +16,6 @@ package WebGUI::Asset; use strict; use Tie::IxHash; -use WebGUI::Asset::Template; use WebGUI::AdminConsole; use WebGUI::Cache; use WebGUI::DateTime; @@ -193,7 +192,7 @@ Adds a revision of an existing asset. Note that programmers should almost never =head3 properties -A hash reference containing a list of properties to associate with the child. The only required property value is "className" +A hash reference containing a list of properties to associate with the child. =head3 revisionDate @@ -214,7 +213,7 @@ sub addRevision { WebGUI::SQL->write("insert into ".$definition->{tableName}." (assetId,revisionDate) values (".quote($self->getId).",".$now.")"); } } - my $newVersion = WebGUI::Asset->new($self->getId, $properties->{className}, $now); + my $newVersion = WebGUI::Asset->new($self->getId, $self->get("className"), $now); $newVersion->updateHistory("created revision"); $newVersion->update($properties); return $newVersion; @@ -394,8 +393,7 @@ An array reference containing additional information to include with the default sub definition { my $class = shift; my $definition = shift || []; - my @newDef = @{$definition}; - push(@newDef, { + push(@{$definition}, { tableName=>'assetData', className=>'WebGUI::Asset', properties=>{ @@ -418,7 +416,7 @@ sub definition { url=>{ fieldType=>'text', defaultValue=>undef, - filter=>'fixUrl', + filter=>'fixUrl' }, groupIdEdit=>{ fieldType=>'group', @@ -467,7 +465,7 @@ sub definition { } } }); - return \@newDef; + return $definition; } #------------------------------------------------------------------- @@ -1532,7 +1530,7 @@ sub getNextChildRank { my $rank; if (defined $lineage) { $rank = $self->getRank($lineage); - if ($rank >= 999998) { WebGUI::ErrorHandler->fatal; } + WebGUI::ErrorHandler::fatal("Asset ".$self->getId." has too many children.") if ($rank >= 999998); $rank++; } else { $rank = 1; @@ -1860,7 +1858,8 @@ sub new { my $className = shift; my $revisionDate = shift; unless ($revisionDate) { - ($revisionDate) = WebGUI::SQL->quickArray("select max(revisionDate) from assetData where assetId=".quote($assetId)." group by assetData.assetId order by assetData.revisionDate"); + ($revisionDate) = WebGUI::SQL->quickArray("select max(revisionDate) from assetData where assetId=" + .quote($assetId)." group by assetData.assetId order by assetData.revisionDate"); } return undef unless ($revisionDate); if ($className) { @@ -1872,22 +1871,29 @@ sub new { } $class = $className; } - my $properties = WebGUI::Cache->new("asset_".$assetId."/".$revisionDate)->get; + my $properties = $session{assetprops}{$assetId}{$revisionDate}; + # $properties = WebGUI::Cache->new("asset_".$assetId."/".$revisionDate)->get; +# if ( $session{assetcache}{$assetId}{$revisionDate}) { +# return $session{assetcache}{$assetId}{$revisionDate}; +# } if (exists $properties->{assetId}) { # got properties from cache } else { my $sql = "select * from asset"; foreach my $definition (@{$class->definition}) { - $sql .= " left join ".$definition->{tableName}." on asset.assetId=".$definition->{tableName}.".assetId and ".$definition->{tableName}.".revisionDate=".$revisionDate; + $sql .= " left join ".$definition->{tableName}." on asset.assetId=" + .$definition->{tableName}.".assetId and ".$definition->{tableName}.".revisionDate=".$revisionDate; } $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); + # WebGUI::Cache->new("asset_".$assetId."/".$revisionDate)->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; @@ -1935,8 +1941,8 @@ Lineage string. sub newByLineage { my $class = shift; my $lineage = shift; - my $asset = WebGUI::SQL->quickHashRef("select assetId, className from asset where lineage=".quote($lineage)); - return WebGUI::Asset->new($asset->{assetId}, $asset->{className}); + my ($id,$class) = WebGUI::SQL->quickArray("select assetId, className from asset where lineage=".quote($lineage)); + return WebGUI::Asset->new($id, $class); } #------------------------------------------------------------------- @@ -2009,7 +2015,7 @@ sub newByUrl { return WebGUI::Asset->getNotFound; } } - return $class->getDefault; + return WebGUI::Asset->getDefault; } #------------------------------------------------------------------- @@ -2128,7 +2134,7 @@ sub processTemplate { %{$self->{_properties}}, %{$var} ); - my $template = WebGUI::Asset::Template->new($templateId); + my $template = WebGUI::Asset->new($templateId,"WebGUI::Asset::Template"); if (defined $template) { return $template->process(\%vars); } else { @@ -2237,6 +2243,8 @@ Purges all cache entries associated with this asset. sub purgeCache { my $self = shift; WebGUI::Cache->new("asset_".$self->getId."/".$self->get("revisionDate"))->delete; + delete $session{assetcache}{$self->getId}; + delete $session{assetprops}{$self->getId}; } #------------------------------------------------------------------- @@ -3787,7 +3795,7 @@ Returns a www_manageAssets() method. Sets a new parent via the results of a form sub www_setParent { my $self = shift; return WebGUI::Privilege::insufficient() unless $self->canEdit; - my $newParent = WebGUI::Asset->new($session{form}{assetId}); + my $newParent = WebGUI::Asset->newByDynamicClass($session{form}{assetId}); $self->setParent($newParent) if (defined $newParent); return $self->www_manageAssets(); diff --git a/lib/WebGUI/Asset/Wobject/Navigation.pm b/lib/WebGUI/Asset/Wobject/Navigation.pm index 483e1e295..21ffed256 100644 --- a/lib/WebGUI/Asset/Wobject/Navigation.pm +++ b/lib/WebGUI/Asset/Wobject/Navigation.pm @@ -305,6 +305,8 @@ sub getToolbar { sub view { my $self = shift; # we've got to determine what our start point is based upon user conditions +use Time::HiRes; +my $t = [Time::HiRes::gettimeofday()]; my $start; $session{asset} = WebGUI::Asset->newByUrl unless (exists $session{asset}); my $current = $session{asset}; @@ -335,6 +337,8 @@ sub view { $rules{assetToPedigree} = $current if (isIn("pedigree",@includedRelationships)); $rules{ancestorLimit} = $self->get("ancestorEndPoint"); my $assets = $start->getLineage(\@includedRelationships,\%rules); +my $timeoutput = "get records: ".Time::HiRes::tv_interval($t)."
"; +my $t = [Time::HiRes::gettimeofday()]; my $var = {'page_loop' => []}; my @interestingProperties = ('assetId', 'parentId', 'ownerUserId', 'synopsis', 'newWindow'); foreach my $property (@interestingProperties) { @@ -439,7 +443,12 @@ sub view { } push(@{$var->{page_loop}}, $pageData); } - return $self->processTemplate($var,$self->get("templateId")); +$timeoutput .= "build vars: ".Time::HiRes::tv_interval($t)."
"; +my $t = [Time::HiRes::gettimeofday()]; + my $output = $self->processTemplate($var,$self->get("templateId")); +$timeoutput .= "process template: ".Time::HiRes::tv_interval($t)."
"; + return $output."
".$timeoutput; + } diff --git a/lib/WebGUI/Cache.pm b/lib/WebGUI/Cache.pm index 1421f7591..5c1dc7996 100644 --- a/lib/WebGUI/Cache.pm +++ b/lib/WebGUI/Cache.pm @@ -14,9 +14,11 @@ package WebGUI::Cache; =cut -use WebGUI::Cache::FileCache; use WebGUI::Session; use File::Path; +use HTTP::Headers; +use HTTP::Request; +use LWP::UserAgent; =head1 NAME @@ -37,11 +39,40 @@ These methods are available from this class: =cut +#------------------------------------------------------------------- + +=head2 delete ( ) + +Delete a key from the cache. Must be overridden. + +=cut + +sub delete { + +} + +#------------------------------------------------------------------- + +=head2 deleteChunk ( key ) + +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 + +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 { + $self = shift; + $self->flush; +} + #------------------------------------------------------------------- =head2 flush ( ) -Flushes the caching system. +Flushes the caching system. Must be overloaded. =cut @@ -49,18 +80,32 @@ sub flush { rmtree($session{config}{uploadsPath}.$session{os}{slash}."temp"); } +#------------------------------------------------------------------- + +=head2 get ( ) + +Retrieves a key value from the cache. Must be overridden. + +=cut + +sub get { + +} + #------------------------------------------------------------------- -=head2 new ( otions ) +=head2 new ( key, [ namepsace ] ) -The new method will return a handler for the configured caching mechanism. -Defaults to WebGUI::Cache::FileCache. +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. -=head3 options +=head3 key -Options to pass to the new constructor. See the caching methods in WebGUI/Cache/* -for documentation of the options. +A key to store the value under or retrieve it from. + +=head3 namespace + +A subdivider to store this cache under. When building your own cache plug-in default this to the WebGUI config file. =cut @@ -71,10 +116,113 @@ sub new { require WebGUI::Cache::Memcached; return WebGUI::Cache::Memcached->new(@_); } else { + require WebGUI::Cache::FileCache; return WebGUI::Cache::FileCache->new(@_); } } +#------------------------------------------------------------------- + +=head2 parseKey ( key ) + +Returns a formatted string version of the key. A class method. + +=head3 key + +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 $key = shift; + if (ref $key eq "ARRAY") { + my @parts = @{$key}; + my @fixed; + foreach my $part (@parts) { + $part = Digest::MD5::md5_base64($part); + $part =~ s/\//-/g; + push(@fixed,$part); + } + return join('/',@fixed); + } else { + $key = Digest::MD5::md5_base64($key); + $key =~ s/\//-/g; + return $key; + } +} + +#------------------------------------------------------------------- + +=head2 set ( value [, ttl] ) + +Sets a key value to the cache. Must be overridden. + +=head3 value + +A scalar value to store. + +=head3 ttl + +A time in seconds for the cache to exist. When you override default it to 60 seconds. + +=cut + +sub set { + +} + + +#------------------------------------------------------------------- + +=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. + +=head3 url + +The URL of the document to retrieve. It must begin with the standard "http://". + +=head3 ttl + +The time to live for this content. This is the amount of time (in seconds) that the content will remain in the cache. Defaults to "60". + +=cut + +sub setByHTTP { + my $self = shift; + my $url = shift; + my $ttl = shift; + my $userAgent = new LWP::UserAgent; + $userAgent->agent("WebGUI/".$WebGUI::VERSION); + $userAgent->timeout(30); + my $header = new HTTP::Headers; + my $referer = "http://webgui.http.request/".$session{env}{SERVER_NAME}.$session{env}{REQUEST_URI}; + chomp $referer; + $header->referer($referer); + my $request = new HTTP::Request (GET => $url, $header); + my $response = $userAgent->request($request); + if ($response->is_error) { + WebGUI::ErrorHandler::error($url." could not be retrieved."); + } else { + $self->set($response->content,$ttl); + } + return $response->content; +} + +#------------------------------------------------------------------- + +=head2 stats ( ) + +Return a formatted text string describing cache usage. Must be overridden. + +=cut + +sub stats { + +} + + 1; diff --git a/lib/WebGUI/Cache/FileCache.pm b/lib/WebGUI/Cache/FileCache.pm index f8126a170..652c44c61 100644 --- a/lib/WebGUI/Cache/FileCache.pm +++ b/lib/WebGUI/Cache/FileCache.pm @@ -14,13 +14,10 @@ package WebGUI::Cache::FileCache; =cut -use Cache::SizeAwareFileCache; -use HTTP::Headers; -use HTTP::Request; -use LWP::UserAgent; -use WebGUI::ErrorHandler; +use Storable qw(nstore retrieve); use WebGUI::Session; +use File::Path; our @ISA = qw(WebGUI::Cache); @@ -54,29 +51,26 @@ Remove content from the filesystem cache. =cut sub delete { - $_[0]->{_cache}->remove($_[0]->{_key}); + my $self = shift; + rmtree($self->{_cachefolder}); } - #------------------------------------------------------------------- -=head2 deleteByRegex ( regex ) +=head2 deleteChunk ( key ) -Remove content from the filesystem cache where the key meets the condition of the regular expression. +Remove a partial composite key from the cache. -=head3 regex +=head3 key -A regular expression that will match keys in the current namespace. Example: m/^navigation_.*/ +A partial composite key to remove. =cut -sub deleteByRegex { - my @keys = $_[0]->{_cache}->get_keys(); - foreach my $key (@keys) { - if ($key =~ $_[1]) { - $_[0]->{_cache}->remove($key); - } - } +sub deleteChunk { + my $self = shift; + my $key = $self->parseKey(shift); + rmtree($self->getCacheRoot()."/".$self->{_namespace}."/".$key); } #------------------------------------------------------------------- @@ -88,13 +82,9 @@ Remove all objects from the filecache system. =cut sub flush { - my $self = shift; - $self->SUPER::flush(); - foreach my $namespace ($self->{_cache}->get_namespaces) { - next if ($namespace =~ /\.conf$/ && $namespace ne $session{config}{configFile}); - $self->{_cache}->set_namespace($namespace); - $self->{_cache}->clear; - } + my $self = shift; + $self->SUPER::flush(); + rmtree($self->getCacheRoot."/".$self->{_namespace}); } #------------------------------------------------------------------- @@ -106,10 +96,40 @@ Retrieve content from the filesystem cache. =cut sub get { - return undef if ($session{config}{disableCache}); - return $_[0]->{_cache}->get($_[0]->{_key}); + my $self = shift; + return undef if ($session{config}{disableCache}); + if (open(FILE,"<".$self->{_cachefolder}."/expires")) { + my $expires = ; + close(FILE); + return undef if ($expires < time()); + return retrieve($self->{_cachefolder}."/cache"); + } + return undef; } +#------------------------------------------------------------------- + +=head2 getCacheRoot ( ) + +Figures out what the cache root should be. A class method. + +=cut + +sub getCacheRoot { + my $class = shift; + my $root = $session{config}{fileCacheRoot}; + unless ($root) { + if ($session{os}{windowsish}) { + $root = $session{env}{TEMP} || $session{env}{TMP} || "/temp"; + } else { + $root = "/tmp"; + } + $root .= "/WebGUICache"; + } + return $root; +} + + #------------------------------------------------------------------- =head2 new ( key [, namespace ] ) @@ -129,15 +149,10 @@ Defaults to the config filename for the current site. The only reason to overrid sub new { my $cache; my $class = shift; - my $key = shift; + my $key = $class->parseKey(shift); my $namespace = shift || $session{config}{configFile}; - my %options = ( - namespace=>$namespace, - auto_purge_on_set=>1 - ); - $options{cache_root} = $session{config}{fileCacheRoot} if ($session{config}{fileCacheRoot}); - $cache = new Cache::SizeAwareFileCache(\%options); - bless {_cache => $cache, _key => $key}, $class; + my $path = $class->getCacheRoot()."/".$namespace."/".$key; + bless {_cachefolder => $path, _key=>$key, _namespace=>$namespace}, $class; } @@ -158,61 +173,21 @@ The time to live for this content. This is the amount of time (in seconds) that =cut sub set { - my $ttl = $_[2] || 60; - $_[0]->{_cache}->set($_[0]->{_key},$_[1],$ttl); -} - - -#------------------------------------------------------------------- - -=head2 setByHTTP ( url [, ttl ] ) - -Retrieves a document via HTTP and stores it in the cache and returns the content as a string. - -=head3 url - -The URL of the document to retrieve. It must begin with the standard "http://". - -=head3 ttl - -The time to live for this content. This is the amount of time (in seconds) that the content will remain in the cache. Defaults to "60". - -=cut - -sub setByHTTP { - my $userAgent = new LWP::UserAgent; - $userAgent->agent("WebGUI/".$WebGUI::VERSION); - $userAgent->timeout(30); - my $header = new HTTP::Headers; - my $referer = "http://webgui.http.request/".$session{env}{SERVER_NAME}.$session{env}{REQUEST_URI}; - chomp $referer; - $header->referer($referer); - my $request = new HTTP::Request (GET => $_[1], $header); - my $response = $userAgent->request($request); - if ($response->is_error) { - WebGUI::ErrorHandler::warn($_[1]." could not be retrieved."); - } else { - $_[0]->set($response->content,$_[2]); - } - return $response->content; -} - -#------------------------------------------------------------------- - -=head2 shrink ( [ size ] ) - -Reduces the cache down to a specific size to conserve filesystem space. - -=head3 size - -A size to shrink the cache to in bytes. Defaults to the fileCacheSizeLimit variable in the config file. - -=cut - -sub shrink { my $self = shift; - my $size = shift || $session{config}{fileCacheSizeLimit} || 10000000; - $self->{_cache}->limit_size($size); + my $content = shift; + my $ttl = shift || 60; + my $path = $self->{_cachefolder}; + unless (-e $path) { + eval {mkpath($path)}; + if ($@) { + WebGUI::ErrorHandler::error("Couldn't create cache folder: ".$path." : ".$@); + return; + } + } + nstore($content, $path."/cache"); + open(FILE,">".$path."/expires"); + print FILE time()+$ttl; + close(FILE); } @@ -226,18 +201,9 @@ Returns statistic information about the caching system. sub stats { my $self = shift; - my $output; - $output = "Total size of file cache: ".$self->{_cache}->Size()." bytes\n"; - foreach my $namespace ($self->{_cache}->get_namespaces) { - next if ($namespace =~ /\.conf$/ && $namespace ne $session{config}{configFile}); - $self->{_cache}->set_namespace($namespace); - $output .= "\t$namespace : ".($self->{_cache}->get_keys). - " items / ".$self->{_cache}->size()." bytes\n"; - } - return $output; + return undef; } - 1; diff --git a/lib/WebGUI/Cache/Memcached.pm b/lib/WebGUI/Cache/Memcached.pm index e8ba3b23e..278458a65 100644 --- a/lib/WebGUI/Cache/Memcached.pm +++ b/lib/WebGUI/Cache/Memcached.pm @@ -16,11 +16,6 @@ package WebGUI::Cache::Memcached; use Cache::Memcached; use Digest::MD5; - -use HTTP::Headers; -use HTTP::Request; -use LWP::UserAgent; -use WebGUI::ErrorHandler; use WebGUI::Session; our @ISA = qw(WebGUI::Cache); @@ -60,23 +55,6 @@ sub delete { } -#------------------------------------------------------------------- - -=head2 deleteByRegex ( ) - -This method is here to keep the API compatible. -Because of the nature of memcached it does not support a way to retrieve -the list of cache keys. - -The whole cache will be flushed if deleteByRegex is called. - -=cut - -sub deleteByRegex { - my $self = shift; - return $self->flush; -} - #------------------------------------------------------------------- =head2 flush ( ) @@ -134,7 +112,7 @@ Defaults to the config filename for the current site. The only reason to overrid sub new { my $cache; my $class = shift; - my $key = shift; + my $key = $class->parseKey(shift); my $namespace = shift || $session{config}{configFile}; # Overcome maximum key length of 255 characters @@ -177,40 +155,6 @@ sub set { } -#------------------------------------------------------------------- - -=head2 setByHTTP ( url [, ttl ] ) - -Retrieves a document via HTTP and stores it in the cache and returns the content as a string. - -=head3 url - -The URL of the document to retrieve. It must begin with the standard "http://". - -=head3 ttl - -The time to live for this content. This is the amount of time (in seconds) that the content will remain in the cache. Defaults to "60". - -=cut - -sub setByHTTP { - my $userAgent = new LWP::UserAgent; - $userAgent->agent("WebGUI/".$WebGUI::VERSION); - $userAgent->timeout(30); - my $header = new HTTP::Headers; - my $referer = "http://webgui.http.request/".$session{env}{SERVER_NAME}.$session{env}{REQUEST_URI}; - chomp $referer; - $header->referer($referer); - my $request = new HTTP::Request (GET => $_[1], $header); - my $response = $userAgent->request($request); - if ($response->is_error) { - WebGUI::ErrorHandler::warn($_[1]." could not be retrieved."); - } else { - $_[0]->set($response->content,$_[2]); - } - return $response->content; -} - #------------------------------------------------------------------- =head2 stats ( ) diff --git a/lib/WebGUI/Operation/Settings.pm b/lib/WebGUI/Operation/Settings.pm index bef1b965f..35bf2ed83 100644 --- a/lib/WebGUI/Operation/Settings.pm +++ b/lib/WebGUI/Operation/Settings.pm @@ -111,7 +111,7 @@ sub www_editSettings { -name=>"richEditor", -label=>$i18n->get("default rich editor"), -value=>[$session{setting}{richEditor}], - -options=>WebGUI::SQL->buildHashRef("select assetId,title from asset where className='WebGUI::Asset::RichEdit' order by title"), + -options=>WebGUI::SQL->buildHashRef("select assetData.assetId,assetData.title from asset left join assetData on asset.assetId=assetData.assetId where asset.className='WebGUI::Asset::RichEdit' order by assetData.title"), -defaultValue=>["PBrichedit000000000001"] ); $tabform->getTab("ui")->integer( diff --git a/sbin/Hourly/CleanFileCache.pm b/sbin/Hourly/CleanFileCache.pm index 67d1e3c85..941d51c54 100644 --- a/sbin/Hourly/CleanFileCache.pm +++ b/sbin/Hourly/CleanFileCache.pm @@ -13,11 +13,31 @@ package Hourly::CleanFileCache; use strict; use WebGUI::Session; use WebGUI::Cache::FileCache; +use File::Path; #------------------------------------------------------------------- sub process { - my $cache = WebGUI::Cache::FileCache->new; - $cache->shrink; + traverse(WebGUI::Cache::FileCache->getCacheRoot); +} + +#------------------------------------------------------------------- +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 = ; + close(FILE); + rmtree($path) if ($expires < time()); + } else { + traverse($path."/".$file); + } + } + } + closedir(DIR); + } } 1; diff --git a/sbin/preload.perl b/sbin/preload.perl index 11124f147..3010f8474 100644 --- a/sbin/preload.perl +++ b/sbin/preload.perl @@ -44,12 +44,12 @@ use HTML::Template (); use Parse::PlainConfig (); use Net::SMTP (); use Log::Log4perl (); -use Cache::Cache (); use Tie::IxHash (); use Tie::CPHash (); use Time::HiRes (); use Date::Manip (); use Image::Magick (); +use Storable; use XML::Simple (); #### diff --git a/sbin/testEnvironment.pl b/sbin/testEnvironment.pl index 82e5ebc3e..2940b6f65 100644 --- a/sbin/testEnvironment.pl +++ b/sbin/testEnvironment.pl @@ -53,7 +53,6 @@ checkModule("Archive::Tar",1.05); checkModule("IO::Zlib",1.01); checkModule("Compress::Zlib",1.34); checkModule("Net::SMTP",2.24); -checkModule("Cache::Cache",1.02); checkModule("Tie::IxHash",1.21); checkModule("Tie::CPHash",1.001); checkModule("XML::Simple",2.09);