line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBIx::NinjaORM; |
2
|
|
|
|
|
|
|
|
3
|
69
|
|
|
69
|
|
1383551
|
use 5.010; |
|
69
|
|
|
|
|
191
|
|
4
|
|
|
|
|
|
|
|
5
|
69
|
|
|
69
|
|
289
|
use warnings; |
|
69
|
|
|
|
|
87
|
|
|
69
|
|
|
|
|
1610
|
|
6
|
69
|
|
|
69
|
|
254
|
use strict; |
|
69
|
|
|
|
|
90
|
|
|
69
|
|
|
|
|
1265
|
|
7
|
|
|
|
|
|
|
|
8
|
69
|
|
|
69
|
|
276
|
use Carp; |
|
69
|
|
|
|
|
81
|
|
|
69
|
|
|
|
|
4024
|
|
9
|
69
|
|
|
69
|
|
31603
|
use Class::Load qw(); |
|
69
|
|
|
|
|
1107949
|
|
|
69
|
|
|
|
|
1776
|
|
10
|
69
|
|
|
69
|
|
28966
|
use DBIx::NinjaORM::StaticClassInfo; |
|
69
|
|
|
|
|
168
|
|
|
69
|
|
|
|
|
4806
|
|
11
|
69
|
|
|
69
|
|
29553
|
use DBIx::NinjaORM::Utils qw( dumper ); |
|
69
|
|
|
|
|
190
|
|
|
69
|
|
|
|
|
4108
|
|
12
|
69
|
|
|
69
|
|
481
|
use Data::Validate::Type; |
|
69
|
|
|
|
|
90
|
|
|
69
|
|
|
|
|
1953
|
|
13
|
69
|
|
|
69
|
|
30498
|
use Digest::SHA1 qw(); |
|
69
|
|
|
|
|
39685
|
|
|
69
|
|
|
|
|
1845
|
|
14
|
69
|
|
|
69
|
|
30149
|
use Log::Any qw( $log ); |
|
69
|
|
|
|
|
437865
|
|
|
69
|
|
|
|
|
412
|
|
15
|
69
|
|
|
69
|
|
156825
|
use MIME::Base64 qw(); |
|
69
|
|
|
|
|
37156
|
|
|
69
|
|
|
|
|
1538
|
|
16
|
69
|
|
|
69
|
|
38255
|
use Storable; |
|
69
|
|
|
|
|
179162
|
|
|
69
|
|
|
|
|
4011
|
|
17
|
69
|
|
|
69
|
|
477
|
use Try::Tiny; |
|
69
|
|
|
|
|
112
|
|
|
69
|
|
|
|
|
513056
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=head1 NAME |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
DBIx::NinjaORM - Flexible Perl ORM for easy transitions from inline SQL to objects. |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 VERSION |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
Version 3.1.0 |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=cut |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
our $VERSION = '3.1.0'; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head1 DESCRIPTION |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
L was designed with a few goals in mind: |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=over 4 |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
=item * |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
Expand objects with data joined from other tables, to do less queries and |
43
|
|
|
|
|
|
|
prevent lazy-loading of ancillary information. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=item * |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
Have a short learning curve. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
=item * |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
Provide advanced caching features and manage cache expiration upon database changes. |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
=item * |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
Allow a progressive introduction of a separate Model layer in a legacy codebase. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=back |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=head1 SYNOPSIS |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head2 Simple example |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
Let's take the example of a C class that represents a book. You |
65
|
|
|
|
|
|
|
would start C with the following code: |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
package My::Model::Book; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
use strict; |
70
|
|
|
|
|
|
|
use warnings; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
use base 'DBIx::NinjaORM'; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
use DBI; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub static_class_info |
78
|
|
|
|
|
|
|
{ |
79
|
|
|
|
|
|
|
my ( $class ) = @_; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# Retrieve defaults from DBIx::Ninja->static_class_info(). |
82
|
|
|
|
|
|
|
my $info = $class->SUPER::static_class_info(); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
$info->set( |
85
|
|
|
|
|
|
|
{ |
86
|
|
|
|
|
|
|
# Set mandatory defaults. |
87
|
|
|
|
|
|
|
table_name => 'books', |
88
|
|
|
|
|
|
|
primary_key_name => 'book_id', |
89
|
|
|
|
|
|
|
default_dbh => DBI->connect( |
90
|
|
|
|
|
|
|
"dbi:mysql:[database_name]:localhost:3306", |
91
|
|
|
|
|
|
|
"[user]", |
92
|
|
|
|
|
|
|
"[password]", |
93
|
|
|
|
|
|
|
), |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# Add optional information. |
96
|
|
|
|
|
|
|
# Allow filtering SELECTs on books.name. |
97
|
|
|
|
|
|
|
filtering_fields => [ 'name' ], |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
); |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
return $info; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
1; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
Inheriting with C |
107
|
|
|
|
|
|
|
C (with a default database handle and a table name) |
108
|
|
|
|
|
|
|
are the only two requirements to have a working model. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=head2 A more complex model |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
If you have more than one Model class to create, for example C |
114
|
|
|
|
|
|
|
and C, you probably want to create a single class |
115
|
|
|
|
|
|
|
C to hold the defaults and then inherits from that main class. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
package My::Model; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
use strict; |
120
|
|
|
|
|
|
|
use warnings; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
use base 'DBIx::NinjaORM'; |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
use DBI; |
125
|
|
|
|
|
|
|
use Cache::Memcached::Fast; |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub static_class_info |
129
|
|
|
|
|
|
|
{ |
130
|
|
|
|
|
|
|
my ( $class ) = @_; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# Retrieve defaults from DBIx::Ninja->static_class_info(). |
133
|
|
|
|
|
|
|
my $info = $class->SUPER::static_class_info(); |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Set defaults common to all your objects. |
136
|
|
|
|
|
|
|
$info->set( |
137
|
|
|
|
|
|
|
{ |
138
|
|
|
|
|
|
|
default_dbh => DBI->connect( |
139
|
|
|
|
|
|
|
"dbi:mysql:[database_name]:localhost:3306", |
140
|
|
|
|
|
|
|
"[user]", |
141
|
|
|
|
|
|
|
"[password]", |
142
|
|
|
|
|
|
|
), |
143
|
|
|
|
|
|
|
memcache => Cache::Memcached::Fast->new( |
144
|
|
|
|
|
|
|
{ |
145
|
|
|
|
|
|
|
servers => |
146
|
|
|
|
|
|
|
[ |
147
|
|
|
|
|
|
|
'localhost:11211', |
148
|
|
|
|
|
|
|
], |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
), |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
return $info; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
1; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
The various classes will then inherit from C, and the inherited |
160
|
|
|
|
|
|
|
defaults will make C shorter in the other classes: |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
package My::Model::Book; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
use strict; |
165
|
|
|
|
|
|
|
use warnings; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# Inherit from your base model class, not from DBIx::NinjaORM. |
168
|
|
|
|
|
|
|
use base 'My::Model'; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub static_class_info |
171
|
|
|
|
|
|
|
{ |
172
|
|
|
|
|
|
|
my ( $class ) = @_; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# Retrieve defaults from My::Model. |
175
|
|
|
|
|
|
|
my $info = $class->SUPER::static_class_info(); |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
$info->set( |
178
|
|
|
|
|
|
|
{ |
179
|
|
|
|
|
|
|
# Set mandatory defaults for this class. |
180
|
|
|
|
|
|
|
table_name => 'books', |
181
|
|
|
|
|
|
|
primary_key_name => 'book_id', |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# Add optional information. |
184
|
|
|
|
|
|
|
# Allow filtering SELECTs on books.name. |
185
|
|
|
|
|
|
|
filtering_fields => [ 'name' ], |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
return $info; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
1; |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
=cut |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# This hash indicates what argument names are valid in retrieve_list() calls, |
197
|
|
|
|
|
|
|
# and for each argument it specifies whether it should be included (1) or |
198
|
|
|
|
|
|
|
# ignored (0) when building the list cache keys that associate the arguments |
199
|
|
|
|
|
|
|
# passed to the result IDs. |
200
|
|
|
|
|
|
|
our $RETRIEVE_LIST_VALID_ARGUMENTS = |
201
|
|
|
|
|
|
|
{ |
202
|
|
|
|
|
|
|
allow_all => 1, |
203
|
|
|
|
|
|
|
dbh => 0, |
204
|
|
|
|
|
|
|
limit => 1, |
205
|
|
|
|
|
|
|
lock => 0, |
206
|
|
|
|
|
|
|
order_by => 1, |
207
|
|
|
|
|
|
|
pagination => 1, |
208
|
|
|
|
|
|
|
query_extensions => 1, |
209
|
|
|
|
|
|
|
show_queries => 0, |
210
|
|
|
|
|
|
|
skip_cache => 0, |
211
|
|
|
|
|
|
|
exclude_fields => 0, |
212
|
|
|
|
|
|
|
select_fields => 0, |
213
|
|
|
|
|
|
|
}; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=head1 SUPPORTED DATABASES |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
This distribution currently supports: |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
=over 4 |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=item * SQLite |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=item * MySQL |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=item * PostgreSQL |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
=back |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
Please contact me if you need support for another database type, I'm always |
231
|
|
|
|
|
|
|
glad to add extensions if you can help me with testing. |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=head1 SUBCLASSABLE METHODS |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
L is designed with inheritance in mind, and you can subclass |
237
|
|
|
|
|
|
|
most of its public methods to extend or alter its behavior. |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
This group of method covers the most commonly subclassed methods, with examples |
240
|
|
|
|
|
|
|
and use cases. |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=head2 clone() |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
Clone the current object and return the clone. |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
my $cloned_book = $book->clone(); |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=cut |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub clone |
252
|
|
|
|
|
|
|
{ |
253
|
1
|
|
|
1
|
1
|
43
|
my ( $self ) = @_; |
254
|
|
|
|
|
|
|
|
255
|
1
|
|
|
|
|
78
|
return Storable::dclone( $self ); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=head2 commit() |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
Convenience function to insert or update the object. |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
If the object has a primary key set, C is called, otherwise |
264
|
|
|
|
|
|
|
C is called. If there's an error, the method with croak with |
265
|
|
|
|
|
|
|
relevant error information. |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
$book->commit(); |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
Arguments: (none). |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=cut |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
sub commit |
274
|
|
|
|
|
|
|
{ |
275
|
2
|
|
|
2
|
1
|
37
|
my ( $self ) = @_; |
276
|
2
|
|
|
|
|
87
|
my $data = Storable::dclone( $self ); |
277
|
|
|
|
|
|
|
|
278
|
2
|
100
|
|
|
|
9
|
if ( defined( $self->id() ) ) |
279
|
|
|
|
|
|
|
{ |
280
|
|
|
|
|
|
|
# If id() is defined, we have a value for the primary key name |
281
|
|
|
|
|
|
|
# and we need to delete it from the data to update. |
282
|
1
|
|
|
|
|
3
|
my $primary_key_name = $self->get_info('primary_key_name'); |
283
|
1
|
|
|
|
|
2
|
delete( $data->{ $primary_key_name } ); |
284
|
|
|
|
|
|
|
|
285
|
1
|
|
|
|
|
5
|
return $self->update( $data ); |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
else |
288
|
|
|
|
|
|
|
{ |
289
|
1
|
|
|
|
|
4
|
return $self->insert( $data ); |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=head2 get() |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Get the value corresponding to an object's field. |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
my $book_name = $book->get('name'); |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
This method will croak if you attempt to retrieve a private field. It also |
301
|
|
|
|
|
|
|
detects if the object was retrieved from the database, in which case it |
302
|
|
|
|
|
|
|
has an exhaustive list of the fields that actually exist in the database and |
303
|
|
|
|
|
|
|
it will croak if you attempt to retrieve a field that doesn't exist in the |
304
|
|
|
|
|
|
|
database. |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=cut |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub get |
309
|
|
|
|
|
|
|
{ |
310
|
57
|
|
|
57
|
1
|
6187
|
my ( $self, $field_name ) = @_; |
311
|
|
|
|
|
|
|
|
312
|
57
|
100
|
100
|
|
|
245
|
croak "The name of the field to retrieve must be defined" |
313
|
|
|
|
|
|
|
if !defined( $field_name ) || ( $field_name eq '' ); |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# Create your own accessor for private properties. |
316
|
55
|
100
|
|
|
|
116
|
croak 'Cannot retrieve the value of a private object property, create an accessor on the class if you need this value' |
317
|
|
|
|
|
|
|
if substr( $field_name, 0, 1 ) eq '_'; |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# If the object was not populated by retrieve_list(), we know that the keys |
320
|
|
|
|
|
|
|
# on the object correspond to all the columns in the database and we can then |
321
|
|
|
|
|
|
|
# actively show errors in the log if the caller is requesting a field for |
322
|
|
|
|
|
|
|
# which the key doesn't exist. |
323
|
54
|
|
100
|
|
|
103
|
my $populated_by_retrieve_list = $self->{'_populated_by_retrieve_list'} // 0; |
324
|
|
|
|
|
|
|
croak "The property '$field_name' does not exist on the object" |
325
|
54
|
50
|
66
|
|
|
170
|
if $populated_by_retrieve_list && !exists( $self->{ $field_name } ); |
326
|
|
|
|
|
|
|
|
327
|
54
|
|
|
|
|
144
|
return $self->{ $field_name }; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
=head2 get_current_time() |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
Return the current time, to use in SQL statements. |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
my $current_time = $class->get_current_time( $field_name ); |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
By default, DBIx::NinjaORM assumes that time is stored as unixtime (integer) in the database. If you are using a different field type for C and C, you can subclass this method to return the current time in a different format. |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
Arguments: |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=over 4 |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
=item * $field_name |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
The name of the field that will be populated with the return value. |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
=back |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
Notes: |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
=over 4 |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=item * |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
The return value of this method will be inserted directly into the database, so |
356
|
|
|
|
|
|
|
you can use C for example, and if you are inserting strings those should |
357
|
|
|
|
|
|
|
be quoted in the subclassed method. |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
=back |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
=cut |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
sub get_current_time |
364
|
|
|
|
|
|
|
{ |
365
|
105
|
|
|
105
|
1
|
1232
|
my ( $self, $field_name ) = @_; |
366
|
|
|
|
|
|
|
|
367
|
105
|
|
|
|
|
250
|
return time(); |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
=head2 insert() |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
Insert a row corresponding to the data passed as first parameter, and fill the |
374
|
|
|
|
|
|
|
object accordingly upon success. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
my $book = My::Model::Book->new(); |
377
|
|
|
|
|
|
|
$book->insert( |
378
|
|
|
|
|
|
|
{ |
379
|
|
|
|
|
|
|
name => 'Learning Perl', |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
); |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
If you don't need the object afterwards, you can simply do: |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
My::Model::Book->insert( |
386
|
|
|
|
|
|
|
{ |
387
|
|
|
|
|
|
|
name => 'Learning Perl', |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
); |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
This method supports the following optional arguments: |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=over 4 |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
=item * overwrite_created |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
A UNIX timestamp to be used instead of the current time for the value of |
398
|
|
|
|
|
|
|
'created'. |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=item * generated_primary_key_value |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
A primary key value, in case the underlying table doesn't have an |
403
|
|
|
|
|
|
|
autoincremented primary key. |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=item * dbh |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
A different database handle than the default one specified in |
408
|
|
|
|
|
|
|
C, but it has to be writable. |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
=item * ignore |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
INSERT IGNORE instead of plain INSERT. |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=back |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
$book->insert( |
417
|
|
|
|
|
|
|
\%data, |
418
|
|
|
|
|
|
|
overwrite_created => $unixtime, |
419
|
|
|
|
|
|
|
generated_primary_key_value => $value, |
420
|
|
|
|
|
|
|
dbh => $dbh, |
421
|
|
|
|
|
|
|
ignore => $boolean, |
422
|
|
|
|
|
|
|
); |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=cut |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
sub insert ## no critic (Subroutines::RequireArgUnpacking) |
427
|
|
|
|
|
|
|
{ |
428
|
60
|
100
|
|
60
|
1
|
13389
|
croak 'The first argument passed must be a hashref' |
429
|
|
|
|
|
|
|
if !Data::Validate::Type::is_hashref( $_[1] ); |
430
|
|
|
|
|
|
|
|
431
|
59
|
|
|
|
|
1251
|
my ( $self, $data, %args ) = @_; |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# Allows calling Module->insert() if we don't need the object afterwards. |
434
|
|
|
|
|
|
|
# In this case, we turn $self from a class into an object. |
435
|
59
|
100
|
|
|
|
215
|
$self = $self->new() |
436
|
|
|
|
|
|
|
if !ref( $self ); |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# Allow using a different database handle. |
439
|
59
|
|
|
|
|
427
|
my $dbh = $self->assert_dbh( $args{'dbh'} ); |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# Clean input. |
442
|
56
|
|
|
|
|
559
|
my $clean_data = $self->validate_data( $data, %args ); |
443
|
56
|
50
|
|
|
|
173
|
return 0 |
444
|
|
|
|
|
|
|
if !defined( $clean_data ); |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# Retrieve the metadata for that table. |
447
|
56
|
|
|
|
|
112
|
my $class = ref( $self ); |
448
|
56
|
|
|
|
|
132
|
my $table_name = $self->get_info('table_name'); |
449
|
56
|
50
|
|
|
|
181
|
croak "The table name for class '$class' is not defined" |
450
|
|
|
|
|
|
|
if !defined( $table_name ); |
451
|
|
|
|
|
|
|
|
452
|
56
|
|
|
|
|
132
|
my $primary_key_name = $self->get_info('primary_key_name'); |
453
|
|
|
|
|
|
|
croak "Missing primary key name for class '$class', cannot force primary key value" |
454
|
56
|
50
|
33
|
|
|
241
|
if !defined( $primary_key_name ) && defined( $args{'generated_primary_key_value'} ); |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
# Set defaults. |
457
|
56
|
100
|
|
|
|
137
|
if ( $self->get_info('has_created_field') ) |
458
|
|
|
|
|
|
|
{ |
459
|
|
|
|
|
|
|
$clean_data->{'created'} = defined( $args{'overwrite_created'} ) && $args{'overwrite_created'} ne '' |
460
|
53
|
100
|
66
|
|
|
420
|
? $args{'overwrite_created'} |
461
|
|
|
|
|
|
|
: $self->get_current_time(); |
462
|
|
|
|
|
|
|
} |
463
|
56
|
100
|
|
|
|
183
|
$clean_data->{'modified'} = $self->get_current_time() |
464
|
|
|
|
|
|
|
if $self->get_info('has_modified_field'); |
465
|
|
|
|
|
|
|
$clean_data->{ $primary_key_name } = $args{'generated_primary_key_value'} |
466
|
56
|
100
|
|
|
|
198
|
if defined( $args{'generated_primary_key_value'} ); |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
# Prepare the query elements. |
469
|
56
|
50
|
33
|
|
|
457
|
my $ignore = defined( $args{'ignore'} ) && $args{'ignore'} ? 1 : 0; |
470
|
56
|
|
|
|
|
108
|
my @sql_fields = (); |
471
|
56
|
|
|
|
|
95
|
my @sql_values = (); |
472
|
56
|
|
|
|
|
104
|
my @placeholder_values = (); |
473
|
56
|
|
|
|
|
166
|
foreach my $key ( keys %$clean_data ) |
474
|
|
|
|
|
|
|
{ |
475
|
172
|
|
|
|
|
196
|
push( @sql_fields, $key ); |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# 'created' and 'modified' support SQL keywords, so we don't use |
478
|
|
|
|
|
|
|
# placeholders. |
479
|
172
|
100
|
|
|
|
644
|
if ( $key =~ /^(?:created|modified)$/x ) |
480
|
|
|
|
|
|
|
{ |
481
|
106
|
|
|
|
|
198
|
push( @sql_values, $clean_data->{ $key } ); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
else |
484
|
|
|
|
|
|
|
{ |
485
|
|
|
|
|
|
|
# All the other data need to be inserted using placeholders, for |
486
|
|
|
|
|
|
|
# security purposes. |
487
|
66
|
|
|
|
|
108
|
push( @sql_values, '?' ); |
488
|
66
|
|
|
|
|
130
|
push( @placeholder_values, $clean_data->{ $key } ); |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
56
|
50
|
|
|
|
690
|
my $query = sprintf( |
493
|
|
|
|
|
|
|
q| |
494
|
|
|
|
|
|
|
INSERT %s INTO %s( %s ) |
495
|
|
|
|
|
|
|
VALUES ( %s ) |
496
|
|
|
|
|
|
|
|, |
497
|
|
|
|
|
|
|
$ignore ? 'IGNORE' : '', |
498
|
|
|
|
|
|
|
$dbh->quote_identifier( $table_name ), |
499
|
|
|
|
|
|
|
join( ', ', @sql_fields ), |
500
|
|
|
|
|
|
|
join( ', ', @sql_values ), |
501
|
|
|
|
|
|
|
); |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
# Insert. |
504
|
|
|
|
|
|
|
try |
505
|
|
|
|
|
|
|
{ |
506
|
56
|
|
|
56
|
|
5516
|
local $dbh->{'RaiseError'} = 1; |
507
|
56
|
|
|
|
|
1381
|
$dbh->do( |
508
|
|
|
|
|
|
|
$query, |
509
|
|
|
|
|
|
|
{}, |
510
|
|
|
|
|
|
|
@placeholder_values, |
511
|
|
|
|
|
|
|
); |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
catch |
514
|
|
|
|
|
|
|
{ |
515
|
1
|
|
|
1
|
|
29
|
$log->fatalf( |
516
|
|
|
|
|
|
|
"Could not insert row: %s\nQuery: %s\nValues: %s", |
517
|
|
|
|
|
|
|
$_, |
518
|
|
|
|
|
|
|
$query, |
519
|
|
|
|
|
|
|
\@placeholder_values, |
520
|
|
|
|
|
|
|
); |
521
|
1
|
|
|
|
|
22
|
croak "Insert failed: $_"; |
522
|
56
|
|
|
|
|
3604
|
}; |
523
|
|
|
|
|
|
|
|
524
|
55
|
50
|
|
|
|
34436190
|
if ( defined( $primary_key_name ) ) |
525
|
|
|
|
|
|
|
{ |
526
|
|
|
|
|
|
|
$clean_data->{ $primary_key_name } = defined( $args{'generated_primary_key_value'} ) |
527
|
55
|
100
|
|
|
|
962
|
? $args{'generated_primary_key_value'} |
528
|
|
|
|
|
|
|
: $dbh->last_insert_id( undef, undef, $table_name, $primary_key_name ); |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
# Check that the object was correctly inserted. |
532
|
|
|
|
|
|
|
croak "Could not insert into table '$table_name': " . dumper( $data ) |
533
|
55
|
50
|
33
|
|
|
794
|
if defined( $primary_key_name ) && !defined( $clean_data->{ $primary_key_name } ); |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
# Make sure that the object reflects the changes in the database. |
536
|
55
|
|
|
|
|
727
|
$self->set( |
537
|
|
|
|
|
|
|
$clean_data, |
538
|
|
|
|
|
|
|
force => 1, |
539
|
|
|
|
|
|
|
); |
540
|
|
|
|
|
|
|
|
541
|
55
|
|
|
|
|
977
|
return; |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
=head2 new() |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
C has two possible uses: |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
=over 4 |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
=item * Creating a new empty object |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
my $object = My::Model::Book->new(); |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
=item * Retrieving a single object from the database. |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
# Retrieve by ID. |
558
|
|
|
|
|
|
|
my $object = My::Model::Book->new( { id => 3 } ) |
559
|
|
|
|
|
|
|
// die 'Book #3 does not exist'; |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
# Retrieve by unique field. |
562
|
|
|
|
|
|
|
my $object = My::Model::Book->new( { isbn => '9781449303587' } ) |
563
|
|
|
|
|
|
|
// die 'Book with ISBN 9781449303587 does not exist'; |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
=back |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
When retrieving a single object from the database, the first argument should be |
568
|
|
|
|
|
|
|
a hashref containing the following information to select a single row: |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
=over 4 |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
=item * id |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
The ID for the primary key on the underlying table. C is an alias for the |
575
|
|
|
|
|
|
|
primary key field name. |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
my $object = My::Model::Book->new( { id => 3 } ) |
578
|
|
|
|
|
|
|
// die 'Book #3 does not exist'; |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=item * A unique field |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
Allows passing a unique field and its value, in order to load the |
583
|
|
|
|
|
|
|
corresponding object from the database. |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
my $object = My::Model::Book->new( { isbn => '9781449303587' } ) |
586
|
|
|
|
|
|
|
// die 'Book with ISBN 9781449303587 does not exist'; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
Note that unique fields need to be defined in C, in the |
589
|
|
|
|
|
|
|
C key. |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
=back |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
This method also supports the following optional arguments, passed in a hash |
594
|
|
|
|
|
|
|
after the filtering criteria above-mentioned: |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=over 4 |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=item * skip_cache (default: 0) |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
By default, if cache is enabled with C in |
601
|
|
|
|
|
|
|
C, then C attempts to load the object from the cache |
602
|
|
|
|
|
|
|
first. Setting C to 1 forces the ORM to load the values from the |
603
|
|
|
|
|
|
|
database. |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
my $object = My::Model::Book->new( |
606
|
|
|
|
|
|
|
{ isbn => '9781449303587' }, |
607
|
|
|
|
|
|
|
skip_cache => 1, |
608
|
|
|
|
|
|
|
) // die 'Book with ISBN 9781449303587 does not exist'; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
=item * lock (default: 0) |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
By default, the underlying row is not locked when retrieving an object via |
613
|
|
|
|
|
|
|
C. Setting C to 1 forces the ORM to bypass the cache if any, and |
614
|
|
|
|
|
|
|
to lock the rows in the database as it retrieves them. |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
my $object = My::Model::Book->new( |
617
|
|
|
|
|
|
|
{ isbn => '9781449303587' }, |
618
|
|
|
|
|
|
|
lock => 1, |
619
|
|
|
|
|
|
|
) // die 'Book with ISBN 9781449303587 does not exist'; |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
=back |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
=cut |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
sub new |
626
|
|
|
|
|
|
|
{ |
627
|
79
|
|
|
79
|
1
|
138281
|
my ( $class, $filters, %args ) = @_; |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# If filters exist, they need to be a hashref. |
630
|
79
|
50
|
66
|
|
|
763
|
croak 'The first argument must be a hashref containing filtering criteria' |
631
|
|
|
|
|
|
|
if defined( $filters ) && !Data::Validate::Type::is_hashref( $filters ); |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# Check if we have a unique identifier passed. |
634
|
|
|
|
|
|
|
# Note: passing an ID is a subcase of passing field defined as unique, but |
635
|
|
|
|
|
|
|
# unique_fields() doesn't include the primary key name. |
636
|
79
|
|
|
|
|
320
|
my $unique_field; |
637
|
79
|
|
50
|
|
|
149
|
foreach my $field ( 'id', @{ $class->get_info('unique_fields') // [] } ) |
|
79
|
|
|
|
|
522
|
|
638
|
|
|
|
|
|
|
{ |
639
|
|
|
|
|
|
|
next |
640
|
82
|
100
|
|
|
|
322
|
if ! exists( $filters->{ $field } ); |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
# If the field exists in the list of filters, it needs to be |
643
|
|
|
|
|
|
|
# defined. Being undefined probably indicates a problem in the calling code. |
644
|
|
|
|
|
|
|
croak "Called new() with '$field' declared but not defined" |
645
|
9
|
50
|
|
|
|
42
|
if ! defined( $filters->{ $field } ); |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
# Detect if we're passing two unique fields to retrieve the object. This is |
648
|
|
|
|
|
|
|
# obviously bad. |
649
|
9
|
50
|
|
|
|
35
|
croak "Called new() with the unique argument '$field', but already found another unique argument '$unique_field'" |
650
|
|
|
|
|
|
|
if defined( $unique_field ); |
651
|
|
|
|
|
|
|
|
652
|
9
|
|
|
|
|
80
|
$unique_field = $field; |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
# Retrieve the object. |
656
|
79
|
|
|
|
|
136
|
my $self; |
657
|
79
|
100
|
|
|
|
243
|
if ( defined( $unique_field ) ) |
658
|
|
|
|
|
|
|
{ |
659
|
|
|
|
|
|
|
my $objects = $class->retrieve_list( |
660
|
|
|
|
|
|
|
{ |
661
|
|
|
|
|
|
|
$unique_field => $filters->{ $unique_field }, |
662
|
|
|
|
|
|
|
}, |
663
|
|
|
|
|
|
|
skip_cache => $args{'skip_cache'}, |
664
|
9
|
50
|
|
|
|
222
|
lock => $args{'lock'} ? 1 : 0, |
665
|
|
|
|
|
|
|
); |
666
|
|
|
|
|
|
|
|
667
|
9
|
|
|
|
|
37
|
my $objects_count = scalar( @$objects ); |
668
|
9
|
50
|
|
|
|
48
|
if ( $objects_count == 0 ) |
|
|
50
|
|
|
|
|
|
669
|
|
|
|
|
|
|
{ |
670
|
|
|
|
|
|
|
# No row found. |
671
|
0
|
|
|
|
|
0
|
$self = undef; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
elsif ( $objects_count == 1 ) |
674
|
|
|
|
|
|
|
{ |
675
|
9
|
|
|
|
|
25
|
$self = $objects->[0]; |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
else |
678
|
|
|
|
|
|
|
{ |
679
|
0
|
|
|
|
|
0
|
croak "Called new() with a set of non-unique arguments that returned $objects_count objects: " . dumper( \%args ); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
else |
683
|
|
|
|
|
|
|
{ |
684
|
70
|
|
|
|
|
255
|
$self = bless( {}, $class ); |
685
|
|
|
|
|
|
|
} |
686
|
|
|
|
|
|
|
|
687
|
79
|
|
|
|
|
452
|
return $self; |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
=head2 remove() |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
Delete in the database the row corresponding to the current object. |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
$book->remove(); |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
This method accepts the following arguments: |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
=over 4 |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=item * dbh |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
A different database handle from the default specified in C. |
704
|
|
|
|
|
|
|
This is particularly useful if you have separate reader/writer databases. |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=back |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=cut |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
sub remove |
711
|
|
|
|
|
|
|
{ |
712
|
5
|
|
|
5
|
1
|
1569
|
my ( $self, %args ) = @_; |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
# Retrieve the metadata for that table. |
715
|
5
|
|
|
|
|
11
|
my $class = ref( $self ); |
716
|
5
|
|
|
|
|
18
|
my $table_name = $self->get_info('table_name'); |
717
|
5
|
100
|
|
|
|
39
|
croak "The table name for class '$class' is not defined" |
718
|
|
|
|
|
|
|
if ! defined( $table_name ); |
719
|
|
|
|
|
|
|
|
720
|
4
|
|
|
|
|
11
|
my $primary_key_name = $self->get_info('primary_key_name'); |
721
|
4
|
100
|
|
|
|
24
|
croak "Missing primary key name for class '$class', cannot delete safely" |
722
|
|
|
|
|
|
|
if !defined( $primary_key_name ); |
723
|
|
|
|
|
|
|
|
724
|
3
|
100
|
|
|
|
20
|
croak "The object of class '$class' does not have a primary key value, cannot delete" |
725
|
|
|
|
|
|
|
if ! defined( $self->id() ); |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
# Allow using a different DB handle. |
728
|
2
|
|
|
|
|
150
|
my $dbh = $self->assert_dbh( $args{'dbh'} ); |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
# Prepare the query. |
731
|
2
|
|
|
|
|
30
|
my $query = sprintf( |
732
|
|
|
|
|
|
|
q| |
733
|
|
|
|
|
|
|
DELETE |
734
|
|
|
|
|
|
|
FROM %s |
735
|
|
|
|
|
|
|
WHERE %s = ? |
736
|
|
|
|
|
|
|
|, |
737
|
|
|
|
|
|
|
$dbh->quote_identifier( $table_name ), |
738
|
|
|
|
|
|
|
$dbh->quote_identifier( $primary_key_name ), |
739
|
|
|
|
|
|
|
); |
740
|
2
|
|
|
|
|
154
|
my @query_values = ( $self->id() ); |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
# Delete the row. |
743
|
|
|
|
|
|
|
try |
744
|
|
|
|
|
|
|
{ |
745
|
2
|
|
|
2
|
|
126
|
local $dbh->{'RaiseError'} = 1; |
746
|
2
|
|
|
|
|
55
|
$dbh->do( |
747
|
|
|
|
|
|
|
$query, |
748
|
|
|
|
|
|
|
{}, |
749
|
|
|
|
|
|
|
@query_values, |
750
|
|
|
|
|
|
|
); |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
catch |
753
|
|
|
|
|
|
|
{ |
754
|
1
|
|
|
1
|
|
40
|
$log->fatalf( |
755
|
|
|
|
|
|
|
"Could not delete row: %s\nQuery: %s\nValues: %s", |
756
|
|
|
|
|
|
|
$_, |
757
|
|
|
|
|
|
|
$query, |
758
|
|
|
|
|
|
|
\@query_values, |
759
|
|
|
|
|
|
|
); |
760
|
1
|
|
|
|
|
114
|
croak "Remove failed: $_"; |
761
|
2
|
|
|
|
|
26
|
}; |
762
|
|
|
|
|
|
|
|
763
|
1
|
|
|
|
|
196219
|
return; |
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
=head2 retrieve_list_nocache() |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
Dispatch of retrieve_list() when objects should not be retrieved from the cache. |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
See C for the parameters this method accepts. |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
=cut |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
sub retrieve_list_nocache ## no critic (Subroutines::ProhibitExcessComplexity) |
776
|
|
|
|
|
|
|
{ |
777
|
27
|
|
|
27
|
1
|
8872
|
my ( $class, $filters, %args ) = @_; |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# Handle a different database handle, if requested. |
780
|
27
|
|
|
|
|
165
|
my $dbh = $class->assert_dbh( $args{'dbh'} ); |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
# TODO: If we're asked to lock the rows, we check that we're in a transaction. |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
# Check if we were passed arguments we don't know how to handle. This will |
785
|
|
|
|
|
|
|
# help the calling code to detect typos or deprecated arguments. |
786
|
27
|
|
|
|
|
119
|
foreach my $arg ( keys %args ) |
787
|
|
|
|
|
|
|
{ |
788
|
36
|
50
|
|
|
|
126
|
next if defined( $RETRIEVE_LIST_VALID_ARGUMENTS->{ $arg } ); |
789
|
|
|
|
|
|
|
|
790
|
0
|
|
|
|
|
0
|
croak( |
791
|
|
|
|
|
|
|
"The argument '$arg' passed to DBIx::NinjaORM->retrieve_list() via " . |
792
|
|
|
|
|
|
|
"${class}->retrieve_list() is not handled by the superclass. " . |
793
|
|
|
|
|
|
|
"It could mean that you have a typo in the name or that the argument has " . |
794
|
|
|
|
|
|
|
"been deprecated." |
795
|
|
|
|
|
|
|
); |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# Check the parameters and prepare the corresponding where clauses. |
799
|
27
|
|
50
|
|
|
182
|
my $where_clauses = $args{'query_extensions'}->{'where_clauses'} || []; |
800
|
27
|
|
50
|
|
|
201
|
my $where_values = $args{'query_extensions'}->{'where_values'} || []; |
801
|
27
|
|
|
|
|
37
|
my $filtering_field_keys_passed = 0; |
802
|
27
|
|
|
|
|
217
|
my $filtering_criteria = $class->parse_filtering_criteria( |
803
|
|
|
|
|
|
|
$filters |
804
|
|
|
|
|
|
|
); |
805
|
26
|
50
|
|
|
|
84
|
if ( defined( $filtering_criteria ) ) |
806
|
|
|
|
|
|
|
{ |
807
|
26
|
50
|
|
|
|
40
|
push( @$where_clauses, @{ $filtering_criteria->[0] || [] } ); |
|
26
|
|
|
|
|
111
|
|
808
|
26
|
50
|
|
|
|
55
|
push( @$where_values, @{ $filtering_criteria->[1] || [] } ); |
|
26
|
|
|
|
|
97
|
|
809
|
26
|
|
|
|
|
37
|
$filtering_field_keys_passed = $filtering_criteria->[2]; |
810
|
|
|
|
|
|
|
} |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
# Make sure there's at least one argument, unless allow_all=1 or there is |
813
|
|
|
|
|
|
|
# custom where clauses. |
814
|
|
|
|
|
|
|
croak 'At least one argument must be passed' |
815
|
26
|
100
|
100
|
|
|
430
|
if !$args{'allow_all'} && !$filtering_field_keys_passed && scalar( @$where_clauses ) == 0; |
|
|
|
66
|
|
|
|
|
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
# Prepare the ORDER BY. |
818
|
22
|
|
|
|
|
73
|
my $table_name = $class->get_info('table_name'); |
819
|
22
|
100
|
66
|
|
|
163
|
my $order_by = defined( $args{'order_by'} ) && ( $args{'order_by'} ne '' ) |
|
|
100
|
|
|
|
|
|
820
|
|
|
|
|
|
|
? "ORDER BY $args{'order_by'}" |
821
|
|
|
|
|
|
|
: $class->get_info('has_created_field') |
822
|
|
|
|
|
|
|
? "ORDER BY " . $dbh->quote_identifier( $table_name ) . ".created ASC" |
823
|
|
|
|
|
|
|
: "ORDER BY " . $dbh->quote_identifier( $table_name ) . '.' . $class->get_info('primary_key_name'); |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
# Prepare quoted identifiers. |
826
|
22
|
|
|
|
|
507
|
my $primary_key_name = $class->get_info('primary_key_name'); |
827
|
22
|
|
|
|
|
104
|
my $quoted_primary_key_name = $dbh->quote_identifier( $primary_key_name ); |
828
|
22
|
|
|
|
|
440
|
my $quoted_table_name = $dbh->quote_identifier( $table_name ); |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
# Prepare the SQL request elements. |
831
|
22
|
100
|
|
|
|
450
|
my $where = scalar( @$where_clauses ) != 0 |
832
|
|
|
|
|
|
|
? 'WHERE ( ' . join( ' ) AND ( ', @$where_clauses ) . ' )' |
833
|
|
|
|
|
|
|
: ''; |
834
|
22
|
|
100
|
|
|
145
|
my $joins = $args{'query_extensions'}->{'joins'} || ''; |
835
|
|
|
|
|
|
|
my $limit = defined( $args{'limit'} ) && ( $args{'limit'} =~ m/^\d+$/ ) |
836
|
22
|
50
|
33
|
|
|
139
|
? 'LIMIT ' . $args{'limit'} |
837
|
|
|
|
|
|
|
: ''; |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
# Prepare the list of fields to retrieve. |
840
|
22
|
|
|
|
|
64
|
my $fields; |
841
|
22
|
50
|
33
|
|
|
189
|
if ( defined( $args{'exclude_fields'} ) || defined( $args{'select_fields'} ) ) |
842
|
|
|
|
|
|
|
{ |
843
|
0
|
|
|
|
|
0
|
my $table_schema = $class->get_table_schema(); |
844
|
0
|
0
|
|
|
|
0
|
croak "Failed to retrieve schema for table '$table_name'" |
845
|
|
|
|
|
|
|
if !defined( $table_schema ); |
846
|
0
|
|
|
|
|
0
|
my $column_names = $table_schema->get_column_names(); |
847
|
0
|
0
|
|
|
|
0
|
croak "Failed to retrieve column names for table '$table_name'" |
848
|
|
|
|
|
|
|
if !defined( $column_names ); |
849
|
|
|
|
|
|
|
|
850
|
0
|
|
|
|
|
0
|
my @filtered_fields = (); |
851
|
0
|
0
|
0
|
|
|
0
|
if ( defined( $args{'exclude_fields'} ) && !defined( $args{'select_fields'} ) ) |
|
|
0
|
0
|
|
|
|
|
852
|
|
|
|
|
|
|
{ |
853
|
0
|
|
|
|
|
0
|
my %excluded_fields = map { $_ => 1 } @{ $args{'exclude_fields'} }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
854
|
0
|
|
|
|
|
0
|
foreach my $field ( @$column_names ) |
855
|
|
|
|
|
|
|
{ |
856
|
|
|
|
|
|
|
$excluded_fields{ $field } |
857
|
0
|
0
|
|
|
|
0
|
? delete( $excluded_fields{ $field } ) |
858
|
|
|
|
|
|
|
: push( @filtered_fields, $field ); |
859
|
|
|
|
|
|
|
} |
860
|
0
|
0
|
|
|
|
0
|
croak "The following excluded fields are not valid: " . join( ', ', keys %excluded_fields ) |
861
|
|
|
|
|
|
|
if scalar( keys %excluded_fields ) != 0; |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
elsif ( !defined( $args{'exclude_fields'} ) && defined( $args{'select_fields'} ) ) |
864
|
|
|
|
|
|
|
{ |
865
|
0
|
|
|
|
|
0
|
my %selected_fields = map { $_ => 1 } @{ $args{'select_fields'} }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
866
|
|
|
|
|
|
|
croak 'The primary key must be in the list of selected fields' |
867
|
0
|
0
|
0
|
|
|
0
|
if defined( $primary_key_name ) && !$selected_fields{ $primary_key_name }; |
868
|
|
|
|
|
|
|
|
869
|
0
|
|
|
|
|
0
|
foreach my $field ( @$column_names ) |
870
|
|
|
|
|
|
|
{ |
871
|
0
|
0
|
|
|
|
0
|
next if !$selected_fields{ $field }; |
872
|
0
|
|
|
|
|
0
|
push( @filtered_fields, $field ); |
873
|
0
|
|
|
|
|
0
|
delete( $selected_fields{ $field } ); |
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
|
876
|
0
|
0
|
|
|
|
0
|
croak "The following restricted fields are not valid: " . join( ', ', keys %selected_fields ) |
877
|
|
|
|
|
|
|
if scalar( keys %selected_fields ) != 0; |
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
else |
880
|
|
|
|
|
|
|
{ |
881
|
0
|
|
|
|
|
0
|
croak "The 'exclude_fields' and 'select_fields' options are not compatible, use one or the other"; |
882
|
|
|
|
|
|
|
} |
883
|
|
|
|
|
|
|
|
884
|
0
|
0
|
|
|
|
0
|
croak "No fields left after filtering out the excluded/restricted fields" |
885
|
|
|
|
|
|
|
if scalar( @filtered_fields ) == 0; |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
$fields = join( |
888
|
|
|
|
|
|
|
', ', |
889
|
0
|
|
|
|
|
0
|
map { "$quoted_table_name.$_" } @filtered_fields |
|
0
|
|
|
|
|
0
|
|
890
|
|
|
|
|
|
|
); |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
else |
893
|
|
|
|
|
|
|
{ |
894
|
22
|
|
|
|
|
58
|
$fields = $quoted_table_name . '.*'; |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
$fields .= ', ' . $args{'query_extensions'}->{'joined_fields'} |
898
|
22
|
100
|
|
|
|
86
|
if defined( $args{'query_extensions'}->{'joined_fields'} ); |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
# We need to make an exception for lock=1 when using SQLite, since |
901
|
|
|
|
|
|
|
# SQLite doesn't support FOR UPDATE. |
902
|
|
|
|
|
|
|
# Per http://sqlite.org/cvstrac/wiki?p=UnsupportedSql, the entire |
903
|
|
|
|
|
|
|
# database is locked when updating any bit of it, so we can simply |
904
|
|
|
|
|
|
|
# ignore the locking request here. |
905
|
22
|
|
|
|
|
44
|
my $lock = ''; |
906
|
22
|
100
|
|
|
|
84
|
if ( $args{'lock'} ) |
907
|
|
|
|
|
|
|
{ |
908
|
1
|
|
50
|
|
|
21
|
my $database_type = $dbh->{'Driver'}->{'Name'} || ''; |
909
|
1
|
50
|
|
|
|
5
|
if ( $database_type eq 'SQLite' ) |
910
|
|
|
|
|
|
|
{ |
911
|
1
|
|
|
|
|
7
|
$log->info( |
912
|
|
|
|
|
|
|
'SQLite does not support locking since only one process at a time is ', |
913
|
|
|
|
|
|
|
'allowed to update a given SQLite database, so lock=1 is ignored.', |
914
|
|
|
|
|
|
|
); |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
else |
917
|
|
|
|
|
|
|
{ |
918
|
0
|
|
|
|
|
0
|
$lock = 'FOR UPDATE'; |
919
|
|
|
|
|
|
|
} |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
# Check if we need to paginate. |
923
|
22
|
|
|
|
|
47
|
my $pagination_info = {}; |
924
|
22
|
100
|
|
|
|
82
|
if ( defined( $args{'pagination'} ) ) |
925
|
|
|
|
|
|
|
{ |
926
|
|
|
|
|
|
|
# Allow for pagination => 1 as a shortcut to get all the defaults. |
927
|
|
|
|
|
|
|
$args{'pagination'} = {} |
928
|
5
|
100
|
66
|
|
|
11
|
if !Data::Validate::Type::is_hashref( $args{'pagination'} ) && ( $args{'pagination'} eq '1' ); |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
# Set defaults. |
931
|
|
|
|
|
|
|
$pagination_info->{'per_page'} = ( $args{'pagination'}->{'per_page'} || '' ) =~ m/^\d+$/ |
932
|
5
|
100
|
100
|
|
|
99
|
? $args{'pagination'}->{'per_page'} |
933
|
|
|
|
|
|
|
: 20; |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# Count the total number of results. |
936
|
|
|
|
|
|
|
my $count_data = $dbh->selectrow_arrayref( |
937
|
|
|
|
|
|
|
sprintf( |
938
|
|
|
|
|
|
|
q| |
939
|
|
|
|
|
|
|
SELECT COUNT(*) |
940
|
|
|
|
|
|
|
FROM %s |
941
|
|
|
|
|
|
|
%s |
942
|
|
|
|
|
|
|
%s |
943
|
|
|
|
|
|
|
|, |
944
|
|
|
|
|
|
|
$quoted_table_name, |
945
|
|
|
|
|
|
|
$joins, |
946
|
|
|
|
|
|
|
$where, |
947
|
|
|
|
|
|
|
), |
948
|
|
|
|
|
|
|
{}, |
949
|
5
|
|
|
|
|
27
|
map { @$_ } @$where_values, |
|
5
|
|
|
|
|
65
|
|
950
|
|
|
|
|
|
|
); |
951
|
5
|
50
|
33
|
|
|
1792
|
$pagination_info->{'total_count'} = defined( $count_data ) && scalar( @$count_data ) != 0 |
952
|
|
|
|
|
|
|
? $count_data->[0] |
953
|
|
|
|
|
|
|
: undef; |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
# Calculate what the max page can be. |
956
|
5
|
|
|
|
|
27
|
$pagination_info->{'page_max'} = int( ( $pagination_info->{'total_count'} - 1 ) / $pagination_info->{'per_page'} ) + 1; |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
# Determine what the current page is. |
959
|
|
|
|
|
|
|
$pagination_info->{'page'} = ( ( $args{'pagination'}->{'page'} || '' ) =~ m/^\d+$/ ) && ( $args{'pagination'}->{'page'} > 0 ) |
960
|
|
|
|
|
|
|
? $pagination_info->{'page_max'} < $args{'pagination'}->{'page'} |
961
|
|
|
|
|
|
|
? $pagination_info->{'page_max'} |
962
|
5
|
50
|
66
|
|
|
51
|
: $args{'pagination'}->{'page'} |
|
|
100
|
|
|
|
|
|
963
|
|
|
|
|
|
|
: 1; |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
# Set LIMIT and OFFSET. |
966
|
|
|
|
|
|
|
$limit = "LIMIT $pagination_info->{'per_page'} " |
967
|
5
|
|
|
|
|
24
|
. 'OFFSET ' . ( ( $pagination_info->{'page'} - 1 ) * $pagination_info->{'per_page'} ); |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
# If we need to lock the rows and there's joins, let's do this in two steps: |
971
|
|
|
|
|
|
|
# 1) Lock the rows without join. |
972
|
|
|
|
|
|
|
# 2) Using the IDs found, do another select to retrieve the data with the joins. |
973
|
22
|
50
|
33
|
|
|
98
|
if ( ( $lock ne '' ) && ( $joins ne '' ) ) |
974
|
|
|
|
|
|
|
{ |
975
|
0
|
|
|
|
|
0
|
my $query = sprintf( |
976
|
|
|
|
|
|
|
q| |
977
|
|
|
|
|
|
|
SELECT %s |
978
|
|
|
|
|
|
|
FROM %s |
979
|
|
|
|
|
|
|
%s |
980
|
|
|
|
|
|
|
ORDER BY %s ASC |
981
|
|
|
|
|
|
|
%s |
982
|
|
|
|
|
|
|
%s |
983
|
|
|
|
|
|
|
|, |
984
|
|
|
|
|
|
|
$quoted_primary_key_name, |
985
|
|
|
|
|
|
|
$quoted_table_name, |
986
|
|
|
|
|
|
|
$where, |
987
|
|
|
|
|
|
|
$quoted_primary_key_name, |
988
|
|
|
|
|
|
|
$limit, |
989
|
|
|
|
|
|
|
$lock, |
990
|
|
|
|
|
|
|
); |
991
|
|
|
|
|
|
|
|
992
|
0
|
|
|
|
|
0
|
my @query_values = map { @$_ } @$where_values; |
|
0
|
|
|
|
|
0
|
|
993
|
|
|
|
|
|
|
$log->debugf( |
994
|
|
|
|
|
|
|
"Performing pre-locking query:\n%s\nValues:\n%s", |
995
|
|
|
|
|
|
|
$query, |
996
|
|
|
|
|
|
|
\@query_values, |
997
|
0
|
0
|
|
|
|
0
|
) if $args{'show_queries'}; |
998
|
|
|
|
|
|
|
|
999
|
0
|
|
|
|
|
0
|
my $locked_ids; |
1000
|
|
|
|
|
|
|
try |
1001
|
|
|
|
|
|
|
{ |
1002
|
0
|
|
|
0
|
|
0
|
local $dbh->{'RaiseError'} = 1; |
1003
|
0
|
|
|
|
|
0
|
$locked_ids = $dbh->selectall_arrayref( |
1004
|
|
|
|
|
|
|
$query, |
1005
|
|
|
|
|
|
|
{ |
1006
|
|
|
|
|
|
|
Columns => [ 1 ], |
1007
|
|
|
|
|
|
|
}, |
1008
|
|
|
|
|
|
|
@query_values |
1009
|
|
|
|
|
|
|
); |
1010
|
|
|
|
|
|
|
} |
1011
|
|
|
|
|
|
|
catch |
1012
|
|
|
|
|
|
|
{ |
1013
|
0
|
|
|
0
|
|
0
|
$log->fatalf( |
1014
|
|
|
|
|
|
|
"Could not select rows in pre-locking query: %s\nQuery: %s\nValues:\n%s", |
1015
|
|
|
|
|
|
|
$_, |
1016
|
|
|
|
|
|
|
$query, |
1017
|
|
|
|
|
|
|
\@query_values, |
1018
|
|
|
|
|
|
|
); |
1019
|
0
|
|
|
|
|
0
|
croak "Failed select: $_"; |
1020
|
0
|
|
|
|
|
0
|
}; |
1021
|
|
|
|
|
|
|
|
1022
|
0
|
0
|
0
|
|
|
0
|
if ( !defined( $locked_ids ) || ( scalar( @$locked_ids ) == 0 ) ) |
1023
|
|
|
|
|
|
|
{ |
1024
|
0
|
|
|
|
|
0
|
return []; |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
0
|
|
|
|
|
0
|
$where = sprintf( |
1028
|
|
|
|
|
|
|
'WHERE %s.%s IN ( %s )', |
1029
|
|
|
|
|
|
|
$quoted_table_name, |
1030
|
|
|
|
|
|
|
$quoted_primary_key_name, |
1031
|
|
|
|
|
|
|
join( ', ', ( ('?') x scalar( @$locked_ids ) ) ), |
1032
|
|
|
|
|
|
|
); |
1033
|
0
|
|
|
|
|
0
|
$where_values = [ [ map { $_->[0] } @$locked_ids ] ]; |
|
0
|
|
|
|
|
0
|
|
1034
|
0
|
|
|
|
|
0
|
$lock = ''; |
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
# Prepare the query elements. |
1038
|
22
|
|
|
|
|
163
|
my $query = sprintf( |
1039
|
|
|
|
|
|
|
q| |
1040
|
|
|
|
|
|
|
SELECT %s |
1041
|
|
|
|
|
|
|
FROM %s |
1042
|
|
|
|
|
|
|
%s %s %s %s %s |
1043
|
|
|
|
|
|
|
|, |
1044
|
|
|
|
|
|
|
$fields, |
1045
|
|
|
|
|
|
|
$quoted_table_name, |
1046
|
|
|
|
|
|
|
$joins, |
1047
|
|
|
|
|
|
|
$where, |
1048
|
|
|
|
|
|
|
$order_by, |
1049
|
|
|
|
|
|
|
$limit, |
1050
|
|
|
|
|
|
|
$lock, |
1051
|
|
|
|
|
|
|
); |
1052
|
22
|
|
|
|
|
57
|
my @query_values = map { @$_ } @$where_values; |
|
20
|
|
|
|
|
90
|
|
1053
|
|
|
|
|
|
|
$log->debugf( |
1054
|
|
|
|
|
|
|
"Performing query:\n%s\nValues:\n%s", |
1055
|
|
|
|
|
|
|
$query, |
1056
|
|
|
|
|
|
|
\@query_values, |
1057
|
22
|
50
|
|
|
|
78
|
) if $args{'show_queries'}; |
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
# Retrieve the objects. |
1060
|
22
|
|
|
|
|
32
|
my $sth; |
1061
|
|
|
|
|
|
|
try |
1062
|
|
|
|
|
|
|
{ |
1063
|
22
|
|
|
22
|
|
1688
|
local $dbh->{'RaiseError'} = 1; |
1064
|
22
|
|
|
|
|
596
|
$sth = $dbh->prepare( $query ); |
1065
|
22
|
|
|
|
|
6527
|
$sth->execute( @query_values ); |
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
catch |
1068
|
|
|
|
|
|
|
{ |
1069
|
0
|
|
|
0
|
|
0
|
$log->fatalf( |
1070
|
|
|
|
|
|
|
"Could not select rows: %s\nQuery: %s\nValues: %s", |
1071
|
|
|
|
|
|
|
$_, |
1072
|
|
|
|
|
|
|
$query, |
1073
|
|
|
|
|
|
|
\@query_values, |
1074
|
|
|
|
|
|
|
); |
1075
|
0
|
|
|
|
|
0
|
croak "Failed select: $_"; |
1076
|
22
|
|
|
|
|
250
|
}; |
1077
|
|
|
|
|
|
|
|
1078
|
22
|
|
|
|
|
449
|
my $object_list = []; |
1079
|
22
|
|
|
|
|
910
|
while ( my $ref = $sth->fetchrow_hashref() ) |
1080
|
|
|
|
|
|
|
{ |
1081
|
84
|
|
|
|
|
2063
|
my $object = Storable::dclone( $ref ); |
1082
|
84
|
|
|
|
|
135
|
bless( $object, $class ); |
1083
|
|
|
|
|
|
|
|
1084
|
84
|
|
|
|
|
249
|
$object->reorganize_non_native_fields(); |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
# Add a flag to distinguish objects that were populated via |
1087
|
|
|
|
|
|
|
# retrieve_list_nocache(), as those objects are known for sure to contain |
1088
|
|
|
|
|
|
|
# all the keys for columns that exist in the database. We also won't have to |
1089
|
|
|
|
|
|
|
# worry about missing defaults, like insert() would have to. |
1090
|
84
|
|
|
|
|
130
|
$object->{'_populated_by_retrieve_list'} = 1; |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
# Add cache debugging information. |
1093
|
84
|
|
|
|
|
189
|
$object->{'_debug'}->{'list_cache_used'} = 0; |
1094
|
84
|
|
|
|
|
89
|
$object->{'_debug'}->{'object_cache_used'} = 0; |
1095
|
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
|
# Store if we've excluded any fields, as it will impact caching in |
1097
|
|
|
|
|
|
|
# retrieve_list(). |
1098
|
|
|
|
|
|
|
$object->{'_excluded_fields'} = $args{'exclude_fields'} |
1099
|
84
|
50
|
|
|
|
194
|
if defined( $args{'exclude_fields'} ); |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
# Store if we've restricted to any fields, as it will impact caching in |
1102
|
|
|
|
|
|
|
# retrieve_list(). |
1103
|
|
|
|
|
|
|
$object->{'_selected_fields'} = $args{'select_fields'} |
1104
|
84
|
50
|
|
|
|
155
|
if defined( $args{'select_fields'} ); |
1105
|
|
|
|
|
|
|
|
1106
|
84
|
|
|
|
|
1470
|
push( @$object_list, $object ); |
1107
|
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
|
1109
|
22
|
100
|
66
|
|
|
137
|
if ( wantarray && defined( $args{'pagination'} ) ) |
1110
|
|
|
|
|
|
|
{ |
1111
|
5
|
|
|
|
|
97
|
return ( $object_list, $pagination_info ); |
1112
|
|
|
|
|
|
|
} |
1113
|
|
|
|
|
|
|
else |
1114
|
|
|
|
|
|
|
{ |
1115
|
17
|
|
|
|
|
407
|
return $object_list; |
1116
|
|
|
|
|
|
|
} |
1117
|
|
|
|
|
|
|
} |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
=head2 set() |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
Set fields and values on an object. |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
$book->set( |
1125
|
|
|
|
|
|
|
{ |
1126
|
|
|
|
|
|
|
name => 'Learning Perl', |
1127
|
|
|
|
|
|
|
isbn => '9781449303587', |
1128
|
|
|
|
|
|
|
}, |
1129
|
|
|
|
|
|
|
); |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
This method supports the following arguments: |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
=over 4 |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
=item * force |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
Set the properties on the object without going through C. |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
$book->set( |
1140
|
|
|
|
|
|
|
{ |
1141
|
|
|
|
|
|
|
name => 'Learning Perl', |
1142
|
|
|
|
|
|
|
isbn => '9781449303587', |
1143
|
|
|
|
|
|
|
}, |
1144
|
|
|
|
|
|
|
force => 1, |
1145
|
|
|
|
|
|
|
); |
1146
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
=back |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
=cut |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
sub set ## no critic (NamingConventions::ProhibitAmbiguousNames, Subroutines::RequireArgUnpacking) |
1152
|
|
|
|
|
|
|
{ |
1153
|
67
|
100
|
|
67
|
1
|
3391
|
croak 'The first argument passed must be a hashref' |
1154
|
|
|
|
|
|
|
if !Data::Validate::Type::is_hashref( $_[1] ); |
1155
|
|
|
|
|
|
|
|
1156
|
66
|
|
|
|
|
2247
|
my ( $self, $data, %args ) = @_; |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
# Validate the data first, unless force=1. |
1159
|
|
|
|
|
|
|
$data = $self->validate_data( $data ) |
1160
|
66
|
100
|
|
|
|
318
|
if !$args{'force'}; |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
# Update the object. |
1163
|
64
|
|
|
|
|
341
|
foreach ( keys %$data ) |
1164
|
|
|
|
|
|
|
{ |
1165
|
236
|
|
|
|
|
554
|
$self->{ $_ } = $data->{ $_ }; |
1166
|
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
|
|
1168
|
64
|
|
|
|
|
204
|
return; |
1169
|
|
|
|
|
|
|
} |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
=head2 static_class_info() |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
This methods sets defaults as well as general information for a specific class. |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
It allows for example indicating what table the objects will be related to, or |
1177
|
|
|
|
|
|
|
what database handle to use. See L for the |
1178
|
|
|
|
|
|
|
full list of options that can be set or overridden. |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
Here's what a typical subclassed C would look like: |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
sub static_class_info |
1183
|
|
|
|
|
|
|
{ |
1184
|
|
|
|
|
|
|
my ( $class ) = @_; |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
# Retrieve defaults coming from higher in the inheritance chain, up |
1187
|
|
|
|
|
|
|
# to DBIx::NinjaORM->static_class_info(). |
1188
|
|
|
|
|
|
|
my $info = $class->SUPER::static_class_info(); |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
# Set or override information. |
1191
|
|
|
|
|
|
|
$info->set( |
1192
|
|
|
|
|
|
|
{ |
1193
|
|
|
|
|
|
|
table_name => 'books', |
1194
|
|
|
|
|
|
|
primary_key_name => 'book_id', |
1195
|
|
|
|
|
|
|
default_dbh => DBI->connect( |
1196
|
|
|
|
|
|
|
"dbi:mysql:[database_name]:localhost:3306", |
1197
|
|
|
|
|
|
|
"[user]", |
1198
|
|
|
|
|
|
|
"[password]", |
1199
|
|
|
|
|
|
|
), |
1200
|
|
|
|
|
|
|
} |
1201
|
|
|
|
|
|
|
); |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
# Return the updated information hashref. |
1204
|
|
|
|
|
|
|
return $info; |
1205
|
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
=cut |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
sub static_class_info |
1210
|
|
|
|
|
|
|
{ |
1211
|
79
|
|
|
79
|
1
|
2494
|
return DBIx::NinjaORM::StaticClassInfo->new(); |
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
=head2 update() |
1216
|
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
Update the row in the database corresponding to the current object, using the |
1218
|
|
|
|
|
|
|
primary key and its value on the object. |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
$book->update( |
1221
|
|
|
|
|
|
|
{ |
1222
|
|
|
|
|
|
|
name => 'Learning Perl', |
1223
|
|
|
|
|
|
|
} |
1224
|
|
|
|
|
|
|
); |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
This method supports the following optional arguments: |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
=over 4 |
1229
|
|
|
|
|
|
|
|
1230
|
|
|
|
|
|
|
=item * skip_modified_update (default 0) |
1231
|
|
|
|
|
|
|
|
1232
|
|
|
|
|
|
|
Do not update the 'modified' field. This is useful if you're using 'modified' to |
1233
|
|
|
|
|
|
|
record when was the last time a human changed the row, but you want to exclude |
1234
|
|
|
|
|
|
|
automated changes. |
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
=item * dbh |
1237
|
|
|
|
|
|
|
|
1238
|
|
|
|
|
|
|
A different database handle than the default one specified in |
1239
|
|
|
|
|
|
|
C, but it has to be writable. |
1240
|
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
|
=item * restrictions |
1242
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
The update statement is limited using the primary key. This parameter however |
1244
|
|
|
|
|
|
|
allows adding extra restrictions on the update. Additional clauses passed here |
1245
|
|
|
|
|
|
|
are joined with AND. |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
$book->update( |
1248
|
|
|
|
|
|
|
{ |
1249
|
|
|
|
|
|
|
author_id => 1234, |
1250
|
|
|
|
|
|
|
}, |
1251
|
|
|
|
|
|
|
restrictions => |
1252
|
|
|
|
|
|
|
{ |
1253
|
|
|
|
|
|
|
where_clauses => [ 'status != ?' ], |
1254
|
|
|
|
|
|
|
where_values => [ 'protected' ], |
1255
|
|
|
|
|
|
|
}, |
1256
|
|
|
|
|
|
|
); |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
=item * set |
1259
|
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
|
\%data contains the data to update the row with "SET field = value". It is |
1261
|
|
|
|
|
|
|
however sometimes necessary to use more complex SETs, such as |
1262
|
|
|
|
|
|
|
"SET field = field + value", which is what this parameter allows. |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
Important: you will need to subclass C in your model classes and |
1265
|
|
|
|
|
|
|
update manually the values upon success (or reload the object), as |
1266
|
|
|
|
|
|
|
L cannot determine the end result of those complex sets on the |
1267
|
|
|
|
|
|
|
database side. |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
$book->update( |
1270
|
|
|
|
|
|
|
{ |
1271
|
|
|
|
|
|
|
name => 'Learning Perl', |
1272
|
|
|
|
|
|
|
}, |
1273
|
|
|
|
|
|
|
set => |
1274
|
|
|
|
|
|
|
{ |
1275
|
|
|
|
|
|
|
placeholders => [ 'edits = edits + ?' ], |
1276
|
|
|
|
|
|
|
values => [ 1 ], |
1277
|
|
|
|
|
|
|
} |
1278
|
|
|
|
|
|
|
); |
1279
|
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
=back |
1281
|
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
|
=cut |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
sub update ## no critic (Subroutines::RequireArgUnpacking) |
1285
|
|
|
|
|
|
|
{ |
1286
|
9
|
100
|
|
9
|
1
|
11367
|
croak 'The first argument passed must be a hashref' |
1287
|
|
|
|
|
|
|
if !Data::Validate::Type::is_hashref( $_[1] ); |
1288
|
|
|
|
|
|
|
|
1289
|
8
|
|
|
|
|
164
|
my ( $self, $data, %args ) = @_; |
1290
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
# Allow using a different DB handle. |
1292
|
8
|
|
|
|
|
56
|
my $dbh = $self->assert_dbh( $args{'dbh'} ); |
1293
|
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
|
# Clean input |
1295
|
6
|
|
|
|
|
51
|
my $clean_data = $self->validate_data( $data, %args ); |
1296
|
6
|
50
|
|
|
|
27
|
return 0 |
1297
|
|
|
|
|
|
|
if !defined( $clean_data ); |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
# Set defaults |
1300
|
|
|
|
|
|
|
$clean_data->{'modified'} = $self->get_current_time() |
1301
|
6
|
100
|
66
|
|
|
180
|
if !$args{'skip_modified_update'} && $self->get_info('has_modified_field'); |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
# If there's nothing to update, bail out. |
1304
|
6
|
50
|
|
|
|
131
|
if ( scalar( keys %$clean_data ) == 0 ) |
1305
|
|
|
|
|
|
|
{ |
1306
|
0
|
0
|
|
|
|
0
|
$log->debug( 'No data left to update after validation, skipping SQL update' ) |
1307
|
|
|
|
|
|
|
if $self->is_verbose(); |
1308
|
0
|
|
|
|
|
0
|
return; |
1309
|
|
|
|
|
|
|
} |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
# Retrieve the meta-data for that table. |
1312
|
6
|
|
|
|
|
84
|
my $class = ref( $self ); |
1313
|
|
|
|
|
|
|
|
1314
|
6
|
|
|
|
|
21
|
my $table_name = $self->get_info('table_name'); |
1315
|
6
|
50
|
|
|
|
28
|
croak "The table name for class '$class' is not defined" |
1316
|
|
|
|
|
|
|
if ! defined( $table_name ); |
1317
|
|
|
|
|
|
|
|
1318
|
6
|
|
|
|
|
21
|
my $primary_key_name = $self->get_info('primary_key_name'); |
1319
|
|
|
|
|
|
|
croak "Missing primary key name for class '$class', cannot force primary key value" |
1320
|
6
|
50
|
33
|
|
|
33
|
if !defined( $primary_key_name ) && defined( $args{'generated_primary_key_value'} ); |
1321
|
|
|
|
|
|
|
|
1322
|
6
|
50
|
|
|
|
115
|
croak "The object of class '$class' does not have a primary key value, cannot update" |
1323
|
|
|
|
|
|
|
if ! defined( $self->id() ); |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
# Prepare the SQL request elements. |
1326
|
6
|
|
50
|
|
|
47
|
my $where_clauses = $args{'restrictions'}->{'where_clauses'} || []; |
1327
|
6
|
|
50
|
|
|
34
|
my $where_values = $args{'restrictions'}->{'where_values'} || []; |
1328
|
6
|
|
|
|
|
26
|
push( @$where_clauses, $primary_key_name . ' = ?' ); |
1329
|
6
|
|
|
|
|
18
|
push( @$where_values, [ $self->id() ] ); |
1330
|
|
|
|
|
|
|
|
1331
|
|
|
|
|
|
|
# Prepare the values to set. |
1332
|
6
|
|
|
|
|
18
|
my @set_placeholders = (); |
1333
|
6
|
|
|
|
|
12
|
my @set_values = (); |
1334
|
6
|
|
|
|
|
24
|
foreach my $key ( keys %$clean_data ) |
1335
|
|
|
|
|
|
|
{ |
1336
|
11
|
100
|
|
|
|
89
|
if ( $key eq 'modified' ) |
1337
|
|
|
|
|
|
|
{ |
1338
|
|
|
|
|
|
|
# 'created' supports SQL keywords and is quoted by get_current_time() if |
1339
|
|
|
|
|
|
|
# needed, so we don't use placeholders. |
1340
|
5
|
|
|
|
|
36
|
push( @set_placeholders, $dbh->quote_identifier( $key ) . ' = ' . $clean_data->{ $key } ); |
1341
|
|
|
|
|
|
|
} |
1342
|
|
|
|
|
|
|
else |
1343
|
|
|
|
|
|
|
{ |
1344
|
|
|
|
|
|
|
# All the other data need to be inserted using placeholders, for |
1345
|
|
|
|
|
|
|
# security purposes. |
1346
|
6
|
|
|
|
|
71
|
push( @set_placeholders, $dbh->quote_identifier( $key ) . ' = ?' ); |
1347
|
6
|
|
|
|
|
192
|
push( @set_values, $clean_data->{ $key } ); |
1348
|
|
|
|
|
|
|
} |
1349
|
|
|
|
|
|
|
} |
1350
|
6
|
50
|
|
|
|
94
|
if ( defined( $args{'set'} ) ) |
1351
|
|
|
|
|
|
|
{ |
1352
|
0
|
|
0
|
|
|
0
|
push( @set_placeholders, @{ $args{'set'}->{'placeholders'} // [] } ); |
|
0
|
|
|
|
|
0
|
|
1353
|
0
|
|
0
|
|
|
0
|
push( @set_values, @{ $args{'set'}->{'values'} // [] } ); |
|
0
|
|
|
|
|
0
|
|
1354
|
|
|
|
|
|
|
} |
1355
|
|
|
|
|
|
|
|
1356
|
|
|
|
|
|
|
# Prepare the query elements. |
1357
|
6
|
|
|
|
|
28
|
my $query = sprintf( |
1358
|
|
|
|
|
|
|
qq| |
1359
|
|
|
|
|
|
|
UPDATE %s |
1360
|
|
|
|
|
|
|
SET %s |
1361
|
|
|
|
|
|
|
WHERE %s |
1362
|
|
|
|
|
|
|
|, |
1363
|
|
|
|
|
|
|
$dbh->quote_identifier( $table_name ), |
1364
|
|
|
|
|
|
|
join( ', ', @set_placeholders ), |
1365
|
|
|
|
|
|
|
'( ' . join( ' ) AND ( ', @$where_clauses ) . ' )', |
1366
|
|
|
|
|
|
|
); |
1367
|
|
|
|
|
|
|
my @query_values = |
1368
|
|
|
|
|
|
|
( |
1369
|
|
|
|
|
|
|
@set_values, |
1370
|
6
|
|
|
|
|
203
|
map { @$_ } @$where_values, |
|
6
|
|
|
|
|
24
|
|
1371
|
|
|
|
|
|
|
); |
1372
|
|
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
# Update the row. |
1374
|
6
|
|
|
|
|
12
|
my $rows_updated_count; |
1375
|
|
|
|
|
|
|
try |
1376
|
|
|
|
|
|
|
{ |
1377
|
6
|
|
|
6
|
|
529
|
local $dbh->{'RaiseError'} = 1; |
1378
|
6
|
|
|
|
|
154
|
my $sth = $dbh->prepare( $query ); |
1379
|
5
|
|
|
|
|
141844
|
$sth->execute( @query_values ); |
1380
|
|
|
|
|
|
|
|
1381
|
5
|
|
|
|
|
395
|
$rows_updated_count = $sth->rows(); |
1382
|
|
|
|
|
|
|
} |
1383
|
|
|
|
|
|
|
catch |
1384
|
|
|
|
|
|
|
{ |
1385
|
1
|
|
|
1
|
|
42
|
$log->fatalf( |
1386
|
|
|
|
|
|
|
"Could not update rows: %s\nQuery: %s\nValues: %s", |
1387
|
|
|
|
|
|
|
$_, |
1388
|
|
|
|
|
|
|
$query, |
1389
|
|
|
|
|
|
|
\@query_values, |
1390
|
|
|
|
|
|
|
); |
1391
|
|
|
|
|
|
|
|
1392
|
1
|
|
|
|
|
32
|
croak "Update failed: $_"; |
1393
|
6
|
|
|
|
|
73
|
}; |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
# Also, if rows() returns -1, it's an error. |
1396
|
5
|
50
|
|
|
|
282
|
croak 'Could not execute update: ' . $dbh->errstr() |
1397
|
|
|
|
|
|
|
if $rows_updated_count < 0; |
1398
|
|
|
|
|
|
|
|
1399
|
5
|
|
|
|
|
33
|
my $object_cache_time = $self->get_info('object_cache_time'); |
1400
|
|
|
|
|
|
|
# This needs to be before the set() below, so we invalidate the cache based on the |
1401
|
|
|
|
|
|
|
# old object. We don't need to do it twice, because you can't change primary IDs, and |
1402
|
|
|
|
|
|
|
# you can't change unique fields to ones that are taken, and that's all that we set |
1403
|
|
|
|
|
|
|
# the object cache keys for. |
1404
|
5
|
50
|
|
|
|
29
|
if ( defined( $object_cache_time ) ) |
1405
|
|
|
|
|
|
|
{ |
1406
|
0
|
0
|
|
|
|
0
|
$log->debugf( |
1407
|
|
|
|
|
|
|
"An update on '%s' is forcing to clear the cache for '%s=%s'", |
1408
|
|
|
|
|
|
|
$table_name, |
1409
|
|
|
|
|
|
|
$primary_key_name, |
1410
|
|
|
|
|
|
|
$self->id(), |
1411
|
|
|
|
|
|
|
) if $self->is_verbose(); |
1412
|
|
|
|
|
|
|
|
1413
|
0
|
|
|
|
|
0
|
$self->invalidate_cached_object(); |
1414
|
|
|
|
|
|
|
} |
1415
|
|
|
|
|
|
|
|
1416
|
|
|
|
|
|
|
# Make sure that the object reflects $clean_data. |
1417
|
|
|
|
|
|
|
$self->set( |
1418
|
5
|
|
|
|
|
33
|
$clean_data, |
1419
|
|
|
|
|
|
|
force => 1, |
1420
|
|
|
|
|
|
|
); |
1421
|
|
|
|
|
|
|
|
1422
|
5
|
|
|
|
|
97
|
return $rows_updated_count; |
1423
|
|
|
|
|
|
|
} |
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
|
1426
|
|
|
|
|
|
|
=head2 validate_data() |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
Validate the hashref of data passed as first argument. This is used both by |
1429
|
|
|
|
|
|
|
C and C to check the data before performing databse |
1430
|
|
|
|
|
|
|
operations. |
1431
|
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
|
my $validated_data = $object->validate_data( |
1433
|
|
|
|
|
|
|
\%data, |
1434
|
|
|
|
|
|
|
); |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
If there is invalid data, the method will croak with a detail of the error. |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
=cut |
1439
|
|
|
|
|
|
|
|
1440
|
|
|
|
|
|
|
sub validate_data |
1441
|
|
|
|
|
|
|
{ |
1442
|
71
|
|
|
71
|
1
|
2576
|
my ( $self, $original_data ) = @_; |
1443
|
|
|
|
|
|
|
|
1444
|
71
|
|
|
|
|
3361
|
my $data = Storable::dclone( $original_data ); |
1445
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
# Protect read-only fields. |
1447
|
71
|
|
50
|
|
|
132
|
foreach my $field ( @{ $self->get_info('readonly_fields') // [] } ) |
|
71
|
|
|
|
|
206
|
|
1448
|
|
|
|
|
|
|
{ |
1449
|
6
|
100
|
|
|
|
17
|
next if ! exists( $data->{ $field } ); |
1450
|
|
|
|
|
|
|
|
1451
|
3
|
|
|
|
|
48
|
croak "The field '$field' is read-only and cannot be set via the model"; |
1452
|
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
# Don't allow setting timestamps. |
1455
|
68
|
|
|
|
|
162
|
foreach my $field ( qw( created modified ) ) |
1456
|
|
|
|
|
|
|
{ |
1457
|
136
|
50
|
|
|
|
369
|
next if ! exists( $data->{ $field } ); |
1458
|
|
|
|
|
|
|
|
1459
|
0
|
|
|
|
|
0
|
$log->warnf( |
1460
|
|
|
|
|
|
|
"The field '%s' cannot be set and will be ignored", |
1461
|
|
|
|
|
|
|
$field, |
1462
|
|
|
|
|
|
|
); |
1463
|
0
|
|
|
|
|
0
|
delete( $data->{ $field } ); |
1464
|
|
|
|
|
|
|
} |
1465
|
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
|
# Allow inserting the primary key, but not updating it. |
1467
|
68
|
|
|
|
|
187
|
my $primary_key_name = $self->get_info('primary_key_name'); |
1468
|
68
|
100
|
100
|
|
|
574
|
if ( defined( $primary_key_name ) && defined( $self->{ $primary_key_name } ) && exists( $data->{ $primary_key_name } ) ) |
|
|
|
66
|
|
|
|
|
1469
|
|
|
|
|
|
|
{ |
1470
|
1
|
|
50
|
|
|
28
|
croak "'$primary_key_name' with a value of '" . ( $data->{ $primary_key_name } || 'undef' ) . "' ", |
1471
|
|
|
|
|
|
|
"was passed to set(), but primary keys cannot be set manually"; |
1472
|
|
|
|
|
|
|
} |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
# Fields starting with an underscore are hidden data that shouldn't be |
1475
|
|
|
|
|
|
|
# modified via a public interface. |
1476
|
67
|
|
|
|
|
249
|
foreach my $field ( keys %$data ) |
1477
|
|
|
|
|
|
|
{ |
1478
|
77
|
100
|
|
|
|
411
|
delete( $data->{ $field } ) |
1479
|
|
|
|
|
|
|
if substr( $field, 0, 1 ) eq '_'; |
1480
|
|
|
|
|
|
|
} |
1481
|
|
|
|
|
|
|
|
1482
|
67
|
|
|
|
|
161
|
return $data; |
1483
|
|
|
|
|
|
|
} |
1484
|
|
|
|
|
|
|
|
1485
|
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
|
=head1 UTILITY METHODS |
1487
|
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
|
=head2 dump() |
1490
|
|
|
|
|
|
|
|
1491
|
|
|
|
|
|
|
Return a string representation of the current object. |
1492
|
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
|
my $string = $book->dump(); |
1494
|
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
=cut |
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
sub dump ## no critic (Subroutines::ProhibitBuiltinHomonyms) |
1498
|
|
|
|
|
|
|
{ |
1499
|
2
|
|
|
2
|
1
|
1698
|
my ( $self ) = @_; |
1500
|
|
|
|
|
|
|
|
1501
|
2
|
|
|
|
|
9
|
return dumper( $self ); |
1502
|
|
|
|
|
|
|
} |
1503
|
|
|
|
|
|
|
|
1504
|
|
|
|
|
|
|
|
1505
|
|
|
|
|
|
|
=head2 flatten_object() |
1506
|
|
|
|
|
|
|
|
1507
|
|
|
|
|
|
|
Return a hash with the requested key/value pairs based on the list of fields |
1508
|
|
|
|
|
|
|
provided. |
1509
|
|
|
|
|
|
|
|
1510
|
|
|
|
|
|
|
Note that non-native fields (starting with an underscore) are not allowed. It |
1511
|
|
|
|
|
|
|
also protects sensitive fields. |
1512
|
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
|
#TODO: allow defining sensitive fields. |
1514
|
|
|
|
|
|
|
|
1515
|
|
|
|
|
|
|
my $book_data = $book->flatten_object( |
1516
|
|
|
|
|
|
|
[ 'name', 'isbn' ] |
1517
|
|
|
|
|
|
|
); |
1518
|
|
|
|
|
|
|
|
1519
|
|
|
|
|
|
|
=cut |
1520
|
|
|
|
|
|
|
|
1521
|
|
|
|
|
|
|
sub flatten_object |
1522
|
|
|
|
|
|
|
{ |
1523
|
5
|
|
|
5
|
1
|
2252
|
my ( $self, $fields ) = @_; |
1524
|
5
|
|
|
|
|
17
|
my @protected_fields = qw( password ); |
1525
|
|
|
|
|
|
|
|
1526
|
5
|
|
|
|
|
12
|
my %data = (); |
1527
|
5
|
|
|
|
|
14
|
foreach my $field ( @$fields ) |
1528
|
|
|
|
|
|
|
{ |
1529
|
6
|
100
|
|
|
|
13
|
if ( scalar( grep { $_ eq $field } @protected_fields ) != 0 ) |
|
6
|
100
|
|
|
|
57
|
|
|
|
100
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
{ |
1531
|
1
|
|
|
|
|
28
|
croak "The fields '$field' is protected and cannot be added to the flattened copy"; |
1532
|
|
|
|
|
|
|
} |
1533
|
|
|
|
|
|
|
elsif ( substr( $field, 0, 1 ) eq '_' ) |
1534
|
|
|
|
|
|
|
{ |
1535
|
1
|
|
|
|
|
17
|
croak "The field '$field' is hidden and cannot be added to the flattened copy"; |
1536
|
|
|
|
|
|
|
} |
1537
|
|
|
|
|
|
|
elsif ( $field eq 'id' ) |
1538
|
|
|
|
|
|
|
{ |
1539
|
2
|
100
|
|
|
|
9
|
if ( defined( $self->get_info('primary_key_name') ) ) |
1540
|
|
|
|
|
|
|
{ |
1541
|
1
|
|
|
|
|
5
|
$data{'id'} = $self->id(); |
1542
|
|
|
|
|
|
|
} |
1543
|
|
|
|
|
|
|
else |
1544
|
|
|
|
|
|
|
{ |
1545
|
1
|
|
|
|
|
17
|
croak "Requested adding ID to the list of fields, but the class doesn't define a primary key name"; |
1546
|
|
|
|
|
|
|
} |
1547
|
|
|
|
|
|
|
} |
1548
|
|
|
|
|
|
|
else |
1549
|
|
|
|
|
|
|
{ |
1550
|
2
|
|
|
|
|
7
|
$data{ $field } = $self->{ $field }; |
1551
|
|
|
|
|
|
|
} |
1552
|
|
|
|
|
|
|
} |
1553
|
|
|
|
|
|
|
|
1554
|
2
|
|
|
|
|
14
|
return \%data; |
1555
|
|
|
|
|
|
|
} |
1556
|
|
|
|
|
|
|
|
1557
|
|
|
|
|
|
|
|
1558
|
|
|
|
|
|
|
=head2 reload() |
1559
|
|
|
|
|
|
|
|
1560
|
|
|
|
|
|
|
Reload the content of the current object. This always skips the cache. |
1561
|
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
|
$book->reload(); |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
=cut |
1565
|
|
|
|
|
|
|
|
1566
|
|
|
|
|
|
|
sub reload |
1567
|
|
|
|
|
|
|
{ |
1568
|
1
|
|
|
1
|
1
|
32
|
my ( $self ) = @_; |
1569
|
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
|
# Make sure we were passed an object. |
1571
|
1
|
50
|
|
|
|
8
|
croak 'This method can only be called on an object' |
1572
|
|
|
|
|
|
|
if !Data::Validate::Type::is_hashref( $self ); |
1573
|
|
|
|
|
|
|
|
1574
|
1
|
|
|
|
|
16
|
my $class = ref( $self ); |
1575
|
|
|
|
|
|
|
|
1576
|
1
|
50
|
33
|
|
|
45
|
croak 'The object is not blessed with a class name' |
1577
|
|
|
|
|
|
|
if !defined( $class ) || ( $class eq '' ); |
1578
|
|
|
|
|
|
|
|
1579
|
1
|
50
|
|
|
|
8
|
croak "The class '$class' doesn't allow calling \$class->new()" |
1580
|
|
|
|
|
|
|
if ! $class->can('new'); |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
# Verify that we can reload the object. |
1583
|
1
|
50
|
|
|
|
4
|
croak 'Cannot reload an object for which a primary key name has not been defined at the class level.' |
1584
|
|
|
|
|
|
|
if ! defined( $self->get_info('primary_key_name') ); |
1585
|
1
|
50
|
|
|
|
7
|
croak 'Cannot reload an object with no ID value for its primary key' |
1586
|
|
|
|
|
|
|
if ! defined( $self->id() ); |
1587
|
|
|
|
|
|
|
|
1588
|
|
|
|
|
|
|
# Retrieve a fresh version using the object ID. |
1589
|
1
|
|
|
|
|
2
|
my $id = $self->id(); |
1590
|
1
|
|
|
|
|
3
|
my $fresh_object = $class->new( |
1591
|
|
|
|
|
|
|
{ id => $self->id() }, |
1592
|
|
|
|
|
|
|
skip_cache => 1, |
1593
|
|
|
|
|
|
|
); |
1594
|
|
|
|
|
|
|
|
1595
|
1
|
50
|
|
|
|
4
|
croak "Could not retrieve the row in the database corresponding to the current object using ID '$id'" |
1596
|
|
|
|
|
|
|
if ! defined( $fresh_object ); |
1597
|
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
|
# Keep the memory location intact. |
1599
|
1
|
|
|
|
|
1
|
%{ $self } = %{ $fresh_object }; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
3
|
|
1600
|
|
|
|
|
|
|
|
1601
|
1
|
|
|
|
|
10
|
return; |
1602
|
|
|
|
|
|
|
} |
1603
|
|
|
|
|
|
|
|
1604
|
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
|
=head2 retrieve_list() |
1606
|
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
|
Return an arrayref of objects matching all the criteria passed. |
1608
|
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
This method supports the following filtering criteria in a hashref passed as |
1610
|
|
|
|
|
|
|
first argument: |
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
=over 4 |
1613
|
|
|
|
|
|
|
|
1614
|
|
|
|
|
|
|
=item * id |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
An ID or an arrayref of IDs corresponding to the primary key. |
1617
|
|
|
|
|
|
|
|
1618
|
|
|
|
|
|
|
# Retrieve books with ID 1. |
1619
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1620
|
|
|
|
|
|
|
{ |
1621
|
|
|
|
|
|
|
id => 1, |
1622
|
|
|
|
|
|
|
} |
1623
|
|
|
|
|
|
|
); |
1624
|
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
|
# Retrieve books with IDs 1, 2 or 3. |
1626
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1627
|
|
|
|
|
|
|
{ |
1628
|
|
|
|
|
|
|
id => [ 1, 2, 3 ] |
1629
|
|
|
|
|
|
|
} |
1630
|
|
|
|
|
|
|
); |
1631
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
=item * Field names |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
A scalar value or an arrayref of values corresponding to a field listed in |
1635
|
|
|
|
|
|
|
C under either C or C. |
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
# Retrieve books for an author. |
1638
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1639
|
|
|
|
|
|
|
{ |
1640
|
|
|
|
|
|
|
author_id => 12, |
1641
|
|
|
|
|
|
|
} |
1642
|
|
|
|
|
|
|
); |
1643
|
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
|
# Retrieve books by ISBN. |
1645
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1646
|
|
|
|
|
|
|
{ |
1647
|
|
|
|
|
|
|
isbn => |
1648
|
|
|
|
|
|
|
[ |
1649
|
|
|
|
|
|
|
'9781449313142', |
1650
|
|
|
|
|
|
|
'9781449393090', |
1651
|
|
|
|
|
|
|
] |
1652
|
|
|
|
|
|
|
} |
1653
|
|
|
|
|
|
|
); |
1654
|
|
|
|
|
|
|
|
1655
|
|
|
|
|
|
|
=back |
1656
|
|
|
|
|
|
|
|
1657
|
|
|
|
|
|
|
Note that you can combine filters (which is the equivalent of AND in SQL) in |
1658
|
|
|
|
|
|
|
that hashref: |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
# Retrieve books by ISBN for a specific author. |
1661
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1662
|
|
|
|
|
|
|
{ |
1663
|
|
|
|
|
|
|
isbn => |
1664
|
|
|
|
|
|
|
[ |
1665
|
|
|
|
|
|
|
'9781449313142', |
1666
|
|
|
|
|
|
|
'9781449393090', |
1667
|
|
|
|
|
|
|
], |
1668
|
|
|
|
|
|
|
author_id => 12, |
1669
|
|
|
|
|
|
|
} |
1670
|
|
|
|
|
|
|
); |
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
Filters as discussed above, imply an equality between the field and the values. For instance, in the last example, |
1673
|
|
|
|
|
|
|
the request could be written as "Please provide a list of books with author_id equal to 12, which also have an |
1674
|
|
|
|
|
|
|
ISBN equal to 9781449313142 or an ISBN equal to 9781449393090". |
1675
|
|
|
|
|
|
|
|
1676
|
|
|
|
|
|
|
If you wish to request records using some other operator than equals, you can create a request similar to the following: |
1677
|
|
|
|
|
|
|
|
1678
|
|
|
|
|
|
|
# Retrieve books for a specific author with ISBNs starting with a certain pattern. |
1679
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1680
|
|
|
|
|
|
|
{ |
1681
|
|
|
|
|
|
|
isbn => |
1682
|
|
|
|
|
|
|
{ |
1683
|
|
|
|
|
|
|
operator => 'like', |
1684
|
|
|
|
|
|
|
value => [ '9781%' ], |
1685
|
|
|
|
|
|
|
}, |
1686
|
|
|
|
|
|
|
author_id => 12, |
1687
|
|
|
|
|
|
|
} |
1688
|
|
|
|
|
|
|
); |
1689
|
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
|
The above example could be written as "Please provide a list of books with author_id equal to 12, which also have |
1691
|
|
|
|
|
|
|
an ISBN starting with 9781". |
1692
|
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
|
Valid operators include: |
1694
|
|
|
|
|
|
|
|
1695
|
|
|
|
|
|
|
* = |
1696
|
|
|
|
|
|
|
* not |
1697
|
|
|
|
|
|
|
* <= |
1698
|
|
|
|
|
|
|
* >= |
1699
|
|
|
|
|
|
|
* < |
1700
|
|
|
|
|
|
|
* > |
1701
|
|
|
|
|
|
|
* between |
1702
|
|
|
|
|
|
|
* null |
1703
|
|
|
|
|
|
|
* not_null |
1704
|
|
|
|
|
|
|
* like |
1705
|
|
|
|
|
|
|
* not_like |
1706
|
|
|
|
|
|
|
|
1707
|
|
|
|
|
|
|
This method also supports the following optional arguments, passed in a hash |
1708
|
|
|
|
|
|
|
after the filtering criteria above-mentioned: |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
=over 4 |
1711
|
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
=item * dbh |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
Retrieve the data against a different database than the default one specified |
1715
|
|
|
|
|
|
|
in C. |
1716
|
|
|
|
|
|
|
|
1717
|
|
|
|
|
|
|
=item * order_by |
1718
|
|
|
|
|
|
|
|
1719
|
|
|
|
|
|
|
Specify an ORDER BY clause to sort the objects returned. |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1722
|
|
|
|
|
|
|
{ |
1723
|
|
|
|
|
|
|
author_id => 12, |
1724
|
|
|
|
|
|
|
}, |
1725
|
|
|
|
|
|
|
order_by => 'books.name ASC', |
1726
|
|
|
|
|
|
|
); |
1727
|
|
|
|
|
|
|
|
1728
|
|
|
|
|
|
|
=item * limit |
1729
|
|
|
|
|
|
|
|
1730
|
|
|
|
|
|
|
Limit the number of objects to return. |
1731
|
|
|
|
|
|
|
|
1732
|
|
|
|
|
|
|
# Get 10 books from author #12. |
1733
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1734
|
|
|
|
|
|
|
{ |
1735
|
|
|
|
|
|
|
author_id => 12, |
1736
|
|
|
|
|
|
|
}, |
1737
|
|
|
|
|
|
|
limit => 10, |
1738
|
|
|
|
|
|
|
); |
1739
|
|
|
|
|
|
|
|
1740
|
|
|
|
|
|
|
=item * query_extensions |
1741
|
|
|
|
|
|
|
|
1742
|
|
|
|
|
|
|
Add joins and support different filtering criteria: |
1743
|
|
|
|
|
|
|
|
1744
|
|
|
|
|
|
|
=over 8 |
1745
|
|
|
|
|
|
|
|
1746
|
|
|
|
|
|
|
=item * where_clauses |
1747
|
|
|
|
|
|
|
|
1748
|
|
|
|
|
|
|
An arrayref of clauses to add to WHERE. |
1749
|
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
|
=item * where_values |
1751
|
|
|
|
|
|
|
|
1752
|
|
|
|
|
|
|
An arrayref of values corresponding to the clauses. |
1753
|
|
|
|
|
|
|
|
1754
|
|
|
|
|
|
|
=item * joins |
1755
|
|
|
|
|
|
|
|
1756
|
|
|
|
|
|
|
A string specifying JOIN statements. |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
=item * joined_fields |
1759
|
|
|
|
|
|
|
|
1760
|
|
|
|
|
|
|
A string of extra fields to add to the SELECT. |
1761
|
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
|
=back |
1763
|
|
|
|
|
|
|
|
1764
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1765
|
|
|
|
|
|
|
{ |
1766
|
|
|
|
|
|
|
id => [ 1, 2, 3 ], |
1767
|
|
|
|
|
|
|
}, |
1768
|
|
|
|
|
|
|
query_extensions => |
1769
|
|
|
|
|
|
|
{ |
1770
|
|
|
|
|
|
|
where_clauses => [ 'authors.name = ?' ], |
1771
|
|
|
|
|
|
|
where_values => [ [ 'Randal L. Schwartz' ] ], |
1772
|
|
|
|
|
|
|
joins => 'INNER JOIN authors USING (author_id)', |
1773
|
|
|
|
|
|
|
joined_fields => 'authors.name AS _author_name', |
1774
|
|
|
|
|
|
|
} |
1775
|
|
|
|
|
|
|
); |
1776
|
|
|
|
|
|
|
|
1777
|
|
|
|
|
|
|
=item * pagination |
1778
|
|
|
|
|
|
|
|
1779
|
|
|
|
|
|
|
Off by default. Paginate the results. You can control the pagination options |
1780
|
|
|
|
|
|
|
by setting this to the following hash, with each key being optional and falling |
1781
|
|
|
|
|
|
|
back to the default if you omit it: |
1782
|
|
|
|
|
|
|
|
1783
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1784
|
|
|
|
|
|
|
{}, |
1785
|
|
|
|
|
|
|
allow_all => 1, |
1786
|
|
|
|
|
|
|
pagination => |
1787
|
|
|
|
|
|
|
{ |
1788
|
|
|
|
|
|
|
# The number of results to retrieve. |
1789
|
|
|
|
|
|
|
per_page => $per_page, |
1790
|
|
|
|
|
|
|
# Number of the page of results to retrieve. If you have per_page=10 |
1791
|
|
|
|
|
|
|
# and page=2, then this would retrieve rows 10-19 from the set of |
1792
|
|
|
|
|
|
|
# matching rows. |
1793
|
|
|
|
|
|
|
page => $page, |
1794
|
|
|
|
|
|
|
} |
1795
|
|
|
|
|
|
|
); |
1796
|
|
|
|
|
|
|
|
1797
|
|
|
|
|
|
|
Additionally, pagination can be set to '1' instead of {} and then the default |
1798
|
|
|
|
|
|
|
options will be used. |
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
More pagination information is then returned in list context: |
1801
|
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
|
my ( $books, $pagination ) = My::Model::Book->retrieve_list( ... ); |
1803
|
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
|
With the following pagination information inside C<$pagination>: |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
{ |
1807
|
|
|
|
|
|
|
# The total number of rows matching the query. |
1808
|
|
|
|
|
|
|
total_count => $total_count, |
1809
|
|
|
|
|
|
|
# The current page being returned. |
1810
|
|
|
|
|
|
|
page => $page, |
1811
|
|
|
|
|
|
|
# The total number of pages to display the matching rows. |
1812
|
|
|
|
|
|
|
page_max => $page_max, |
1813
|
|
|
|
|
|
|
# The number of rows displayed per page. |
1814
|
|
|
|
|
|
|
per_page => $per_page, |
1815
|
|
|
|
|
|
|
} |
1816
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
=item * lock (default 0) |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
Add a lock to the rows retrieved. |
1820
|
|
|
|
|
|
|
|
1821
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1822
|
|
|
|
|
|
|
{ |
1823
|
|
|
|
|
|
|
id => [ 1, 2, 3 ], |
1824
|
|
|
|
|
|
|
}, |
1825
|
|
|
|
|
|
|
lock => 1, |
1826
|
|
|
|
|
|
|
); |
1827
|
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
|
=item * allow_all (default 0) |
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
Retrieve all the rows in the table if no criteria is passed. Off by |
1831
|
|
|
|
|
|
|
default to prevent retrieving large tables at once. |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
# All the books! |
1834
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1835
|
|
|
|
|
|
|
{}, |
1836
|
|
|
|
|
|
|
allow_all => 1, |
1837
|
|
|
|
|
|
|
); |
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
=item * show_queries (default 0) |
1840
|
|
|
|
|
|
|
|
1841
|
|
|
|
|
|
|
Set to '1' to see in the logs the queries being performed. |
1842
|
|
|
|
|
|
|
|
1843
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1844
|
|
|
|
|
|
|
{ |
1845
|
|
|
|
|
|
|
id => [ 1, 2, 3 ], |
1846
|
|
|
|
|
|
|
}, |
1847
|
|
|
|
|
|
|
show_queries => 1, |
1848
|
|
|
|
|
|
|
); |
1849
|
|
|
|
|
|
|
|
1850
|
|
|
|
|
|
|
=item * allow_subclassing (default 0) |
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
By default, C cannot be subclassed to prevent accidental |
1853
|
|
|
|
|
|
|
infinite recursions and breaking the cache features provided by NinjaORM. |
1854
|
|
|
|
|
|
|
Typically, if you want to add functionality to how retrieving a group of |
1855
|
|
|
|
|
|
|
objects works, you will want to modify C instead. |
1856
|
|
|
|
|
|
|
|
1857
|
|
|
|
|
|
|
If you really need to subclass C, you will then need to |
1858
|
|
|
|
|
|
|
set C to C<1> in subclassed method's call to its parent, |
1859
|
|
|
|
|
|
|
to indicate that you've carefully considered the impact of this and that it |
1860
|
|
|
|
|
|
|
is safe. |
1861
|
|
|
|
|
|
|
|
1862
|
|
|
|
|
|
|
=item * select_fields / exclude_fields (optional) |
1863
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
By default, C will select all the fields that exist on the |
1865
|
|
|
|
|
|
|
table associated with the class. In some rare cases, it is however desirable to |
1866
|
|
|
|
|
|
|
either select only or to exclude explicitely some fields from the table, and |
1867
|
|
|
|
|
|
|
you can pass an arrayref with C and C |
1868
|
|
|
|
|
|
|
(respectively) to specify those. |
1869
|
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
|
Important cache consideration: when this option is used, the cache will be used |
1871
|
|
|
|
|
|
|
to retrieve objects without polling the database when possible, but any objects |
1872
|
|
|
|
|
|
|
retrieved from the database will not be stashed in the cache as they will not |
1873
|
|
|
|
|
|
|
have the complete information for that object. If you have other |
1874
|
|
|
|
|
|
|
C calls warming the cache this most likely won't be an issue, |
1875
|
|
|
|
|
|
|
but if you exclusively run C calls with C and |
1876
|
|
|
|
|
|
|
C, then you may be better off creating a view and tieing the |
1877
|
|
|
|
|
|
|
class to that view. |
1878
|
|
|
|
|
|
|
|
1879
|
|
|
|
|
|
|
# To display an index of our library, we want all the book properties but not |
1880
|
|
|
|
|
|
|
# the book content, which is a huge field that we won't use in the template. |
1881
|
|
|
|
|
|
|
my $books = My::Model::Book->retrieve_list( |
1882
|
|
|
|
|
|
|
{}, |
1883
|
|
|
|
|
|
|
allow_all => 1, |
1884
|
|
|
|
|
|
|
exclude_fields => [ 'full_text' ], |
1885
|
|
|
|
|
|
|
); |
1886
|
|
|
|
|
|
|
|
1887
|
|
|
|
|
|
|
=back |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
=cut |
1890
|
|
|
|
|
|
|
|
1891
|
|
|
|
|
|
|
sub retrieve_list |
1892
|
|
|
|
|
|
|
{ |
1893
|
26
|
|
|
26
|
1
|
14201
|
my ( $class, $filters, %args ) = @_; |
1894
|
26
|
|
100
|
|
|
155
|
my $allow_subclassing = delete( $args{'allow_subclassing'} ) || 0; |
1895
|
|
|
|
|
|
|
|
1896
|
|
|
|
|
|
|
# Check caller and prevent calls from a subclass' retrieve_list(). |
1897
|
26
|
100
|
|
|
|
122
|
if ( !$allow_subclassing ) |
1898
|
|
|
|
|
|
|
{ |
1899
|
25
|
|
|
|
|
285
|
my $subroutine = (caller(1))[3]; |
1900
|
25
|
50
|
|
|
|
388
|
if ( defined( $subroutine ) ) |
1901
|
|
|
|
|
|
|
{ |
1902
|
25
|
|
|
|
|
147
|
$subroutine =~ s/^.*:://; |
1903
|
25
|
100
|
|
|
|
99
|
croak( |
1904
|
|
|
|
|
|
|
'You have subclassed retrieve_list(), which is not allowed to prevent infinite recursions. ' . |
1905
|
|
|
|
|
|
|
'You most likely want to subclass retrieve_list_nocache() instead.' |
1906
|
|
|
|
|
|
|
) if $subroutine eq 'retrieve_list'; |
1907
|
|
|
|
|
|
|
} |
1908
|
|
|
|
|
|
|
} |
1909
|
|
|
|
|
|
|
|
1910
|
25
|
|
100
|
|
|
79
|
my $any_cache_time = $class->get_info('list_cache_time') || $class->get_info('object_cache_time'); |
1911
|
25
|
100
|
66
|
|
|
285
|
return defined( $any_cache_time ) && !$args{'skip_cache'} && !$args{'lock'} |
1912
|
|
|
|
|
|
|
? $class->retrieve_list_cache( $filters, %args ) |
1913
|
|
|
|
|
|
|
: $class->retrieve_list_nocache( $filters, %args ); |
1914
|
|
|
|
|
|
|
} |
1915
|
|
|
|
|
|
|
|
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
=head1 ACCESSORS |
1918
|
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
|
|
1920
|
|
|
|
|
|
|
=head2 get_cache_key_field() |
1921
|
|
|
|
|
|
|
|
1922
|
|
|
|
|
|
|
Return the name of the field that should be used in the cache key. |
1923
|
|
|
|
|
|
|
|
1924
|
|
|
|
|
|
|
my $cache_time = $class->cache_key_field(); |
1925
|
|
|
|
|
|
|
my $cache_time = $object->cache_key_field(); |
1926
|
|
|
|
|
|
|
|
1927
|
|
|
|
|
|
|
=cut |
1928
|
|
|
|
|
|
|
|
1929
|
|
|
|
|
|
|
sub get_cache_key_field |
1930
|
|
|
|
|
|
|
{ |
1931
|
3
|
|
|
3
|
1
|
5182
|
my ( $self ) = @_; |
1932
|
|
|
|
|
|
|
|
1933
|
3
|
|
|
|
|
14
|
my $cache_key_field = $self->cached_static_class_info()->get('cache_key_field'); |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
# If the subclass specifies a field to use for the cache key name, use it. |
1936
|
|
|
|
|
|
|
# Otherwise, we fall back on the primary key if it exists. |
1937
|
3
|
100
|
|
|
|
16
|
return defined( $cache_key_field ) |
1938
|
|
|
|
|
|
|
? $cache_key_field |
1939
|
|
|
|
|
|
|
: $self->get_info('primary_key_name'); |
1940
|
|
|
|
|
|
|
} |
1941
|
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
|
|
1943
|
|
|
|
|
|
|
=head2 get_default_dbh() |
1944
|
|
|
|
|
|
|
|
1945
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C instead. |
1946
|
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
|
Return the default database handle to use with this class. |
1948
|
|
|
|
|
|
|
|
1949
|
|
|
|
|
|
|
my $default_dbh = $class->get_default_dbh(); |
1950
|
|
|
|
|
|
|
my $default_dbh = $object->get_default_dbh(); |
1951
|
|
|
|
|
|
|
|
1952
|
|
|
|
|
|
|
=cut |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
sub get_default_dbh |
1955
|
|
|
|
|
|
|
{ |
1956
|
2
|
|
|
2
|
1
|
5388
|
my ( $self ) = @_; |
1957
|
|
|
|
|
|
|
|
1958
|
2
|
|
|
|
|
56
|
carp "get_default_dbh() has been deprecated, please change the method call to get_info('default_dbh')"; |
1959
|
|
|
|
|
|
|
|
1960
|
2
|
|
|
|
|
1223
|
return $self->get_info('default_dbh'); |
1961
|
|
|
|
|
|
|
} |
1962
|
|
|
|
|
|
|
|
1963
|
|
|
|
|
|
|
|
1964
|
|
|
|
|
|
|
=head2 get_filtering_fields() |
1965
|
|
|
|
|
|
|
|
1966
|
|
|
|
|
|
|
Returns the fields that can be used as filtering criteria in retrieve_list(). |
1967
|
|
|
|
|
|
|
|
1968
|
|
|
|
|
|
|
Notes: |
1969
|
|
|
|
|
|
|
|
1970
|
|
|
|
|
|
|
=over 4 |
1971
|
|
|
|
|
|
|
|
1972
|
|
|
|
|
|
|
=item * Does not include the primary key. |
1973
|
|
|
|
|
|
|
|
1974
|
|
|
|
|
|
|
=item * Includes unique fields. |
1975
|
|
|
|
|
|
|
|
1976
|
|
|
|
|
|
|
my $filtering_fields = $class->get_filtering_fields(); |
1977
|
|
|
|
|
|
|
my $filtering_fields = $object->get_filtering_fields(); |
1978
|
|
|
|
|
|
|
|
1979
|
|
|
|
|
|
|
=back |
1980
|
|
|
|
|
|
|
|
1981
|
|
|
|
|
|
|
=cut |
1982
|
|
|
|
|
|
|
|
1983
|
|
|
|
|
|
|
sub get_filtering_fields |
1984
|
|
|
|
|
|
|
{ |
1985
|
36
|
|
|
36
|
1
|
5337
|
my ( $self ) = @_; |
1986
|
|
|
|
|
|
|
|
1987
|
|
|
|
|
|
|
my %fields = ( |
1988
|
34
|
|
|
|
|
110
|
map { $_ => undef } |
1989
|
|
|
|
|
|
|
( |
1990
|
36
|
|
|
|
|
96
|
@{ $self->cached_static_class_info()->get('filtering_fields') }, |
1991
|
36
|
|
|
|
|
51
|
@{ $self->cached_static_class_info()->get('unique_fields') }, |
|
36
|
|
|
|
|
81
|
|
1992
|
|
|
|
|
|
|
) |
1993
|
|
|
|
|
|
|
); |
1994
|
36
|
|
|
|
|
196
|
return [ keys %fields ]; |
1995
|
|
|
|
|
|
|
} |
1996
|
|
|
|
|
|
|
|
1997
|
|
|
|
|
|
|
|
1998
|
|
|
|
|
|
|
=head2 get_info() |
1999
|
|
|
|
|
|
|
|
2000
|
|
|
|
|
|
|
Return cached static class information for the current object or class. |
2001
|
|
|
|
|
|
|
|
2002
|
|
|
|
|
|
|
my $info = $class->get_info(); |
2003
|
|
|
|
|
|
|
my $info = $object->get_info(); |
2004
|
|
|
|
|
|
|
|
2005
|
|
|
|
|
|
|
=cut |
2006
|
|
|
|
|
|
|
|
2007
|
|
|
|
|
|
|
sub get_info { |
2008
|
887
|
|
|
887
|
1
|
15623
|
my ( $self, $key ) = @_; |
2009
|
|
|
|
|
|
|
|
2010
|
887
|
|
|
|
|
1824
|
return $self->cached_static_class_info()->get( $key ); |
2011
|
|
|
|
|
|
|
} |
2012
|
|
|
|
|
|
|
|
2013
|
|
|
|
|
|
|
|
2014
|
|
|
|
|
|
|
=head2 get_list_cache_time() |
2015
|
|
|
|
|
|
|
|
2016
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C |
2017
|
|
|
|
|
|
|
instead. |
2018
|
|
|
|
|
|
|
|
2019
|
|
|
|
|
|
|
Return the duration for which a list of objects of the current class can be |
2020
|
|
|
|
|
|
|
cached. |
2021
|
|
|
|
|
|
|
|
2022
|
|
|
|
|
|
|
my $list_cache_time = $class->list_cache_time(); |
2023
|
|
|
|
|
|
|
my $list_cache_time = $object->list_cache_time(); |
2024
|
|
|
|
|
|
|
|
2025
|
|
|
|
|
|
|
=cut |
2026
|
|
|
|
|
|
|
|
2027
|
|
|
|
|
|
|
sub get_list_cache_time |
2028
|
|
|
|
|
|
|
{ |
2029
|
3
|
|
|
3
|
1
|
6106
|
my ( $self ) = @_; |
2030
|
|
|
|
|
|
|
|
2031
|
3
|
|
|
|
|
47
|
carp "get_list_cache_time() has been deprecated, please change the method call to get_info('list_cache_time')"; |
2032
|
|
|
|
|
|
|
|
2033
|
3
|
|
|
|
|
1155
|
return $self->get_info('list_cache_time'); |
2034
|
|
|
|
|
|
|
} |
2035
|
|
|
|
|
|
|
|
2036
|
|
|
|
|
|
|
|
2037
|
|
|
|
|
|
|
=head2 get_memcache() |
2038
|
|
|
|
|
|
|
|
2039
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C instead. |
2040
|
|
|
|
|
|
|
|
2041
|
|
|
|
|
|
|
Return the memcache object to use with this class. |
2042
|
|
|
|
|
|
|
|
2043
|
|
|
|
|
|
|
my $memcache = $class->get_memcache(); |
2044
|
|
|
|
|
|
|
my $memcache = $object->get_memcache(); |
2045
|
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
|
=cut |
2047
|
|
|
|
|
|
|
|
2048
|
|
|
|
|
|
|
sub get_memcache |
2049
|
|
|
|
|
|
|
{ |
2050
|
2
|
|
|
2
|
1
|
3581
|
my ( $self ) = @_; |
2051
|
|
|
|
|
|
|
|
2052
|
2
|
|
|
|
|
28
|
carp "get_memcache() has been deprecated, please change the method call to get_info('memcache')"; |
2053
|
|
|
|
|
|
|
|
2054
|
2
|
|
|
|
|
699
|
return $self->get_info('memcache'); |
2055
|
|
|
|
|
|
|
} |
2056
|
|
|
|
|
|
|
|
2057
|
|
|
|
|
|
|
|
2058
|
|
|
|
|
|
|
=head2 get_object_cache_time() |
2059
|
|
|
|
|
|
|
|
2060
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C |
2061
|
|
|
|
|
|
|
instead. |
2062
|
|
|
|
|
|
|
|
2063
|
|
|
|
|
|
|
Return the duration for which an object of the current class can be cached. |
2064
|
|
|
|
|
|
|
|
2065
|
|
|
|
|
|
|
my $object_cache_time = $class->get_object_cache_time(); |
2066
|
|
|
|
|
|
|
my $object_cache_time = $object->get_object_cache_time(); |
2067
|
|
|
|
|
|
|
|
2068
|
|
|
|
|
|
|
=cut |
2069
|
|
|
|
|
|
|
|
2070
|
|
|
|
|
|
|
sub get_object_cache_time |
2071
|
|
|
|
|
|
|
{ |
2072
|
3
|
|
|
3
|
1
|
6645
|
my ( $self ) = @_; |
2073
|
|
|
|
|
|
|
|
2074
|
3
|
|
|
|
|
56
|
carp "get_object_cache_time() has been deprecated, please change the method call to get_info('object_cache_time')"; |
2075
|
|
|
|
|
|
|
|
2076
|
3
|
|
|
|
|
1616
|
return $self->get_info('object_cache_time'); |
2077
|
|
|
|
|
|
|
} |
2078
|
|
|
|
|
|
|
|
2079
|
|
|
|
|
|
|
|
2080
|
|
|
|
|
|
|
=head2 get_primary_key_name() |
2081
|
|
|
|
|
|
|
|
2082
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C instead. |
2083
|
|
|
|
|
|
|
|
2084
|
|
|
|
|
|
|
Return the underlying primary key name for the current class or object. |
2085
|
|
|
|
|
|
|
|
2086
|
|
|
|
|
|
|
my $primary_key_name = $class->get_primary_key_name(); |
2087
|
|
|
|
|
|
|
my $primary_key_name = $object->get_primary_key_name(); |
2088
|
|
|
|
|
|
|
|
2089
|
|
|
|
|
|
|
=cut |
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
sub get_primary_key_name |
2092
|
|
|
|
|
|
|
{ |
2093
|
2
|
|
|
2
|
1
|
3475
|
my ( $self ) = @_; |
2094
|
|
|
|
|
|
|
|
2095
|
2
|
|
|
|
|
31
|
carp "get_primary_key_name() has been deprecated, please change the method call to get_info('primary_key_name')"; |
2096
|
|
|
|
|
|
|
|
2097
|
2
|
|
|
|
|
682
|
return $self->get_info('primary_key_name'); |
2098
|
|
|
|
|
|
|
} |
2099
|
|
|
|
|
|
|
|
2100
|
|
|
|
|
|
|
|
2101
|
|
|
|
|
|
|
=head2 get_readonly_fields() |
2102
|
|
|
|
|
|
|
|
2103
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C instead. |
2104
|
|
|
|
|
|
|
|
2105
|
|
|
|
|
|
|
Return an arrayref of fields that cannot be modified via C, C, |
2106
|
|
|
|
|
|
|
or C. |
2107
|
|
|
|
|
|
|
|
2108
|
|
|
|
|
|
|
my $readonly_fields = $class->get_readonly_fields(); |
2109
|
|
|
|
|
|
|
my $readonly_fields = $object->get_readonly_fields(); |
2110
|
|
|
|
|
|
|
|
2111
|
|
|
|
|
|
|
=cut |
2112
|
|
|
|
|
|
|
|
2113
|
|
|
|
|
|
|
sub get_readonly_fields |
2114
|
|
|
|
|
|
|
{ |
2115
|
3
|
|
|
3
|
1
|
6049
|
my ( $self ) = @_; |
2116
|
|
|
|
|
|
|
|
2117
|
3
|
|
|
|
|
53
|
carp "get_readonly_fields() has been deprecated, please change the method call to get_info('readonly_fields')"; |
2118
|
|
|
|
|
|
|
|
2119
|
3
|
|
|
|
|
1273
|
return $self->get_info('readonly_fields'); |
2120
|
|
|
|
|
|
|
} |
2121
|
|
|
|
|
|
|
|
2122
|
|
|
|
|
|
|
|
2123
|
|
|
|
|
|
|
=head2 get_table_name() |
2124
|
|
|
|
|
|
|
|
2125
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C instead. |
2126
|
|
|
|
|
|
|
|
2127
|
|
|
|
|
|
|
Returns the underlying table name for the current class or object. |
2128
|
|
|
|
|
|
|
|
2129
|
|
|
|
|
|
|
my $table_name = $class->get_table_name(); |
2130
|
|
|
|
|
|
|
my $table_name = $object->get_table_name(); |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
=cut |
2133
|
|
|
|
|
|
|
|
2134
|
|
|
|
|
|
|
sub get_table_name |
2135
|
|
|
|
|
|
|
{ |
2136
|
2
|
|
|
2
|
1
|
3536
|
my ( $self ) = @_; |
2137
|
|
|
|
|
|
|
|
2138
|
2
|
|
|
|
|
34
|
carp "get_table_name() has been deprecated, please change the method call to get_info('table_name')"; |
2139
|
|
|
|
|
|
|
|
2140
|
2
|
|
|
|
|
701
|
return $self->get_info('table_name'); |
2141
|
|
|
|
|
|
|
} |
2142
|
|
|
|
|
|
|
|
2143
|
|
|
|
|
|
|
|
2144
|
|
|
|
|
|
|
=head2 get_unique_fields() |
2145
|
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C |
2147
|
|
|
|
|
|
|
instead. |
2148
|
|
|
|
|
|
|
|
2149
|
|
|
|
|
|
|
Return an arrayref of fields that are unique for the underlying table. |
2150
|
|
|
|
|
|
|
|
2151
|
|
|
|
|
|
|
Important: this doesn't include the primary key name. To retrieve the name |
2152
|
|
|
|
|
|
|
of the primary key, use C<$class->primary_key_name()> |
2153
|
|
|
|
|
|
|
|
2154
|
|
|
|
|
|
|
my $unique_fields = $class->get_unique_fields(); |
2155
|
|
|
|
|
|
|
my $unique_fields = $object->get_unique_fields(); |
2156
|
|
|
|
|
|
|
|
2157
|
|
|
|
|
|
|
=cut |
2158
|
|
|
|
|
|
|
|
2159
|
|
|
|
|
|
|
sub get_unique_fields |
2160
|
|
|
|
|
|
|
{ |
2161
|
3
|
|
|
3
|
1
|
5302
|
my ( $self ) = @_; |
2162
|
|
|
|
|
|
|
|
2163
|
3
|
|
|
|
|
39
|
carp "get_unique_fields() has been deprecated, please change the method call to get_info('unique_fields')"; |
2164
|
|
|
|
|
|
|
|
2165
|
3
|
|
|
|
|
989
|
return $self->get_info('unique_fields'); |
2166
|
|
|
|
|
|
|
} |
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
|
2169
|
|
|
|
|
|
|
=head2 has_created_field() |
2170
|
|
|
|
|
|
|
|
2171
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C |
2172
|
|
|
|
|
|
|
instead. |
2173
|
|
|
|
|
|
|
|
2174
|
|
|
|
|
|
|
Return a boolean to indicate whether the underlying table has a 'created' |
2175
|
|
|
|
|
|
|
field. |
2176
|
|
|
|
|
|
|
|
2177
|
|
|
|
|
|
|
my $has_created_field = $class->has_created_field(); |
2178
|
|
|
|
|
|
|
my $has_created_field = $object->has_created_field(); |
2179
|
|
|
|
|
|
|
|
2180
|
|
|
|
|
|
|
=cut |
2181
|
|
|
|
|
|
|
|
2182
|
|
|
|
|
|
|
sub has_created_field |
2183
|
|
|
|
|
|
|
{ |
2184
|
5
|
|
|
5
|
1
|
10289
|
my ( $self ) = @_; |
2185
|
|
|
|
|
|
|
|
2186
|
5
|
|
|
|
|
75
|
carp "has_created_field() has been deprecated, please change the method call to get_info('has_created_field')"; |
2187
|
|
|
|
|
|
|
|
2188
|
5
|
|
|
|
|
2021
|
return $self->get_info('has_created_field'); |
2189
|
|
|
|
|
|
|
} |
2190
|
|
|
|
|
|
|
|
2191
|
|
|
|
|
|
|
|
2192
|
|
|
|
|
|
|
=head2 has_modified_field() |
2193
|
|
|
|
|
|
|
|
2194
|
|
|
|
|
|
|
WARNING: this method will be removed soon. Use C instead. |
2195
|
|
|
|
|
|
|
|
2196
|
|
|
|
|
|
|
Return a boolean to indicate whether the underlying table has a 'modified' |
2197
|
|
|
|
|
|
|
field. |
2198
|
|
|
|
|
|
|
|
2199
|
|
|
|
|
|
|
my $has_modified_field = $class->has_modified_field(); |
2200
|
|
|
|
|
|
|
my $has_modified_field = $object->has_modified_field(); |
2201
|
|
|
|
|
|
|
|
2202
|
|
|
|
|
|
|
=cut |
2203
|
|
|
|
|
|
|
|
2204
|
|
|
|
|
|
|
sub has_modified_field |
2205
|
|
|
|
|
|
|
{ |
2206
|
5
|
|
|
5
|
1
|
8761
|
my ( $self ) = @_; |
2207
|
|
|
|
|
|
|
|
2208
|
5
|
|
|
|
|
60
|
carp "has_modified_field() has been deprecated, please change the method call to get_info('has_modified_field')"; |
2209
|
|
|
|
|
|
|
|
2210
|
5
|
|
|
|
|
1578
|
return $self->get_info('has_modified_field'); |
2211
|
|
|
|
|
|
|
} |
2212
|
|
|
|
|
|
|
|
2213
|
|
|
|
|
|
|
|
2214
|
|
|
|
|
|
|
=head2 id() |
2215
|
|
|
|
|
|
|
|
2216
|
|
|
|
|
|
|
Return the value associated with the primary key for the current object. |
2217
|
|
|
|
|
|
|
|
2218
|
|
|
|
|
|
|
my $id = $object->id(); |
2219
|
|
|
|
|
|
|
|
2220
|
|
|
|
|
|
|
=cut |
2221
|
|
|
|
|
|
|
|
2222
|
|
|
|
|
|
|
sub id |
2223
|
|
|
|
|
|
|
{ |
2224
|
38
|
|
|
38
|
1
|
4650
|
my ( $self ) = @_; |
2225
|
|
|
|
|
|
|
|
2226
|
38
|
|
|
|
|
138
|
my $primary_key_name = $self->get_info('primary_key_name'); |
2227
|
|
|
|
|
|
|
return defined( $primary_key_name ) |
2228
|
38
|
50
|
|
|
|
327
|
? $self->{ $primary_key_name } |
2229
|
|
|
|
|
|
|
: undef; |
2230
|
|
|
|
|
|
|
} |
2231
|
|
|
|
|
|
|
|
2232
|
|
|
|
|
|
|
|
2233
|
|
|
|
|
|
|
=head2 is_verbose() |
2234
|
|
|
|
|
|
|
|
2235
|
|
|
|
|
|
|
Return if verbosity is enabled. |
2236
|
|
|
|
|
|
|
|
2237
|
|
|
|
|
|
|
This method supports two types of verbosity: |
2238
|
|
|
|
|
|
|
|
2239
|
|
|
|
|
|
|
=over 4 |
2240
|
|
|
|
|
|
|
|
2241
|
|
|
|
|
|
|
=item * general verbosity |
2242
|
|
|
|
|
|
|
|
2243
|
|
|
|
|
|
|
Called with no argument, this returns whether code in general will be verbose. |
2244
|
|
|
|
|
|
|
|
2245
|
|
|
|
|
|
|
$log->debug( 'This is verbose' ) |
2246
|
|
|
|
|
|
|
if $class->is_verbose(); |
2247
|
|
|
|
|
|
|
$log->debug( 'This is verbose' ) |
2248
|
|
|
|
|
|
|
if $object->is_verbose(); |
2249
|
|
|
|
|
|
|
|
2250
|
|
|
|
|
|
|
=item * verbosity for a specific type of operations |
2251
|
|
|
|
|
|
|
|
2252
|
|
|
|
|
|
|
Called with a specific type of operations as first argument, this returns |
2253
|
|
|
|
|
|
|
whether that type of operations will be verbose. |
2254
|
|
|
|
|
|
|
|
2255
|
|
|
|
|
|
|
$log->debug( 'Describe cache operation' ) |
2256
|
|
|
|
|
|
|
if $class->is_verbose( $operation_type ); |
2257
|
|
|
|
|
|
|
$log->debug( 'Describe cache operation' ) |
2258
|
|
|
|
|
|
|
if $object->is_verbose( $operation_type ); |
2259
|
|
|
|
|
|
|
|
2260
|
|
|
|
|
|
|
Currently, the following types of operations are supported: |
2261
|
|
|
|
|
|
|
|
2262
|
|
|
|
|
|
|
=over 8 |
2263
|
|
|
|
|
|
|
|
2264
|
|
|
|
|
|
|
=item * 'cache_operations' |
2265
|
|
|
|
|
|
|
|
2266
|
|
|
|
|
|
|
=back |
2267
|
|
|
|
|
|
|
|
2268
|
|
|
|
|
|
|
=back |
2269
|
|
|
|
|
|
|
|
2270
|
|
|
|
|
|
|
=cut |
2271
|
|
|
|
|
|
|
|
2272
|
|
|
|
|
|
|
sub is_verbose |
2273
|
|
|
|
|
|
|
{ |
2274
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $specific_area ) = @_; |
2275
|
|
|
|
|
|
|
|
2276
|
0
|
|
|
|
|
0
|
my $cached_static_class_info = $self->cached_static_class_info(); |
2277
|
|
|
|
|
|
|
|
2278
|
0
|
0
|
|
|
|
0
|
if ( defined( $specific_area ) ) |
2279
|
|
|
|
|
|
|
{ |
2280
|
0
|
|
|
|
|
0
|
my $info_key = 'verbose_' . $specific_area; |
2281
|
|
|
|
|
|
|
|
2282
|
|
|
|
|
|
|
croak "'$specific_area' is not valid" |
2283
|
0
|
0
|
|
|
|
0
|
if ! exists( $cached_static_class_info->{ $info_key } ); |
2284
|
|
|
|
|
|
|
|
2285
|
0
|
|
|
|
|
0
|
return $cached_static_class_info->get( $info_key ); |
2286
|
|
|
|
|
|
|
} |
2287
|
|
|
|
|
|
|
else |
2288
|
|
|
|
|
|
|
{ |
2289
|
0
|
|
|
|
|
0
|
return $cached_static_class_info->get('verbose'); |
2290
|
|
|
|
|
|
|
} |
2291
|
|
|
|
|
|
|
} |
2292
|
|
|
|
|
|
|
|
2293
|
|
|
|
|
|
|
|
2294
|
|
|
|
|
|
|
=head1 CACHE RELATED METHODS |
2295
|
|
|
|
|
|
|
|
2296
|
|
|
|
|
|
|
|
2297
|
|
|
|
|
|
|
=head2 cached_static_class_info() |
2298
|
|
|
|
|
|
|
|
2299
|
|
|
|
|
|
|
Return a cached version of the information retrieved by C. |
2300
|
|
|
|
|
|
|
|
2301
|
|
|
|
|
|
|
my $static_class_info = $class->cached_static_class_info(); |
2302
|
|
|
|
|
|
|
my $static_class_info = $object->cached_static_class_info(); |
2303
|
|
|
|
|
|
|
|
2304
|
|
|
|
|
|
|
=cut |
2305
|
|
|
|
|
|
|
|
2306
|
|
|
|
|
|
|
{ |
2307
|
|
|
|
|
|
|
my $CACHE = {}; |
2308
|
|
|
|
|
|
|
sub cached_static_class_info |
2309
|
|
|
|
|
|
|
{ |
2310
|
963
|
|
|
963
|
1
|
1435
|
my ( $self ) = @_; |
2311
|
963
|
|
66
|
|
|
2854
|
my $class = ref( $self ) || $self; |
2312
|
|
|
|
|
|
|
|
2313
|
963
|
|
66
|
|
|
2308
|
$CACHE->{ $class } ||= $class->static_class_info(); |
2314
|
|
|
|
|
|
|
|
2315
|
963
|
|
|
|
|
5054
|
return $CACHE->{ $class } |
2316
|
|
|
|
|
|
|
} |
2317
|
|
|
|
|
|
|
} |
2318
|
|
|
|
|
|
|
|
2319
|
|
|
|
|
|
|
|
2320
|
|
|
|
|
|
|
=head2 get_table_schema() |
2321
|
|
|
|
|
|
|
|
2322
|
|
|
|
|
|
|
Return the schema corresponding to the underlying table. |
2323
|
|
|
|
|
|
|
|
2324
|
|
|
|
|
|
|
my $table_schema = $class->get_table_schema(); |
2325
|
|
|
|
|
|
|
my $table_schema = $object->get_table_schema(); |
2326
|
|
|
|
|
|
|
|
2327
|
|
|
|
|
|
|
=cut |
2328
|
|
|
|
|
|
|
|
2329
|
|
|
|
|
|
|
{ |
2330
|
|
|
|
|
|
|
my $TABLE_SCHEMAS_CACHE = {}; |
2331
|
|
|
|
|
|
|
sub get_table_schema |
2332
|
|
|
|
|
|
|
{ |
2333
|
1
|
|
|
1
|
1
|
1253
|
my ( $self ) = @_; |
2334
|
1
|
|
33
|
|
|
7
|
my $class = ref( $self ) || $self; |
2335
|
|
|
|
|
|
|
|
2336
|
1
|
50
|
|
|
|
4
|
if ( !defined( $TABLE_SCHEMAS_CACHE->{ $class } ) ) |
2337
|
|
|
|
|
|
|
{ |
2338
|
1
|
|
|
|
|
11
|
my $dbh = $class->assert_dbh(); |
2339
|
1
|
|
|
|
|
6
|
my $table_name = $self->get_info('table_name'); |
2340
|
|
|
|
|
|
|
|
2341
|
1
|
|
|
|
|
5
|
Class::Load::load_class( 'DBIx::NinjaORM::Schema::Table' ); |
2342
|
1
|
|
|
|
|
75
|
my $table_schema = DBIx::NinjaORM::Schema::Table->new( |
2343
|
|
|
|
|
|
|
name => $table_name, |
2344
|
|
|
|
|
|
|
dbh => $self->assert_dbh(), |
2345
|
|
|
|
|
|
|
); |
2346
|
1
|
|
|
|
|
3
|
$table_schema->get_columns(); |
2347
|
1
|
|
|
|
|
4
|
$TABLE_SCHEMAS_CACHE->{ $class } = $table_schema; |
2348
|
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
|
croak "Failed to load schema for '$table_name'" |
2350
|
1
|
50
|
|
|
|
10
|
if !defined( $TABLE_SCHEMAS_CACHE->{ $class } ); |
2351
|
|
|
|
|
|
|
} |
2352
|
|
|
|
|
|
|
|
2353
|
1
|
|
|
|
|
9
|
return $TABLE_SCHEMAS_CACHE->{ $class }; |
2354
|
|
|
|
|
|
|
} |
2355
|
|
|
|
|
|
|
} |
2356
|
|
|
|
|
|
|
|
2357
|
|
|
|
|
|
|
|
2358
|
|
|
|
|
|
|
=head2 delete_cache() |
2359
|
|
|
|
|
|
|
|
2360
|
|
|
|
|
|
|
Delete a key from the cache. |
2361
|
|
|
|
|
|
|
|
2362
|
|
|
|
|
|
|
my $value = $class->delete_cache( key => $key ); |
2363
|
|
|
|
|
|
|
|
2364
|
|
|
|
|
|
|
=cut |
2365
|
|
|
|
|
|
|
|
2366
|
|
|
|
|
|
|
sub delete_cache |
2367
|
|
|
|
|
|
|
{ |
2368
|
0
|
|
|
0
|
1
|
0
|
my ( $self, %args ) = @_; |
2369
|
0
|
|
|
|
|
0
|
my $key = delete( $args{'key'} ); |
2370
|
0
|
0
|
|
|
|
0
|
croak 'Invalid argument(s): ' . join( ', ', keys %args ) |
2371
|
|
|
|
|
|
|
if scalar( keys %args ) != 0; |
2372
|
|
|
|
|
|
|
|
2373
|
|
|
|
|
|
|
# Check parameters. |
2374
|
0
|
0
|
0
|
|
|
0
|
croak 'The parameter "key" is mandatory' |
2375
|
|
|
|
|
|
|
if !defined( $key ) || $key !~ /\w/; |
2376
|
|
|
|
|
|
|
|
2377
|
0
|
|
|
|
|
0
|
my $memcache = $self->get_info('memcache'); |
2378
|
|
|
|
|
|
|
return undef |
2379
|
0
|
0
|
|
|
|
0
|
if !defined( $memcache ); |
2380
|
|
|
|
|
|
|
|
2381
|
0
|
|
|
|
|
0
|
return $memcache->delete( $key ); |
2382
|
|
|
|
|
|
|
} |
2383
|
|
|
|
|
|
|
|
2384
|
|
|
|
|
|
|
|
2385
|
|
|
|
|
|
|
=head2 get_cache() |
2386
|
|
|
|
|
|
|
|
2387
|
|
|
|
|
|
|
Get a value from the cache. |
2388
|
|
|
|
|
|
|
|
2389
|
|
|
|
|
|
|
my $value = $class->get_cache( key => $key ); |
2390
|
|
|
|
|
|
|
|
2391
|
|
|
|
|
|
|
=cut |
2392
|
|
|
|
|
|
|
|
2393
|
|
|
|
|
|
|
sub get_cache |
2394
|
|
|
|
|
|
|
{ |
2395
|
0
|
|
|
0
|
1
|
0
|
my ( $self, %args ) = @_; |
2396
|
0
|
|
|
|
|
0
|
my $key = delete( $args{'key'} ); |
2397
|
0
|
0
|
|
|
|
0
|
croak 'Invalid argument(s): ' . join( ', ', keys %args ) |
2398
|
|
|
|
|
|
|
if scalar( keys %args ) != 0; |
2399
|
|
|
|
|
|
|
|
2400
|
|
|
|
|
|
|
# Check parameters. |
2401
|
0
|
0
|
0
|
|
|
0
|
croak 'The parameter "key" is mandatory' |
2402
|
|
|
|
|
|
|
if !defined( $key ) || $key !~ /\w/; |
2403
|
|
|
|
|
|
|
|
2404
|
0
|
|
|
|
|
0
|
my $memcache = $self->get_info('memcache'); |
2405
|
|
|
|
|
|
|
return undef |
2406
|
0
|
0
|
|
|
|
0
|
if !defined( $memcache ); |
2407
|
|
|
|
|
|
|
|
2408
|
0
|
|
|
|
|
0
|
return $memcache->get( $key ); |
2409
|
|
|
|
|
|
|
} |
2410
|
|
|
|
|
|
|
|
2411
|
|
|
|
|
|
|
|
2412
|
|
|
|
|
|
|
=head2 get_object_cache_key() |
2413
|
|
|
|
|
|
|
|
2414
|
|
|
|
|
|
|
Return the name of the cache key for an object or a class, given a field name |
2415
|
|
|
|
|
|
|
on which a unique constraint exists and the corresponding value. |
2416
|
|
|
|
|
|
|
|
2417
|
|
|
|
|
|
|
my $cache_key = $object->get_object_cache_key(); |
2418
|
|
|
|
|
|
|
my $cache_key = $class->get_object_cache_key( |
2419
|
|
|
|
|
|
|
unique_field => $unique_field, |
2420
|
|
|
|
|
|
|
value => $value, |
2421
|
|
|
|
|
|
|
); |
2422
|
|
|
|
|
|
|
|
2423
|
|
|
|
|
|
|
=cut |
2424
|
|
|
|
|
|
|
|
2425
|
|
|
|
|
|
|
sub get_object_cache_key |
2426
|
|
|
|
|
|
|
{ |
2427
|
0
|
|
|
0
|
1
|
0
|
my ( $self, %args ) = @_; |
2428
|
0
|
|
|
|
|
0
|
my $unique_field = delete( $args{'unique_field'} ); |
2429
|
0
|
|
|
|
|
0
|
my $value = delete( $args{'value'} ); |
2430
|
|
|
|
|
|
|
|
2431
|
|
|
|
|
|
|
# Retrieve the field we'll use to create the cache key. |
2432
|
0
|
|
|
|
|
0
|
my $cache_key_field = $self->get_cache_key_field(); |
2433
|
0
|
0
|
|
|
|
0
|
croak 'No cache key found for class' |
2434
|
|
|
|
|
|
|
if !defined( $cache_key_field ); |
2435
|
|
|
|
|
|
|
|
2436
|
0
|
|
|
|
|
0
|
my $table_name = $self->get_info('table_name'); |
2437
|
0
|
0
|
|
|
|
0
|
if ( defined( $unique_field ) ) |
2438
|
|
|
|
|
|
|
{ |
2439
|
0
|
0
|
|
|
|
0
|
if ( !defined( $value ) ) |
2440
|
|
|
|
|
|
|
{ |
2441
|
0
|
|
|
|
|
0
|
$log->debugf( |
2442
|
|
|
|
|
|
|
"Passed unique field '%s' without a corresponding value for " |
2443
|
|
|
|
|
|
|
. "table '%s', cannot determine cache key", |
2444
|
|
|
|
|
|
|
$unique_field, |
2445
|
|
|
|
|
|
|
$table_name, |
2446
|
|
|
|
|
|
|
); |
2447
|
0
|
|
|
|
|
0
|
return; |
2448
|
|
|
|
|
|
|
} |
2449
|
|
|
|
|
|
|
|
2450
|
|
|
|
|
|
|
# 'id' is only an alias and needs to be expanded to its actual name. |
2451
|
0
|
0
|
|
|
|
0
|
$unique_field = $self->get_info('primary_key_name') |
2452
|
|
|
|
|
|
|
if $unique_field eq 'id'; |
2453
|
|
|
|
|
|
|
} |
2454
|
|
|
|
|
|
|
else |
2455
|
|
|
|
|
|
|
{ |
2456
|
|
|
|
|
|
|
# If no unique field was passed, use the $cache_key_field field and its |
2457
|
|
|
|
|
|
|
# corresponding value. |
2458
|
0
|
0
|
|
|
|
0
|
if ( Data::Validate::Type::is_hashref( $self ) ) |
2459
|
|
|
|
|
|
|
{ |
2460
|
0
|
|
|
|
|
0
|
$unique_field = $cache_key_field; |
2461
|
0
|
|
|
|
|
0
|
$value = $self->{ $unique_field }; |
2462
|
|
|
|
|
|
|
|
2463
|
0
|
0
|
|
|
|
0
|
unless ( defined( $value ) ) |
2464
|
|
|
|
|
|
|
{ |
2465
|
0
|
|
|
|
|
0
|
$log->debugf( |
2466
|
|
|
|
|
|
|
"Trying to use field '%s' on table '%s' to generate " |
2467
|
|
|
|
|
|
|
. "a cache key, but the value for that field on the " |
2468
|
|
|
|
|
|
|
. "object is undef", |
2469
|
|
|
|
|
|
|
$cache_key_field, |
2470
|
|
|
|
|
|
|
$table_name, |
2471
|
|
|
|
|
|
|
); |
2472
|
0
|
|
|
|
|
0
|
return; |
2473
|
|
|
|
|
|
|
} |
2474
|
|
|
|
|
|
|
} |
2475
|
|
|
|
|
|
|
else |
2476
|
|
|
|
|
|
|
{ |
2477
|
0
|
|
|
|
|
0
|
$log->debug( |
2478
|
|
|
|
|
|
|
"If you don't specify a unique field and value, you need to " |
2479
|
|
|
|
|
|
|
. "call this function on an object" |
2480
|
|
|
|
|
|
|
); |
2481
|
0
|
|
|
|
|
0
|
return; |
2482
|
|
|
|
|
|
|
} |
2483
|
|
|
|
|
|
|
} |
2484
|
|
|
|
|
|
|
|
2485
|
|
|
|
|
|
|
# If the unique field passed doesn't match what the cache key is, we need |
2486
|
|
|
|
|
|
|
# to do a database lookup to find out the corresponding cache key. |
2487
|
0
|
|
|
|
|
0
|
my $cache_key_value; |
2488
|
0
|
0
|
|
|
|
0
|
if ( $unique_field ne $cache_key_field ) |
2489
|
|
|
|
|
|
|
{ |
2490
|
0
|
|
|
|
|
0
|
my $dbh = $self->assert_dbh(); |
2491
|
|
|
|
|
|
|
|
2492
|
0
|
|
|
|
|
0
|
$cache_key_value = $dbh->selectrow_arrayref( |
2493
|
|
|
|
|
|
|
sprintf( |
2494
|
|
|
|
|
|
|
q| |
2495
|
|
|
|
|
|
|
SELECT %s |
2496
|
|
|
|
|
|
|
FROM %s |
2497
|
|
|
|
|
|
|
WHERE %s = ? |
2498
|
|
|
|
|
|
|
|, |
2499
|
|
|
|
|
|
|
$dbh->quote_identifier( $cache_key_field ), |
2500
|
|
|
|
|
|
|
$dbh->quote_identifier( $table_name ), |
2501
|
|
|
|
|
|
|
$dbh->quote_identifier( $unique_field ), |
2502
|
|
|
|
|
|
|
), |
2503
|
|
|
|
|
|
|
{}, |
2504
|
|
|
|
|
|
|
$value, |
2505
|
|
|
|
|
|
|
); |
2506
|
|
|
|
|
|
|
|
2507
|
0
|
0
|
0
|
|
|
0
|
$cache_key_value = defined( $cache_key_value ) && scalar( @$cache_key_value ) != 0 |
2508
|
|
|
|
|
|
|
? $cache_key_value->[0] |
2509
|
|
|
|
|
|
|
: undef; |
2510
|
|
|
|
|
|
|
|
2511
|
0
|
0
|
|
|
|
0
|
unless ( defined( $cache_key_value ) ) |
2512
|
|
|
|
|
|
|
{ |
2513
|
0
|
0
|
|
|
|
0
|
$log->debugf( |
2514
|
|
|
|
|
|
|
"Cache miss for unique field '%s' and value '%s' on table " |
2515
|
|
|
|
|
|
|
. "'%s', cannot generate cache key.", |
2516
|
|
|
|
|
|
|
$unique_field, |
2517
|
|
|
|
|
|
|
$value, |
2518
|
|
|
|
|
|
|
$table_name, |
2519
|
|
|
|
|
|
|
) if $self->is_verbose(); |
2520
|
0
|
|
|
|
|
0
|
return; |
2521
|
|
|
|
|
|
|
} |
2522
|
|
|
|
|
|
|
} |
2523
|
|
|
|
|
|
|
else |
2524
|
|
|
|
|
|
|
{ |
2525
|
0
|
|
|
|
|
0
|
$cache_key_value = $value; |
2526
|
|
|
|
|
|
|
} |
2527
|
|
|
|
|
|
|
|
2528
|
0
|
|
|
|
|
0
|
return lc( 'object|' . $table_name . '|' . $cache_key_field . '|' . $cache_key_value ); |
2529
|
|
|
|
|
|
|
} |
2530
|
|
|
|
|
|
|
|
2531
|
|
|
|
|
|
|
|
2532
|
|
|
|
|
|
|
=head2 invalidate_cached_object() |
2533
|
|
|
|
|
|
|
|
2534
|
|
|
|
|
|
|
Invalidate the cached copies of the current object across all the unique |
2535
|
|
|
|
|
|
|
keys this object can be referenced with. |
2536
|
|
|
|
|
|
|
|
2537
|
|
|
|
|
|
|
$object->invalidate_cached_object(); |
2538
|
|
|
|
|
|
|
|
2539
|
|
|
|
|
|
|
=cut |
2540
|
|
|
|
|
|
|
|
2541
|
|
|
|
|
|
|
sub invalidate_cached_object |
2542
|
|
|
|
|
|
|
{ |
2543
|
0
|
|
|
0
|
1
|
0
|
my ( $self ) = @_; |
2544
|
|
|
|
|
|
|
|
2545
|
0
|
|
|
|
|
0
|
my $primary_key_name = $self->get_info('primary_key_name'); |
2546
|
0
|
0
|
|
|
|
0
|
if ( defined( $primary_key_name ) ) |
2547
|
|
|
|
|
|
|
{ |
2548
|
0
|
|
|
|
|
0
|
my $cache_key = $self->get_object_cache_key( |
2549
|
|
|
|
|
|
|
unique_field => 'id', |
2550
|
|
|
|
|
|
|
value => $self->id(), |
2551
|
|
|
|
|
|
|
); |
2552
|
0
|
0
|
|
|
|
0
|
$self->delete_cache( key => $cache_key ) |
2553
|
|
|
|
|
|
|
if defined( $cache_key ); |
2554
|
|
|
|
|
|
|
} |
2555
|
|
|
|
|
|
|
|
2556
|
0
|
|
0
|
|
|
0
|
foreach my $field ( @{ $self->get_info('unique_fields') // [] } ) |
|
0
|
|
|
|
|
0
|
|
2557
|
|
|
|
|
|
|
{ |
2558
|
|
|
|
|
|
|
# If the object has no value for the unique field, it wasn't |
2559
|
|
|
|
|
|
|
# cached for this key/value pair and we can't build a cache key |
2560
|
|
|
|
|
|
|
# for it anyway, so we just skip to the next unique field. |
2561
|
0
|
0
|
|
|
|
0
|
next unless defined( $self->{ $field } ); |
2562
|
|
|
|
|
|
|
|
2563
|
|
|
|
|
|
|
my $cache_key = $self->get_object_cache_key( |
2564
|
|
|
|
|
|
|
unique_field => $field, |
2565
|
0
|
|
|
|
|
0
|
value => $self->{ $field }, |
2566
|
|
|
|
|
|
|
); |
2567
|
0
|
0
|
|
|
|
0
|
$self->delete_cache( key => $cache_key ) |
2568
|
|
|
|
|
|
|
if defined( $cache_key ); |
2569
|
|
|
|
|
|
|
} |
2570
|
|
|
|
|
|
|
|
2571
|
0
|
|
|
|
|
0
|
return 1; |
2572
|
|
|
|
|
|
|
} |
2573
|
|
|
|
|
|
|
|
2574
|
|
|
|
|
|
|
|
2575
|
|
|
|
|
|
|
=head2 retrieve_list_cache() |
2576
|
|
|
|
|
|
|
|
2577
|
|
|
|
|
|
|
Dispatch of retrieve_list() when objects should be retrieved from the cache. |
2578
|
|
|
|
|
|
|
|
2579
|
|
|
|
|
|
|
See C for the parameters this method accepts. |
2580
|
|
|
|
|
|
|
|
2581
|
|
|
|
|
|
|
=cut |
2582
|
|
|
|
|
|
|
|
2583
|
|
|
|
|
|
|
sub retrieve_list_cache ## no critic (Subroutines::ProhibitExcessComplexity) |
2584
|
|
|
|
|
|
|
{ |
2585
|
0
|
|
|
0
|
1
|
0
|
my ( $class, $filters, %args ) = @_; |
2586
|
0
|
|
|
|
|
0
|
my $list_cache_time = $class->get_info('list_cache_time'); |
2587
|
0
|
|
|
|
|
0
|
my $object_cache_time = $class->get_info('object_cache_time'); |
2588
|
0
|
|
|
|
|
0
|
my $primary_key_name = $class->get_info('primary_key_name'); |
2589
|
|
|
|
|
|
|
|
2590
|
|
|
|
|
|
|
# Create a unique cache key. |
2591
|
0
|
|
|
|
|
0
|
my $list_cache_keys = []; |
2592
|
0
|
|
|
|
|
0
|
foreach my $filter ( keys %$filters ) |
2593
|
|
|
|
|
|
|
{ |
2594
|
|
|
|
|
|
|
# Force all arguments into lower case for purposes of caching. |
2595
|
0
|
|
|
|
|
0
|
push( @$list_cache_keys, [ lc( $filter ), $filters->{ $filter } ] ); |
2596
|
|
|
|
|
|
|
} |
2597
|
0
|
|
|
|
|
0
|
foreach my $arg ( sort keys %args ) |
2598
|
|
|
|
|
|
|
{ |
2599
|
|
|
|
|
|
|
# Those arguments don't have an impact on the filters to IDs translation, |
2600
|
|
|
|
|
|
|
# so we can exclude them from the unique cache key. |
2601
|
0
|
|
|
|
|
0
|
my $has_impact = $RETRIEVE_LIST_VALID_ARGUMENTS->{ $arg }; |
2602
|
0
|
0
|
|
|
|
0
|
croak "The argument '$arg' is not valid" |
2603
|
|
|
|
|
|
|
if !defined( $has_impact ); |
2604
|
0
|
0
|
|
|
|
0
|
next if !$has_impact; |
2605
|
|
|
|
|
|
|
|
2606
|
|
|
|
|
|
|
# Force all arguments into lower case for purposes of caching. |
2607
|
0
|
|
|
|
|
0
|
push( @$list_cache_keys, [ lc( $arg ), $args{ $arg } ] ); |
2608
|
|
|
|
|
|
|
} |
2609
|
|
|
|
|
|
|
|
2610
|
0
|
|
|
|
|
0
|
my $list_cache_key = MIME::Base64::encode_base64( Storable::freeze( $list_cache_keys ) ); |
2611
|
0
|
|
|
|
|
0
|
chomp( $list_cache_key ); |
2612
|
0
|
|
|
|
|
0
|
my $list_cache_key_sha1 = Digest::SHA1::sha1_base64( $list_cache_key ); |
2613
|
|
|
|
|
|
|
|
2614
|
|
|
|
|
|
|
# Find out if the parameters are searching by ID or using a unique field. |
2615
|
0
|
|
|
|
|
0
|
my $search_field; |
2616
|
|
|
|
|
|
|
my $list_of_search_values; |
2617
|
0
|
|
0
|
|
|
0
|
foreach my $field ( 'id', @{ $class->get_info('unique_fields') // [] } ) |
|
0
|
|
|
|
|
0
|
|
2618
|
|
|
|
|
|
|
{ |
2619
|
|
|
|
|
|
|
next |
2620
|
0
|
0
|
|
|
|
0
|
unless exists( $filters->{ $field } ); |
2621
|
|
|
|
|
|
|
|
2622
|
0
|
|
|
|
|
0
|
$search_field = $field; |
2623
|
|
|
|
|
|
|
|
2624
|
|
|
|
|
|
|
$list_of_search_values = Data::Validate::Type::filter_arrayref( $filters->{ $field } ) |
2625
|
0
|
|
0
|
|
|
0
|
// [ $filters->{ $field } ]; |
2626
|
|
|
|
|
|
|
} |
2627
|
|
|
|
|
|
|
|
2628
|
|
|
|
|
|
|
# If we're searcing by ID or unique field, those are how the objects are |
2629
|
|
|
|
|
|
|
# cached so we already know how to retrieve them from the object cache. |
2630
|
|
|
|
|
|
|
# If we're searching by anything else, then we maintain a "list cache", |
2631
|
|
|
|
|
|
|
# which associates retrieve_list() args with the resulting IDs. |
2632
|
0
|
|
|
|
|
0
|
my $pagination; |
2633
|
0
|
|
|
|
|
0
|
my $list_cache_used = 0; |
2634
|
0
|
0
|
|
|
|
0
|
if ( !defined( $search_field ) ) |
2635
|
|
|
|
|
|
|
{ |
2636
|
|
|
|
|
|
|
# Test if we have a corresponding list of IDs in the cache. |
2637
|
0
|
|
|
|
|
0
|
my $cache = $class->get_cache( key => $list_cache_key_sha1 ); |
2638
|
|
|
|
|
|
|
|
2639
|
0
|
0
|
|
|
|
0
|
if ( defined( $cache ) ) |
2640
|
|
|
|
|
|
|
{ |
2641
|
0
|
|
|
|
|
0
|
my $cache_content = Storable::thaw( MIME::Base64::decode_base64( $cache ) ); |
2642
|
0
|
|
0
|
|
|
0
|
my ( $original_list_cache_key, $original_pagination, $original_search_field, $original_list_of_ids ) = @{ Data::Validate::Type::filter_arrayref( $cache_content ) // [] }; |
|
0
|
|
|
|
|
0
|
|
2643
|
|
|
|
|
|
|
|
2644
|
|
|
|
|
|
|
# We need to use SHA1 due to the limitation on the length of memcache keys |
2645
|
|
|
|
|
|
|
# (we can't just cache $cache_key). |
2646
|
|
|
|
|
|
|
# However, there is a very small risk of collision so we check here that |
2647
|
|
|
|
|
|
|
# the cache key stored inside the cache entry is the same. |
2648
|
0
|
0
|
|
|
|
0
|
if ( $original_list_cache_key eq $list_cache_key ) |
2649
|
|
|
|
|
|
|
{ |
2650
|
0
|
|
|
|
|
0
|
$list_of_search_values = $original_list_of_ids; |
2651
|
0
|
|
|
|
|
0
|
$pagination = $original_pagination; |
2652
|
0
|
|
|
|
|
0
|
$search_field = $original_search_field; |
2653
|
0
|
|
|
|
|
0
|
$list_cache_used = 1; |
2654
|
|
|
|
|
|
|
} |
2655
|
|
|
|
|
|
|
} |
2656
|
|
|
|
|
|
|
} |
2657
|
|
|
|
|
|
|
|
2658
|
0
|
|
|
|
|
0
|
my $cached_objects = {}; |
2659
|
0
|
|
|
|
|
0
|
my $objects; |
2660
|
0
|
0
|
0
|
|
|
0
|
if ( !$args{'lock'} && defined( $list_of_search_values ) ) |
2661
|
|
|
|
|
|
|
{ |
2662
|
0
|
0
|
|
|
|
0
|
$log->debug( "Using values (unique/IDs) from the list cache" ) |
2663
|
|
|
|
|
|
|
if $class->is_verbose('cache_operations'); |
2664
|
|
|
|
|
|
|
|
2665
|
|
|
|
|
|
|
# If we're not trying to lock the underlying rows, and we have a list of |
2666
|
|
|
|
|
|
|
# IDs from the cache, we try to get the objects from the object cache. |
2667
|
0
|
|
|
|
|
0
|
my $objects_to_retrieve_from_database = {}; |
2668
|
0
|
|
|
|
|
0
|
foreach my $search_value ( @$list_of_search_values ) |
2669
|
|
|
|
|
|
|
{ |
2670
|
0
|
0
|
|
|
|
0
|
my $object_cache_key = $class->get_object_cache_key( |
2671
|
|
|
|
|
|
|
unique_field => $search_field eq 'id' |
2672
|
|
|
|
|
|
|
? $primary_key_name |
2673
|
|
|
|
|
|
|
: $search_field, |
2674
|
|
|
|
|
|
|
value => $search_value, |
2675
|
|
|
|
|
|
|
); |
2676
|
|
|
|
|
|
|
|
2677
|
0
|
0
|
|
|
|
0
|
my $object = defined( $object_cache_key ) |
2678
|
|
|
|
|
|
|
? $class->get_cache( key => $object_cache_key ) |
2679
|
|
|
|
|
|
|
: undef; |
2680
|
|
|
|
|
|
|
|
2681
|
0
|
0
|
|
|
|
0
|
if ( defined( $object ) ) |
2682
|
|
|
|
|
|
|
{ |
2683
|
0
|
0
|
|
|
|
0
|
$log->debugf( |
2684
|
|
|
|
|
|
|
"Retrieved '%s' from cache.", |
2685
|
|
|
|
|
|
|
$object_cache_key, |
2686
|
|
|
|
|
|
|
) if $class->is_verbose('cache_operations'); |
2687
|
|
|
|
|
|
|
|
2688
|
0
|
|
|
|
|
0
|
$object->{'_debug'}->{'object_cache_used'} = 1; |
2689
|
|
|
|
|
|
|
|
2690
|
0
|
0
|
|
|
|
0
|
my $hash_key = lc( |
2691
|
|
|
|
|
|
|
$search_field eq 'id' |
2692
|
|
|
|
|
|
|
? $object->id() |
2693
|
|
|
|
|
|
|
: $object->get( $search_field ) |
2694
|
|
|
|
|
|
|
); |
2695
|
|
|
|
|
|
|
|
2696
|
0
|
|
|
|
|
0
|
$cached_objects->{ $hash_key } = $object; |
2697
|
|
|
|
|
|
|
} |
2698
|
|
|
|
|
|
|
else |
2699
|
|
|
|
|
|
|
{ |
2700
|
0
|
0
|
|
|
|
0
|
$log->debugf( |
2701
|
|
|
|
|
|
|
"'%s' not found in the cache.", |
2702
|
|
|
|
|
|
|
$object_cache_key, |
2703
|
|
|
|
|
|
|
) if $class->is_verbose('cache_operations'); |
2704
|
|
|
|
|
|
|
|
2705
|
0
|
|
|
|
|
0
|
$objects_to_retrieve_from_database->{ lc( $search_value ) } = $object_cache_key; |
2706
|
|
|
|
|
|
|
} |
2707
|
|
|
|
|
|
|
} |
2708
|
|
|
|
|
|
|
|
2709
|
|
|
|
|
|
|
# If we have any ID we couldn't get an object for from the cache, we now |
2710
|
|
|
|
|
|
|
# go to the database. |
2711
|
0
|
0
|
|
|
|
0
|
if ( scalar( keys %$objects_to_retrieve_from_database ) != 0 ) |
2712
|
|
|
|
|
|
|
{ |
2713
|
0
|
0
|
|
|
|
0
|
$log->debug( |
2714
|
|
|
|
|
|
|
"The following objects are not cached and need to be retrieved from the database: %s", |
2715
|
|
|
|
|
|
|
join( ', ', keys %$objects_to_retrieve_from_database ), |
2716
|
|
|
|
|
|
|
) if $class->is_verbose('cache_operations'); |
2717
|
|
|
|
|
|
|
|
2718
|
|
|
|
|
|
|
# We don't want to pass %args, which has a lot of information that may |
2719
|
|
|
|
|
|
|
# actually conflict with what we're trying to do here. However, some of |
2720
|
|
|
|
|
|
|
# the arguments are important, such as 'dbh' to connect to the correct |
2721
|
|
|
|
|
|
|
# database. We filter here the relevant arguments. |
2722
|
|
|
|
|
|
|
my %local_args = |
2723
|
0
|
|
|
|
|
0
|
map { $_ => $args{ $_ } } |
2724
|
0
|
|
|
|
|
0
|
grep { defined( $args{ $_ } ) } |
|
0
|
|
|
|
|
0
|
|
2725
|
|
|
|
|
|
|
qw( dbh show_queries exclude_fields select_fields ); |
2726
|
|
|
|
|
|
|
|
2727
|
0
|
|
|
|
|
0
|
$objects = $class->retrieve_list_nocache( |
2728
|
|
|
|
|
|
|
{ |
2729
|
|
|
|
|
|
|
$search_field => [ keys %$objects_to_retrieve_from_database ], |
2730
|
|
|
|
|
|
|
}, |
2731
|
|
|
|
|
|
|
%local_args, |
2732
|
|
|
|
|
|
|
); |
2733
|
|
|
|
|
|
|
} |
2734
|
|
|
|
|
|
|
|
2735
|
|
|
|
|
|
|
# Indicate that we've used the list cache to retrieve the list of object |
2736
|
|
|
|
|
|
|
# IDs. |
2737
|
0
|
0
|
|
|
|
0
|
if ( $list_cache_used ) |
2738
|
|
|
|
|
|
|
{ |
2739
|
0
|
|
0
|
|
|
0
|
foreach my $object ( values %$cached_objects, @{ $objects // [] } ) |
|
0
|
|
|
|
|
0
|
|
2740
|
|
|
|
|
|
|
{ |
2741
|
0
|
|
|
|
|
0
|
$object->{'_debug'}->{'list_cache_used'} = 1; |
2742
|
|
|
|
|
|
|
} |
2743
|
|
|
|
|
|
|
} |
2744
|
|
|
|
|
|
|
} |
2745
|
|
|
|
|
|
|
else |
2746
|
|
|
|
|
|
|
{ |
2747
|
|
|
|
|
|
|
# If we don't have a list of IDs, we need to go to the database via |
2748
|
|
|
|
|
|
|
# retrieve_list_nocache() to get the objects. |
2749
|
0
|
|
|
|
|
0
|
( $objects, $pagination ) = $class->retrieve_list_nocache( |
2750
|
|
|
|
|
|
|
$filters, |
2751
|
|
|
|
|
|
|
%args, |
2752
|
|
|
|
|
|
|
); |
2753
|
|
|
|
|
|
|
|
2754
|
|
|
|
|
|
|
# Set the list cache. |
2755
|
0
|
|
|
|
|
0
|
my $list_cache_ids = [ map { $_->id() } @$objects ]; |
|
0
|
|
|
|
|
0
|
|
2756
|
|
|
|
|
|
|
|
2757
|
0
|
0
|
|
|
|
0
|
$log->debugf( |
2758
|
|
|
|
|
|
|
"Adding key '%s' to the list cache, with the following IDs: %s", |
2759
|
|
|
|
|
|
|
$list_cache_key, |
2760
|
|
|
|
|
|
|
join( ', ', @$list_cache_ids ), |
2761
|
|
|
|
|
|
|
) if $class->is_verbose('cache_operations'); |
2762
|
|
|
|
|
|
|
|
2763
|
0
|
|
|
|
|
0
|
$class->set_cache( |
2764
|
|
|
|
|
|
|
key => $list_cache_key_sha1, |
2765
|
|
|
|
|
|
|
value => MIME::Base64::encode_base64( |
2766
|
|
|
|
|
|
|
Storable::freeze( |
2767
|
|
|
|
|
|
|
[ |
2768
|
|
|
|
|
|
|
$list_cache_key, |
2769
|
|
|
|
|
|
|
$pagination, |
2770
|
|
|
|
|
|
|
'id', |
2771
|
|
|
|
|
|
|
$list_cache_ids, |
2772
|
|
|
|
|
|
|
] |
2773
|
|
|
|
|
|
|
) |
2774
|
|
|
|
|
|
|
), |
2775
|
|
|
|
|
|
|
expire_time => $list_cache_time, |
2776
|
|
|
|
|
|
|
); |
2777
|
|
|
|
|
|
|
} |
2778
|
|
|
|
|
|
|
|
2779
|
|
|
|
|
|
|
# For cache purposes, we use the search field if it is available (as it's |
2780
|
|
|
|
|
|
|
# either the primary key or a unique field), and we fall back on 'id' |
2781
|
|
|
|
|
|
|
# which exists on all objects as a primary key shortcut. |
2782
|
0
|
|
0
|
|
|
0
|
my $cache_field = $search_field // 'id'; |
2783
|
|
|
|
|
|
|
|
2784
|
|
|
|
|
|
|
# Cache the objects. |
2785
|
0
|
|
|
|
|
0
|
my $database_objects = {}; |
2786
|
0
|
|
|
|
|
0
|
foreach my $object ( @$objects ) |
2787
|
|
|
|
|
|
|
{ |
2788
|
0
|
0
|
|
|
|
0
|
my $hash_key = lc( |
2789
|
|
|
|
|
|
|
$cache_field eq 'id' |
2790
|
|
|
|
|
|
|
? $object->id() |
2791
|
|
|
|
|
|
|
: $object->get( $cache_field ) |
2792
|
|
|
|
|
|
|
); |
2793
|
|
|
|
|
|
|
|
2794
|
0
|
|
|
|
|
0
|
$database_objects->{ $hash_key } = $object; |
2795
|
|
|
|
|
|
|
|
2796
|
|
|
|
|
|
|
# If the caller forced excluding fields, we can't cache the objects here. |
2797
|
|
|
|
|
|
|
# Otherwise, we would serve incomplete objects the next time a caller |
2798
|
|
|
|
|
|
|
# requests objects without specifying the same excluded fields. |
2799
|
|
|
|
|
|
|
# Same goes for explicit fields restrictions. |
2800
|
|
|
|
|
|
|
next |
2801
|
0
|
0
|
0
|
|
|
0
|
if exists( $object->{'_excluded_fields'} ) || exists( $object->{'_selected_fields'} ); |
2802
|
|
|
|
|
|
|
|
2803
|
0
|
0
|
|
|
|
0
|
my $object_cache_key = $cache_field eq 'id' |
2804
|
|
|
|
|
|
|
? $object->get_object_cache_key() |
2805
|
|
|
|
|
|
|
: $object->get_object_cache_key( |
2806
|
|
|
|
|
|
|
unique_field => $cache_field, |
2807
|
|
|
|
|
|
|
value => $object->get( $cache_field ), |
2808
|
|
|
|
|
|
|
); |
2809
|
|
|
|
|
|
|
|
2810
|
0
|
0
|
|
|
|
0
|
next if !defined( $object_cache_key ); |
2811
|
|
|
|
|
|
|
|
2812
|
0
|
|
|
|
|
0
|
$object->{'_debug'}->{'cache_expires'} = time() + $object_cache_time; |
2813
|
|
|
|
|
|
|
|
2814
|
0
|
0
|
|
|
|
0
|
$log->debugf( |
2815
|
|
|
|
|
|
|
"Set object cache for key '%s'.", |
2816
|
|
|
|
|
|
|
$object_cache_key, |
2817
|
|
|
|
|
|
|
) if $class->is_verbose('cache_operations'); |
2818
|
|
|
|
|
|
|
|
2819
|
0
|
|
|
|
|
0
|
$class->set_cache( |
2820
|
|
|
|
|
|
|
key => $object_cache_key, |
2821
|
|
|
|
|
|
|
value => $object, |
2822
|
|
|
|
|
|
|
expire_time => $object_cache_time, |
2823
|
|
|
|
|
|
|
); |
2824
|
|
|
|
|
|
|
} |
2825
|
|
|
|
|
|
|
|
2826
|
|
|
|
|
|
|
# Make sure the objects are sorted. |
2827
|
0
|
|
|
|
|
0
|
my $sorted_objects; |
2828
|
0
|
0
|
|
|
|
0
|
if ( defined( $list_of_search_values ) ) |
2829
|
|
|
|
|
|
|
{ |
2830
|
|
|
|
|
|
|
# If we've been using a list of IDs from the cache, we need to merge |
2831
|
|
|
|
|
|
|
# the objects and sort them. |
2832
|
0
|
|
|
|
|
0
|
$sorted_objects = []; |
2833
|
0
|
|
|
|
|
0
|
foreach my $search_value ( @$list_of_search_values ) |
2834
|
|
|
|
|
|
|
{ |
2835
|
0
|
0
|
|
|
|
0
|
if ( exists( $cached_objects->{ lc( $search_value ) } ) ) |
|
|
0
|
|
|
|
|
|
2836
|
|
|
|
|
|
|
{ |
2837
|
0
|
|
|
|
|
0
|
push( @$sorted_objects, $cached_objects->{ lc( $search_value ) } ); |
2838
|
|
|
|
|
|
|
} |
2839
|
|
|
|
|
|
|
elsif ( exists( $database_objects->{ lc( $search_value ) } ) ) |
2840
|
|
|
|
|
|
|
{ |
2841
|
0
|
|
|
|
|
0
|
push( @$sorted_objects, $database_objects->{ lc( $search_value ) } ); |
2842
|
|
|
|
|
|
|
} |
2843
|
|
|
|
|
|
|
else |
2844
|
|
|
|
|
|
|
{ |
2845
|
0
|
|
|
|
|
0
|
$log->debugf( |
2846
|
|
|
|
|
|
|
'Failed to retrieve object for %s=%s', |
2847
|
|
|
|
|
|
|
$cache_field, |
2848
|
|
|
|
|
|
|
$search_value, |
2849
|
|
|
|
|
|
|
); |
2850
|
|
|
|
|
|
|
} |
2851
|
|
|
|
|
|
|
} |
2852
|
|
|
|
|
|
|
} |
2853
|
|
|
|
|
|
|
else |
2854
|
|
|
|
|
|
|
{ |
2855
|
|
|
|
|
|
|
# Otherwise, $object comes from the database and is already sorted by |
2856
|
|
|
|
|
|
|
# retrieve_list_nocache(). |
2857
|
0
|
|
|
|
|
0
|
$sorted_objects = $objects; |
2858
|
|
|
|
|
|
|
} |
2859
|
|
|
|
|
|
|
|
2860
|
|
|
|
|
|
|
# Return the objects, taking into account whether pagination is requested. |
2861
|
0
|
0
|
0
|
|
|
0
|
if ( wantarray && defined( $args{'pagination'} ) ) |
2862
|
|
|
|
|
|
|
{ |
2863
|
0
|
|
|
|
|
0
|
return ( $sorted_objects, $pagination ); |
2864
|
|
|
|
|
|
|
} |
2865
|
|
|
|
|
|
|
else |
2866
|
|
|
|
|
|
|
{ |
2867
|
0
|
|
|
|
|
0
|
return $sorted_objects; |
2868
|
|
|
|
|
|
|
} |
2869
|
|
|
|
|
|
|
} |
2870
|
|
|
|
|
|
|
|
2871
|
|
|
|
|
|
|
|
2872
|
|
|
|
|
|
|
=head2 set_cache() |
2873
|
|
|
|
|
|
|
|
2874
|
|
|
|
|
|
|
Set a value into the cache. |
2875
|
|
|
|
|
|
|
|
2876
|
|
|
|
|
|
|
$class->set_cache( |
2877
|
|
|
|
|
|
|
key => $key, |
2878
|
|
|
|
|
|
|
value => $value, |
2879
|
|
|
|
|
|
|
expire_time => $expire_time, |
2880
|
|
|
|
|
|
|
); |
2881
|
|
|
|
|
|
|
|
2882
|
|
|
|
|
|
|
=cut |
2883
|
|
|
|
|
|
|
|
2884
|
|
|
|
|
|
|
sub set_cache |
2885
|
|
|
|
|
|
|
{ |
2886
|
0
|
|
|
0
|
1
|
0
|
my ( $self, %args ) = @_; |
2887
|
0
|
|
|
|
|
0
|
my $key = delete( $args{'key'} ); |
2888
|
0
|
|
|
|
|
0
|
my $value = delete( $args{'value'} ); |
2889
|
0
|
|
|
|
|
0
|
my $expire_time = delete( $args{'expire_time'} ); |
2890
|
0
|
0
|
|
|
|
0
|
croak 'Invalid argument(s): ' . join( ', ', keys %args ) |
2891
|
|
|
|
|
|
|
if scalar( keys %args ) != 0; |
2892
|
|
|
|
|
|
|
|
2893
|
|
|
|
|
|
|
# Check parameters. |
2894
|
0
|
0
|
0
|
|
|
0
|
croak 'The argument "key" is mandatory' |
2895
|
|
|
|
|
|
|
if !defined( $key ) || $key !~ /\w/; |
2896
|
0
|
0
|
|
|
|
0
|
croak 'The argument "value" is mandatory' |
2897
|
|
|
|
|
|
|
if !defined( $value ); |
2898
|
|
|
|
|
|
|
|
2899
|
0
|
|
|
|
|
0
|
my $memcache = $self->get_info('memcache'); |
2900
|
|
|
|
|
|
|
return |
2901
|
0
|
0
|
|
|
|
0
|
if !defined( $memcache ); |
2902
|
|
|
|
|
|
|
|
2903
|
0
|
0
|
|
|
|
0
|
$memcache->set( $key, $value, $expire_time ) |
2904
|
|
|
|
|
|
|
|| $log->errorf( "Failed to set cache with key '%s'.", $key ); |
2905
|
|
|
|
|
|
|
|
2906
|
0
|
|
|
|
|
0
|
return; |
2907
|
|
|
|
|
|
|
} |
2908
|
|
|
|
|
|
|
|
2909
|
|
|
|
|
|
|
|
2910
|
|
|
|
|
|
|
=head1 INTERNAL METHODS |
2911
|
|
|
|
|
|
|
|
2912
|
|
|
|
|
|
|
Those methods are used internally by L, you should not subclass |
2913
|
|
|
|
|
|
|
them. |
2914
|
|
|
|
|
|
|
|
2915
|
|
|
|
|
|
|
|
2916
|
|
|
|
|
|
|
=head2 assert_dbh() |
2917
|
|
|
|
|
|
|
|
2918
|
|
|
|
|
|
|
Assert that there is a database handle, either a specific one passed as first |
2919
|
|
|
|
|
|
|
argument to this function (if defined) or the default one specified via |
2920
|
|
|
|
|
|
|
C, and return it. |
2921
|
|
|
|
|
|
|
|
2922
|
|
|
|
|
|
|
my $dbh = $class->assert_dbh(); |
2923
|
|
|
|
|
|
|
my $dbh = $object->assert_dbh(); |
2924
|
|
|
|
|
|
|
|
2925
|
|
|
|
|
|
|
my $dbh = $class->assert_dbh( $custom_dbh ); |
2926
|
|
|
|
|
|
|
my $dbh = $object->assert_dbh( $custom_dbh ); |
2927
|
|
|
|
|
|
|
|
2928
|
|
|
|
|
|
|
Note that this method also supports coderefs that return a C object |
2929
|
|
|
|
|
|
|
when evaluated. That way, if no database connection is needed when running the |
2930
|
|
|
|
|
|
|
code, no connection needs to be established. |
2931
|
|
|
|
|
|
|
|
2932
|
|
|
|
|
|
|
=cut |
2933
|
|
|
|
|
|
|
|
2934
|
|
|
|
|
|
|
sub assert_dbh |
2935
|
|
|
|
|
|
|
{ |
2936
|
158
|
|
|
158
|
1
|
26576
|
my ( $class, $specific_dbh ) = @_; |
2937
|
|
|
|
|
|
|
|
2938
|
158
|
|
|
|
|
211
|
my ( $dbh, $type ); |
2939
|
158
|
100
|
|
|
|
371
|
if ( defined( $specific_dbh ) ) |
2940
|
|
|
|
|
|
|
{ |
2941
|
3
|
|
|
|
|
5
|
$dbh = $specific_dbh; |
2942
|
3
|
|
|
|
|
6
|
$type = 'specified'; |
2943
|
|
|
|
|
|
|
} |
2944
|
|
|
|
|
|
|
else |
2945
|
|
|
|
|
|
|
{ |
2946
|
155
|
|
|
|
|
407
|
$dbh = $class->get_info('default_dbh'); |
2947
|
155
|
|
|
|
|
263
|
$type = 'default'; |
2948
|
|
|
|
|
|
|
} |
2949
|
|
|
|
|
|
|
|
2950
|
158
|
100
|
|
|
|
523
|
$dbh = $dbh->() |
2951
|
|
|
|
|
|
|
if Data::Validate::Type::is_coderef( $dbh ); |
2952
|
|
|
|
|
|
|
|
2953
|
158
|
100
|
|
|
|
2290
|
croak "The $type database handle is not a valid DBI::db object (" . ref( $dbh ) . ')' |
2954
|
|
|
|
|
|
|
if !Data::Validate::Type::is_instance( $dbh, class => 'DBI::db' ); |
2955
|
|
|
|
|
|
|
|
2956
|
153
|
|
|
|
|
3353
|
return $dbh; |
2957
|
|
|
|
|
|
|
} |
2958
|
|
|
|
|
|
|
|
2959
|
|
|
|
|
|
|
|
2960
|
|
|
|
|
|
|
=head2 build_filtering_clause() |
2961
|
|
|
|
|
|
|
|
2962
|
|
|
|
|
|
|
Create a filtering clause using the field, operator and values passed. |
2963
|
|
|
|
|
|
|
|
2964
|
|
|
|
|
|
|
my ( $clause, $clause_values ) = $class->build_filtering_clause( |
2965
|
|
|
|
|
|
|
field => $field, |
2966
|
|
|
|
|
|
|
operator => $operator, |
2967
|
|
|
|
|
|
|
values => $values, |
2968
|
|
|
|
|
|
|
); |
2969
|
|
|
|
|
|
|
|
2970
|
|
|
|
|
|
|
=cut |
2971
|
|
|
|
|
|
|
|
2972
|
|
|
|
|
|
|
sub build_filtering_clause |
2973
|
|
|
|
|
|
|
{ |
2974
|
48
|
|
|
48
|
1
|
49105
|
my ( $class, %args ) = @_; |
2975
|
48
|
|
|
|
|
83
|
my $field = $args{'field'}; |
2976
|
48
|
|
|
|
|
72
|
my $operator = $args{'operator'}; |
2977
|
48
|
|
|
|
|
79
|
my $values = $args{'values'}; |
2978
|
|
|
|
|
|
|
|
2979
|
48
|
|
|
|
|
49
|
my $clause; |
2980
|
48
|
|
|
|
|
80
|
my $clause_values = [ $values ]; |
2981
|
|
|
|
|
|
|
|
2982
|
|
|
|
|
|
|
# Quote the field name. |
2983
|
48
|
|
|
|
|
108
|
my $dbh = $class->assert_dbh(); |
2984
|
48
|
|
|
|
|
173
|
my $quoted_field = join( '.', map { $dbh->quote_identifier( $_ ) } split( /\./, $field ) ); |
|
74
|
|
|
|
|
1067
|
|
2985
|
|
|
|
|
|
|
|
2986
|
48
|
50
|
33
|
|
|
1082
|
croak 'A field name is required' |
2987
|
|
|
|
|
|
|
if !defined( $field ) || $field eq ''; |
2988
|
|
|
|
|
|
|
|
2989
|
|
|
|
|
|
|
# Between is a special case where values are an arrayref of a specific size. |
2990
|
48
|
100
|
|
|
|
331
|
if ( $operator eq 'between' ) ## no critic (ControlStructures::ProhibitCascadingIfElse) |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
2991
|
|
|
|
|
|
|
{ |
2992
|
2
|
100
|
66
|
|
|
8
|
unless ( defined( $values ) && Data::Validate::Type::is_arrayref( $values ) && scalar( @$values ) == 2 ) |
|
|
|
66
|
|
|
|
|
2993
|
|
|
|
|
|
|
{ |
2994
|
1
|
|
|
|
|
34
|
croak '>between< requires two values to be passed as an arrayref'; |
2995
|
|
|
|
|
|
|
} |
2996
|
|
|
|
|
|
|
|
2997
|
1
|
|
|
|
|
27
|
$clause = "$quoted_field BETWEEN ? AND ?"; |
2998
|
1
|
|
|
|
|
1
|
$clause_values = $values; |
2999
|
|
|
|
|
|
|
} |
3000
|
|
|
|
|
|
|
# 'null' is also a special case with no values. |
3001
|
|
|
|
|
|
|
elsif ( $operator eq 'null' ) |
3002
|
|
|
|
|
|
|
{ |
3003
|
2
|
|
|
|
|
3
|
$clause = "$quoted_field IS NULL"; |
3004
|
2
|
|
|
|
|
3
|
$clause_values = []; |
3005
|
|
|
|
|
|
|
} |
3006
|
|
|
|
|
|
|
# 'not_null' is also a special case with no values. |
3007
|
|
|
|
|
|
|
elsif ( $operator eq 'not_null' ) |
3008
|
|
|
|
|
|
|
{ |
3009
|
2
|
|
|
|
|
3
|
$clause = "$quoted_field IS NOT NULL"; |
3010
|
2
|
|
|
|
|
4
|
$clause_values = []; |
3011
|
|
|
|
|
|
|
} |
3012
|
|
|
|
|
|
|
# More than one value passed. |
3013
|
|
|
|
|
|
|
elsif ( Data::Validate::Type::is_arrayref( $values ) ) |
3014
|
|
|
|
|
|
|
{ |
3015
|
35
|
100
|
100
|
|
|
698
|
if ( $operator eq '=' ) ## no critic (ControlStructures::ProhibitCascadingIfElse) |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3016
|
|
|
|
|
|
|
{ |
3017
|
25
|
|
|
|
|
140
|
$clause = "$quoted_field IN (" . join( ', ', ( ( '?' ) x scalar( @$values ) ) ) . ")"; |
3018
|
25
|
|
|
|
|
42
|
$clause_values = $values; |
3019
|
|
|
|
|
|
|
} |
3020
|
|
|
|
|
|
|
elsif ( $operator eq 'not' ) |
3021
|
|
|
|
|
|
|
{ |
3022
|
2
|
|
|
|
|
12
|
$clause = "$quoted_field NOT IN (" . join( ', ', ( ( '?' ) x scalar( @$values ) ) ) . ")"; |
3023
|
2
|
|
|
|
|
4
|
$clause_values = $values; |
3024
|
|
|
|
|
|
|
} |
3025
|
|
|
|
|
|
|
elsif ( $operator eq '>' || $operator eq '>=' ) |
3026
|
|
|
|
|
|
|
{ |
3027
|
|
|
|
|
|
|
|
3028
|
|
|
|
|
|
|
# List::Util::max() really hates undefined elements and will warn |
3029
|
|
|
|
|
|
|
# loudly at each one it encounters. So, grep them out first. |
3030
|
2
|
|
|
|
|
5
|
my $max = List::Util::max( grep { defined( $_ ) } @$values ); |
|
4
|
|
|
|
|
10
|
|
3031
|
2
|
50
|
|
|
|
6
|
if ( defined( $max ) ) |
3032
|
|
|
|
|
|
|
{ |
3033
|
2
|
|
|
|
|
4
|
$clause = "$quoted_field $operator ?"; |
3034
|
2
|
|
|
|
|
4
|
$clause_values = [ $max ]; |
3035
|
|
|
|
|
|
|
} |
3036
|
|
|
|
|
|
|
else |
3037
|
|
|
|
|
|
|
{ |
3038
|
0
|
|
|
|
|
0
|
croak 'Could not find max of the following list: ' . dumper( $values ); |
3039
|
|
|
|
|
|
|
} |
3040
|
|
|
|
|
|
|
} |
3041
|
|
|
|
|
|
|
elsif ( $operator eq '<' || $operator eq '<=' ) |
3042
|
|
|
|
|
|
|
{ |
3043
|
|
|
|
|
|
|
# List::Util::max() really hates undefined elements and will warn |
3044
|
|
|
|
|
|
|
# loudly at each one it encounters. So, grep them out first. |
3045
|
2
|
|
|
|
|
4
|
my $min = List::Util::min( grep { defined( $_ ) } @$values ); |
|
4
|
|
|
|
|
10
|
|
3046
|
2
|
50
|
|
|
|
3
|
if ( defined( $min ) ) |
3047
|
|
|
|
|
|
|
{ |
3048
|
2
|
|
|
|
|
6
|
$clause = "$quoted_field $operator ?"; |
3049
|
2
|
|
|
|
|
5
|
$clause_values = [ $min ]; |
3050
|
|
|
|
|
|
|
} |
3051
|
|
|
|
|
|
|
else |
3052
|
|
|
|
|
|
|
{ |
3053
|
0
|
|
|
|
|
0
|
croak 'Could not find min of the following list: ' . dumper( $values ); |
3054
|
|
|
|
|
|
|
} |
3055
|
|
|
|
|
|
|
} |
3056
|
|
|
|
|
|
|
elsif ( $operator eq 'like' ) |
3057
|
|
|
|
|
|
|
{ |
3058
|
|
|
|
|
|
|
# Permit more than one like clause on the same field. |
3059
|
2
|
|
|
|
|
4
|
$clause = "$quoted_field LIKE ? OR " x scalar @{ $values }; |
|
2
|
|
|
|
|
7
|
|
3060
|
2
|
|
|
|
|
4
|
$clause = substr( $clause, 0, -4 ); |
3061
|
2
|
|
|
|
|
5
|
$clause_values = $values; |
3062
|
|
|
|
|
|
|
} |
3063
|
|
|
|
|
|
|
elsif ( $operator eq 'not_like' ) |
3064
|
|
|
|
|
|
|
{ |
3065
|
|
|
|
|
|
|
# Permit more than one like clause on the same field. |
3066
|
2
|
|
|
|
|
5
|
$clause = "$quoted_field NOT LIKE ? AND " x scalar @{ $values }; |
|
2
|
|
|
|
|
6
|
|
3067
|
2
|
|
|
|
|
5
|
$clause = substr( $clause, 0, -5 ); |
3068
|
2
|
|
|
|
|
3
|
$clause_values = $values; |
3069
|
|
|
|
|
|
|
} |
3070
|
|
|
|
|
|
|
# Only one value passed. |
3071
|
|
|
|
|
|
|
else |
3072
|
|
|
|
|
|
|
{ |
3073
|
0
|
|
|
|
|
0
|
croak "The operator '$operator' is not implemented"; |
3074
|
|
|
|
|
|
|
} |
3075
|
|
|
|
|
|
|
} |
3076
|
|
|
|
|
|
|
else |
3077
|
|
|
|
|
|
|
{ |
3078
|
7
|
100
|
|
|
|
80
|
$operator = '!=' |
3079
|
|
|
|
|
|
|
if $operator eq 'not'; |
3080
|
|
|
|
|
|
|
|
3081
|
7
|
|
|
|
|
17
|
$clause = "$quoted_field $operator ?"; |
3082
|
|
|
|
|
|
|
} |
3083
|
|
|
|
|
|
|
|
3084
|
47
|
|
|
|
|
211
|
return ( $clause, $clause_values ); |
3085
|
|
|
|
|
|
|
} |
3086
|
|
|
|
|
|
|
|
3087
|
|
|
|
|
|
|
|
3088
|
|
|
|
|
|
|
=head2 parse_filtering_criteria() |
3089
|
|
|
|
|
|
|
|
3090
|
|
|
|
|
|
|
Helper function that takes a list of fields and converts them into where |
3091
|
|
|
|
|
|
|
clauses and values that can be used by retrieve_list(). |
3092
|
|
|
|
|
|
|
|
3093
|
|
|
|
|
|
|
my ( $where_clauses, $where_values, $filtering_field_keys_passed ) = |
3094
|
|
|
|
|
|
|
@{ |
3095
|
|
|
|
|
|
|
$class->parse_filtering_criteria( |
3096
|
|
|
|
|
|
|
\%filtering_criteria |
3097
|
|
|
|
|
|
|
) |
3098
|
|
|
|
|
|
|
}; |
3099
|
|
|
|
|
|
|
|
3100
|
|
|
|
|
|
|
$filtering_field_keys_passed indicates whether %values had keys matching at |
3101
|
|
|
|
|
|
|
least one element of @field. This allows detecting whether any filtering |
3102
|
|
|
|
|
|
|
criteria was passed, even if the filtering criteria do not result in WHERE |
3103
|
|
|
|
|
|
|
clauses being returned. |
3104
|
|
|
|
|
|
|
|
3105
|
|
|
|
|
|
|
=cut |
3106
|
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
|
sub parse_filtering_criteria |
3108
|
|
|
|
|
|
|
{ |
3109
|
35
|
|
|
35
|
1
|
21477
|
my ( $class, $filters ) = @_; |
3110
|
|
|
|
|
|
|
|
3111
|
|
|
|
|
|
|
# Check the arguments. |
3112
|
35
|
100
|
|
|
|
232
|
if ( !Data::Validate::Type::is_hashref( $filters ) ) |
3113
|
|
|
|
|
|
|
{ |
3114
|
2
|
|
|
|
|
23
|
my $error = "The first argument must be a hashref of filtering criteria"; |
3115
|
2
|
|
|
|
|
9
|
$log->error( $error ); |
3116
|
2
|
|
|
|
|
25
|
croak $error; |
3117
|
|
|
|
|
|
|
}; |
3118
|
|
|
|
|
|
|
|
3119
|
|
|
|
|
|
|
# Build the list of filtering fields we allow. |
3120
|
|
|
|
|
|
|
my $filtering_fields = |
3121
|
|
|
|
|
|
|
{ |
3122
|
30
|
|
|
|
|
68
|
map { $_ => 1 } |
3123
|
33
|
50
|
|
|
|
511
|
@{ $class->get_filtering_fields() || [] } |
|
33
|
|
|
|
|
178
|
|
3124
|
|
|
|
|
|
|
}; |
3125
|
|
|
|
|
|
|
|
3126
|
33
|
|
|
|
|
98
|
my $primary_key_name = $class->get_info('primary_key_name'); |
3127
|
33
|
50
|
|
|
|
107
|
if ( defined( $primary_key_name ) ) |
3128
|
|
|
|
|
|
|
{ |
3129
|
|
|
|
|
|
|
# If there's a primary key name, allow 'id' as an alias. |
3130
|
33
|
|
|
|
|
74
|
$filtering_fields->{'id'} = 1; |
3131
|
|
|
|
|
|
|
} |
3132
|
|
|
|
|
|
|
|
3133
|
|
|
|
|
|
|
# Check if we were passed filters we don't know how to handle. This will |
3134
|
|
|
|
|
|
|
# help the calling code to detect typos or missing filtering fields in the |
3135
|
|
|
|
|
|
|
# static class declaration. |
3136
|
33
|
|
|
|
|
107
|
foreach my $filter ( keys %$filters ) |
3137
|
|
|
|
|
|
|
{ |
3138
|
30
|
100
|
|
|
|
118
|
next if defined( $filtering_fields->{ $filter } ); |
3139
|
|
|
|
|
|
|
|
3140
|
1
|
|
|
|
|
24
|
croak( |
3141
|
|
|
|
|
|
|
"The filtering criteria '$filter' passed to DBIx::NinjaORM->retrieve_list() " . |
3142
|
|
|
|
|
|
|
"via ${class}->retrieve_list() is not handled by the superclass. It could " . |
3143
|
|
|
|
|
|
|
"mean that you have a typo in the name, or that you need to add it to " . |
3144
|
|
|
|
|
|
|
"the list of filtering fields in ${class}->static_class_info()." |
3145
|
|
|
|
|
|
|
); |
3146
|
|
|
|
|
|
|
} |
3147
|
|
|
|
|
|
|
|
3148
|
|
|
|
|
|
|
# Find the table name to prefix it to the field names when we create where |
3149
|
|
|
|
|
|
|
# clauses. |
3150
|
32
|
|
|
|
|
77
|
my $table_name = $class->get_info('table_name'); |
3151
|
32
|
50
|
0
|
|
|
97
|
croak "No table name found for the class >" . ( ref( $class ) || $class ) . "<" |
3152
|
|
|
|
|
|
|
if !defined( $table_name ); |
3153
|
|
|
|
|
|
|
|
3154
|
32
|
|
|
|
|
59
|
my $where_clauses = []; |
3155
|
32
|
|
|
|
|
59
|
my $where_values = []; |
3156
|
32
|
|
|
|
|
46
|
my $filtering_field_keys_passed = 0; |
3157
|
32
|
|
|
|
|
101
|
foreach my $field ( sort keys %$filters ) |
3158
|
|
|
|
|
|
|
{ |
3159
|
|
|
|
|
|
|
# "field => undef" and "field => []" are not valid filtering |
3160
|
|
|
|
|
|
|
# criteria. This prevents programming errors, by forcing the |
3161
|
|
|
|
|
|
|
# use of the 'null' operator when you explicitely want to |
3162
|
|
|
|
|
|
|
# test for NULL. See: |
3163
|
|
|
|
|
|
|
# |
3164
|
|
|
|
|
|
|
# field => |
3165
|
|
|
|
|
|
|
# { |
3166
|
|
|
|
|
|
|
# operator => 'null', |
3167
|
|
|
|
|
|
|
# } |
3168
|
|
|
|
|
|
|
# |
3169
|
29
|
100
|
|
|
|
131
|
next unless defined( $filters->{ $field } ); |
3170
|
|
|
|
|
|
|
next if Data::Validate::Type::is_arrayref( $filters->{ $field } ) |
3171
|
28
|
100
|
100
|
|
|
114
|
&& scalar( @{ $filters->{ $field } } ) == 0; |
|
8
|
|
|
|
|
187
|
|
3172
|
|
|
|
|
|
|
|
3173
|
|
|
|
|
|
|
# We now have a valid filtering criteria. |
3174
|
27
|
|
|
|
|
396
|
$filtering_field_keys_passed = 1; |
3175
|
|
|
|
|
|
|
|
3176
|
|
|
|
|
|
|
# Add the table prefix if needed, this will prevent conflicts if the |
3177
|
|
|
|
|
|
|
# main query performs JOINs. |
3178
|
27
|
50
|
66
|
|
|
250
|
my $full_field_name = defined( $primary_key_name ) && ( $field eq 'id' ) |
|
|
100
|
|
|
|
|
|
3179
|
|
|
|
|
|
|
? $table_name . '.' . $primary_key_name |
3180
|
|
|
|
|
|
|
: $field =~ m/\./ |
3181
|
|
|
|
|
|
|
? $field |
3182
|
|
|
|
|
|
|
: $table_name . '.' . $field; |
3183
|
|
|
|
|
|
|
|
3184
|
|
|
|
|
|
|
# Turn the value into an array of values, if needed. |
3185
|
|
|
|
|
|
|
my $values = Data::Validate::Type::is_arrayref( $filters->{ $field } ) |
3186
|
|
|
|
|
|
|
? $filters->{ $field } |
3187
|
27
|
100
|
|
|
|
86
|
: [ $filters->{ $field } ]; |
3188
|
|
|
|
|
|
|
|
3189
|
27
|
|
|
|
|
381
|
my @scalar_values = (); |
3190
|
27
|
|
|
|
|
77
|
foreach my $block ( @$values ) |
3191
|
|
|
|
|
|
|
{ |
3192
|
86
|
100
|
|
|
|
156
|
if ( Data::Validate::Type::is_hashref( $block ) ) |
3193
|
|
|
|
|
|
|
{ |
3194
|
3
|
50
|
33
|
|
|
53
|
if ( !defined( $block->{'operator'} ) ) |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3195
|
|
|
|
|
|
|
{ |
3196
|
0
|
|
|
|
|
0
|
croak 'The operator is missing or not defined'; |
3197
|
|
|
|
|
|
|
} |
3198
|
|
|
|
|
|
|
elsif ( $block->{'operator'} !~ m/^(?:=|not|<=|>=|<|>|between|null|not_null|like|not_like)$/x ) |
3199
|
|
|
|
|
|
|
{ |
3200
|
1
|
|
|
|
|
19
|
croak "The operator '$block->{'operator'}' is not a valid one. Try (=|not|<=|>=|<|>)"; |
3201
|
|
|
|
|
|
|
} |
3202
|
|
|
|
|
|
|
elsif ( !exists( $block->{'value'} ) && $block->{'operator'} !~ /^(?:null|not_null)$/ ) |
3203
|
|
|
|
|
|
|
{ |
3204
|
0
|
|
|
|
|
0
|
croak "The value key is missing for operator '$block->{'operator'}'"; |
3205
|
|
|
|
|
|
|
} |
3206
|
|
|
|
|
|
|
|
3207
|
|
|
|
|
|
|
my ( $clause, $clause_values ) = $class->build_filtering_clause( |
3208
|
|
|
|
|
|
|
field => $full_field_name, |
3209
|
|
|
|
|
|
|
operator => $block->{'operator'}, |
3210
|
2
|
|
|
|
|
6
|
values => $block->{'value'}, |
3211
|
|
|
|
|
|
|
); |
3212
|
2
|
|
|
|
|
3
|
push( @$where_clauses, $clause ); |
3213
|
2
|
|
|
|
|
4
|
push( @$where_values, $clause_values ); |
3214
|
|
|
|
|
|
|
} |
3215
|
|
|
|
|
|
|
else |
3216
|
|
|
|
|
|
|
{ |
3217
|
83
|
|
|
|
|
578
|
push( @scalar_values, $block ); |
3218
|
|
|
|
|
|
|
} |
3219
|
|
|
|
|
|
|
} |
3220
|
|
|
|
|
|
|
|
3221
|
26
|
100
|
|
|
|
93
|
if ( scalar( @scalar_values ) != 0 ) |
3222
|
|
|
|
|
|
|
{ |
3223
|
24
|
|
|
|
|
156
|
my ( $clause, $clause_values ) = $class->build_filtering_clause( |
3224
|
|
|
|
|
|
|
field => $full_field_name, |
3225
|
|
|
|
|
|
|
operator => '=', |
3226
|
|
|
|
|
|
|
values => \@scalar_values, |
3227
|
|
|
|
|
|
|
); |
3228
|
24
|
|
|
|
|
67
|
push( @$where_clauses, $clause ); |
3229
|
24
|
|
|
|
|
134
|
push( @$where_values, $clause_values ); |
3230
|
|
|
|
|
|
|
} |
3231
|
|
|
|
|
|
|
} |
3232
|
|
|
|
|
|
|
|
3233
|
31
|
|
|
|
|
130
|
return [ $where_clauses, $where_values, $filtering_field_keys_passed ]; |
3234
|
|
|
|
|
|
|
} |
3235
|
|
|
|
|
|
|
|
3236
|
|
|
|
|
|
|
|
3237
|
|
|
|
|
|
|
=head2 reorganize_non_native_fields() |
3238
|
|
|
|
|
|
|
|
3239
|
|
|
|
|
|
|
When we retrieve fields via SELECT in retrieve_list_nocache(), by convention we use |
3240
|
|
|
|
|
|
|
_[table_name]_[field_name] for fields that are not native to the underlying |
3241
|
|
|
|
|
|
|
table that the object represents. |
3242
|
|
|
|
|
|
|
|
3243
|
|
|
|
|
|
|
This method moves them to $object->{'_table_name'}->{'field_name'} for a |
3244
|
|
|
|
|
|
|
cleaner organization inside the object. |
3245
|
|
|
|
|
|
|
|
3246
|
|
|
|
|
|
|
$object->reorganize_non_native_fields(); |
3247
|
|
|
|
|
|
|
|
3248
|
|
|
|
|
|
|
=cut |
3249
|
|
|
|
|
|
|
|
3250
|
|
|
|
|
|
|
sub reorganize_non_native_fields |
3251
|
|
|
|
|
|
|
{ |
3252
|
85
|
|
|
85
|
1
|
331
|
my ( $self ) = @_; |
3253
|
|
|
|
|
|
|
|
3254
|
|
|
|
|
|
|
# Move non-native fields to their own happy place. |
3255
|
85
|
|
|
|
|
254
|
foreach my $field ( keys %$self ) |
3256
|
|
|
|
|
|
|
{ |
3257
|
502
|
100
|
|
|
|
872
|
next unless $field =~ m/^(_[^_]+)_(.*)$/; |
3258
|
4
|
|
|
|
|
26
|
$self->{ $1 }->{ $2 } = $self->{ $field }; |
3259
|
4
|
|
|
|
|
11
|
delete( $self->{ $field } ); |
3260
|
|
|
|
|
|
|
} |
3261
|
|
|
|
|
|
|
|
3262
|
85
|
|
|
|
|
141
|
return; |
3263
|
|
|
|
|
|
|
} |
3264
|
|
|
|
|
|
|
|
3265
|
|
|
|
|
|
|
|
3266
|
|
|
|
|
|
|
=head1 BUGS |
3267
|
|
|
|
|
|
|
|
3268
|
|
|
|
|
|
|
Please report any bugs or feature requests through the web interface at |
3269
|
|
|
|
|
|
|
L. |
3270
|
|
|
|
|
|
|
I will be notified, and then you'll automatically be notified of progress on |
3271
|
|
|
|
|
|
|
your bug as I make changes. |
3272
|
|
|
|
|
|
|
|
3273
|
|
|
|
|
|
|
|
3274
|
|
|
|
|
|
|
=head1 SUPPORT |
3275
|
|
|
|
|
|
|
|
3276
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
3277
|
|
|
|
|
|
|
|
3278
|
|
|
|
|
|
|
perldoc DBIx::NinjaORM |
3279
|
|
|
|
|
|
|
|
3280
|
|
|
|
|
|
|
|
3281
|
|
|
|
|
|
|
You can also look for information at: |
3282
|
|
|
|
|
|
|
|
3283
|
|
|
|
|
|
|
=over 4 |
3284
|
|
|
|
|
|
|
|
3285
|
|
|
|
|
|
|
=item * GitHub's request tracker |
3286
|
|
|
|
|
|
|
|
3287
|
|
|
|
|
|
|
L |
3288
|
|
|
|
|
|
|
|
3289
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
3290
|
|
|
|
|
|
|
|
3291
|
|
|
|
|
|
|
L |
3292
|
|
|
|
|
|
|
|
3293
|
|
|
|
|
|
|
=item * CPAN Ratings |
3294
|
|
|
|
|
|
|
|
3295
|
|
|
|
|
|
|
L |
3296
|
|
|
|
|
|
|
|
3297
|
|
|
|
|
|
|
=item * MetaCPAN |
3298
|
|
|
|
|
|
|
|
3299
|
|
|
|
|
|
|
L |
3300
|
|
|
|
|
|
|
|
3301
|
|
|
|
|
|
|
=back |
3302
|
|
|
|
|
|
|
|
3303
|
|
|
|
|
|
|
|
3304
|
|
|
|
|
|
|
=head1 AUTHOR |
3305
|
|
|
|
|
|
|
|
3306
|
|
|
|
|
|
|
L, C<< >>. |
3307
|
|
|
|
|
|
|
|
3308
|
|
|
|
|
|
|
|
3309
|
|
|
|
|
|
|
=head1 CONTRIBUTORS |
3310
|
|
|
|
|
|
|
|
3311
|
|
|
|
|
|
|
=over 4 |
3312
|
|
|
|
|
|
|
|
3313
|
|
|
|
|
|
|
=item * L |
3314
|
|
|
|
|
|
|
|
3315
|
|
|
|
|
|
|
=item * Jamie McCarthy |
3316
|
|
|
|
|
|
|
|
3317
|
|
|
|
|
|
|
=item * L |
3318
|
|
|
|
|
|
|
|
3319
|
|
|
|
|
|
|
=item * L |
3320
|
|
|
|
|
|
|
|
3321
|
|
|
|
|
|
|
=back |
3322
|
|
|
|
|
|
|
|
3323
|
|
|
|
|
|
|
|
3324
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
3325
|
|
|
|
|
|
|
|
3326
|
|
|
|
|
|
|
I originally developed this project for ThinkGeek |
3327
|
|
|
|
|
|
|
(L). Thanks for allowing me to open-source it! |
3328
|
|
|
|
|
|
|
|
3329
|
|
|
|
|
|
|
Special thanks to Kate Kirby for her help with the design of this module. |
3330
|
|
|
|
|
|
|
|
3331
|
|
|
|
|
|
|
|
3332
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
3333
|
|
|
|
|
|
|
|
3334
|
|
|
|
|
|
|
Copyright 2009-2017 Guillaume Aubert. |
3335
|
|
|
|
|
|
|
|
3336
|
|
|
|
|
|
|
This code is free software; you can redistribute it and/or modify it under the |
3337
|
|
|
|
|
|
|
same terms as Perl 5 itself. |
3338
|
|
|
|
|
|
|
|
3339
|
|
|
|
|
|
|
This program is distributed in the hope that it will be useful, but WITHOUT ANY |
3340
|
|
|
|
|
|
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A |
3341
|
|
|
|
|
|
|
PARTICULAR PURPOSE. See the LICENSE file for more details. |
3342
|
|
|
|
|
|
|
|
3343
|
|
|
|
|
|
|
=cut |
3344
|
|
|
|
|
|
|
|
3345
|
|
|
|
|
|
|
1; |