106 lines
2.8 KiB
Perl
Executable File
106 lines
2.8 KiB
Perl
Executable File
# -*- mode: cperl; c-basic-offset: 8; indent-tabs-mode: nil; -*-
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
# ***** BEGIN LICENSE BLOCK *****
|
|
# Version: MPL 1.1
|
|
#
|
|
# The contents of this file are subject to the Mozilla Public License
|
|
# Version 1.1 (the "License"); you may not use this file except in
|
|
# compliance with the License. You may obtain a copy of the License
|
|
# at http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS IS"
|
|
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
|
|
# the License for the specific language governing rights and
|
|
# limitations under the License.
|
|
#
|
|
# The Original Code is Litmus.
|
|
#
|
|
# The Initial Developer of the Original Code is
|
|
# the Mozilla Corporation.
|
|
# Portions created by the Initial Developer are Copyright (C) 2006
|
|
# the Initial Developer. All Rights Reserved.
|
|
#
|
|
# Contributor(s):
|
|
# Zach Lipton <zach@zachlipton.com>
|
|
#
|
|
# ***** END LICENSE BLOCK *****
|
|
|
|
=cut
|
|
|
|
package Litmus::Memoize;
|
|
|
|
use strict;
|
|
use Exporter;
|
|
our @EXPORT = qw(memoize);
|
|
use Memoize ();
|
|
use base 'Memoize';
|
|
|
|
use constant MP2 => ( exists $ENV{MOD_PERL_API_VERSION} and
|
|
$ENV{MOD_PERL_API_VERSION} >= 2 );
|
|
use constant MP1 => ( exists $ENV{MOD_PERL} and
|
|
! exists $ENV{MOD_PERL_API_VERSION});
|
|
|
|
# Subclass of Memoize.pm that gives us control over when our data is
|
|
# flushed and ensures that cached data does not persist across mod_perl
|
|
# requests unless we really want it to
|
|
|
|
sub memoize {
|
|
my $fn = shift;
|
|
my %options = @_;
|
|
|
|
if (MP2 && ! Apache2::RequestUtil->request()) {
|
|
return;
|
|
} if (MP1 && ! Apache->request()) {
|
|
return;
|
|
}
|
|
|
|
my $uppack = caller;
|
|
|
|
$options{INSTALL} = $uppack . '::' . $fn;
|
|
|
|
$fn = Memoize::_make_cref($fn, $uppack);
|
|
|
|
# if the persist flag is given, we store the memoized data normally
|
|
# and it will persist across mod_perl requests
|
|
if ($options{persist}) {
|
|
Memoize::memoize($fn, %options);
|
|
return;
|
|
}
|
|
|
|
# otherwise, we keep the cache in request_cache where it will get
|
|
# flushed when the request ends
|
|
my $cache = {};
|
|
my $request;
|
|
if (MP1) {
|
|
$request = Apache->request();
|
|
} elsif (MP2) {
|
|
$request = Apache2::RequestUtil->request();
|
|
}
|
|
|
|
if ($ENV{MOD_PERL}) {
|
|
$cache = $request->pnotes();
|
|
if (!$cache->{cleanup_registered}) {
|
|
$request->push_handlers(PerlCleanupHandler => sub {
|
|
my $r = shift;
|
|
foreach my $key (keys %{$r->pnotes}) {
|
|
delete $r->pnotes->{$key};
|
|
}
|
|
});
|
|
$cache->{cleanup_registered} = 1;
|
|
}
|
|
}
|
|
|
|
$cache->{'S'.$fn} = {};
|
|
$cache->{'L'.$fn} = {};
|
|
my $s_cache = $cache->{'S'.$fn};
|
|
my $l_cache = $cache->{'L'.$fn};
|
|
$options{SCALAR_CACHE} = [HASH => $s_cache];
|
|
$options{LIST_CACHE} = [HASH => $l_cache];
|
|
Memoize::memoize($fn, %options);
|
|
return;
|
|
}
|
|
|
|
1;
|