/usr/share/perl5/DBIx/Class/Cursor/Cached.pm is in libdbix-class-cursor-cached-perl 1.001002-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | package DBIx::Class::Cursor::Cached;
use strict;
use warnings;
use 5.008001;
use Storable ();
use Digest::SHA ();
use Carp::Clan qw/^DBIx::Class/;
use vars qw($VERSION);
$VERSION = '1.001002';
sub new {
my $class = shift;
my ($storage, $args, $attrs) = @_;
$class = ref $class if ref $class;
# This gives us the class the storage object -would- have used
# (since cursor_class is inherited Class::Accessor::Grouped type)
my $inner_class = (ref $storage)->cursor_class;
my $inner = $inner_class->new(@_);
if ($attrs->{cache_for}) {
my %args = (
inner => $inner,
cache_for => delete $attrs->{cache_for},
cache_object => delete $attrs->{cache_object},
# this must be here to ensure the deletes have happened
cache_key => $class->_build_cache_key(@_),
pos => 0
);
return bless(\%args, $class);
}
return $inner; # return object that -would- have been constructed.
}
sub next {
my ($self) = @_;
return @{($self->{data} ||= $self->_fill_data)->[$self->{pos}++]||[]};
}
sub all {
my ($self) = @_;
return @{$self->{data} ||= $self->_fill_data};
}
sub reset {
shift->{pos} = 0;
}
sub _build_cache_key {
my ($class, $storage, $args, $attrs) = @_;
# compose the query and bind values, like as_query(),
# so the cache key is only affected by what the database sees
# and not any other cruft in $attrs
my $ref = $storage->_select_args_to_query(@{$args}[0..2], $attrs);
my $conn;
if (! ($conn = $storage->_dbh) ) {
my $connect_info = $storage->_dbi_connect_info;
if (! ref($connect_info->[0]) ) {
$conn = { Name => $connect_info->[0], Username => $connect_info->[1] };
} else {
carp "Invoking connector coderef $connect_info->[0] in order to obtain cache-lookup information";
$conn = $connect_info->[0]->();
}
}
local $Storable::canonical = 1;
return Digest::SHA::sha1_hex(Storable::nfreeze( [ $ref, $conn->{Name}, $conn->{Username} || '' ] ));
}
sub _fill_data {
my ($self) = @_;
my $cache = $self->{cache_object};
my $key = $self->{cache_key};
return $cache->get($key) || do {
my $data = [ $self->{inner}->all ];
$cache->set($key, $data, $self->{cache_for});
$data;
};
}
sub clear_cache {
my ($self) = @_;
$self->{cache_object}->remove($self->{cache_key});
delete $self->{data};
}
sub cache_key { shift->{cache_key} }
1;
=head1 NAME
DBIx::Class::Cursor::Cached - cursor class with built-in caching support
=head1 SYNOPSIS
my $schema = SchemaClass->connect(
$dsn, $user, $pass, { cursor_class => 'DBIx::Class::Cursor::Cached' }
);
$schema->default_resultset_attributes({
cache_object => Cache::FileCache->new({ namespace => 'SchemaClass' }),
});
my $rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
my @cds = $rs->all; # fills cache
$rs = $schema->resultset('CD')->search(undef, { cache_for => 300 });
# refresh resultset
@cds = $rs->all; # uses cache, no SQL run
$rs->cursor->clear_cache; # deletes data from cache
@cds = $rs->all; # refills cache
=head1 AUTHOR
Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
Initial development sponsored by and (c) Takkle, Inc. 2007
=head1 LICENSE
This library is free software under the same license as perl itself
=cut
|