/
DataObject.pm
204 lines (145 loc) · 4.93 KB
/
DataObject.pm
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
package Koha::DataObject;
=head1 NAME
Koha::DataObject - base class for context dependant data retrieval and storage classes
=cut
use strict;
use warnings;
use XML::Quick;
use Carp;
use base qw(Class::Accessor);
use constant CACHE_TTL => undef;
use constant CACHE_POLICY_NEVER => 'CACHE_NEVER';
use constant CACHE_POLICY_CONTEXT => 'CACHE_CONTEXT_DEPENDANT';
use constant CACHE_POLICY_ALWAYS => 'CACHE_ALWAYS';
use constant CACHE_POLICY => CACHE_POLICY_CONTEXT;
=head1 CONSTRUCTOR
=head2 new( $context, $data )
$data is optional
=cut
sub new {
my $class = shift;
# Input params
my $context = shift or croak "Context not supplied in new";
my $data = shift;
my $self = { CONTEXT => $context };
bless $self, $class;
$self->set_object_data($data) if $data;
return $self;
}
=head1 C4::Context PROXY METHODS
=head2 get_context() - Returns context object
=cut
sub get_context {
my $self = shift;
return $self->{CONTEXT};
}
sub get_object_data {
my $self = shift;
return $self->{DATA};
}
sub set_object_data {
my $self = shift;
$self->{DATA} = shift;
}
sub new_by_primary_key {
my $class = shift;
# Input params
my $context = shift || croak "Context not supplied";
my $self = new( $class, $context ) or return;
my $data =
$self->get_data( $self->CACHE_POLICY, $class, $class->CACHE_TTL,
'_load_data', @_ )
or return;
$self->set_object_data($data);
return $self;
}
sub get_data {
my $self = shift;
my $policy = shift or croak "Cache policy not specified";
my $key_prefix = shift;
my $ttl = shift;
my $db_load_sub = shift or croak "DB load sub name not specified";
return ref($db_load_sub) ? $db_load_sub->(@_) : $self->$db_load_sub(@_)
if $policy eq CACHE_POLICY_NEVER;
my $get_method =
$policy eq CACHE_POLICY_CONTEXT ? 'get_data_context_dependant'
: $policy eq CACHE_POLICY_ALWAYS ? 'get_data_cached'
: die( "Unknown cache policy " . $policy );
return $self->$get_method( $key_prefix, $ttl, $db_load_sub, @_ );
}
sub _load_data {
my $self = shift;
my $dbh = $self->get_context->dbh;
my $data;
eval {
$data = $dbh->selectrow_hashref( $self->QUERY, undef, @_ )
or return;
};
if ($@) {
return;
}
return $data;
}
sub get_data_cached {
my $self = shift;
my $key_prefix = shift;
my $ttl = shift; # if 0 store for ever
my $method = shift or croak "Data load method not specified";
my $context = $self->get_context;
my $data = $self->get_from_cache( $key_prefix, @_ );
return $data if $data;
$data = ref($method) ? $method->(@_) : $self->$method(@_)
or return;
$self->store_in_cache( $key_prefix, $ttl, $data, @_ );
return $data;
}
sub get_data_context_dependant {
my $self = shift;
my $key_prefix = shift;
my $ttl = shift;
my $method = shift or croak "Data load method not specified";
my $context = $self->get_context;
return $self->get_data_cached( $key_prefix, $ttl, $method, @_ )
if $context->cache_objects;
return ref($method) ? $method->(@_) : $self->$method(@_);
}
sub get_from_cache {
my $self = shift;
my $key_prefix = shift || ref $self;
my $cache = $self->get_context->cache;
my $key = $self->make_cache_key( $key_prefix, @_ );
my $data = $cache->get_from_cache($key)
or return;
return $data;
}
sub make_cache_key {
my $self = shift;
my $class = ref($self);
return $class->_make_cache_key( "Koha", @_ );
}
sub _make_cache_key {
my $class = shift;
my $db_context = shift or croak "No db_context";
my $prefix = shift;
my @key = ($db_context);
push @key, $prefix if defined $prefix;
push @key, join( ';', map { defined($_) ? $_ : '' } @_ ) if @_;
return join '::', @key;
}
sub store_in_cache {
my $self = shift;
my $key_prefix = shift || ref $self;
my $ttl = shift;
my $data = shift or croak "No data";
my $cache = $self->get_context->cache;
my $key = $self->make_cache_key( $key_prefix, @_ );
$cache->set_in_cache( $key, $data, $ttl )
or return;
return 1;
}
sub data2xml {
my $self = shift;
my $data = shift;
return xml($data);
}
1;