Bug 23432: (QA follow-up) Add a unit test
[koha.git] / Koha / Objects.pm
blob3ea4727048875e7923d5b3483d4cbbfb327ed80f
1 package Koha::Objects;
3 # Copyright ByWater Solutions 2014
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
20 use Modern::Perl;
22 use Carp;
23 use List::MoreUtils qw( none );
24 use Class::Inspector;
26 use Koha::Database;
27 use Koha::Exceptions::Object;
28 use Koha::DateUtils qw( dt_from_string );
30 =head1 NAME
32 Koha::Objects - Koha Object set base class
34 =head1 SYNOPSIS
36 use Koha::Objects;
37 my @objects = Koha::Objects->search({ borrowernumber => $borrowernumber});
39 =head1 DESCRIPTION
41 This class must be subclassed.
43 =head1 API
45 =head2 Class Methods
47 =cut
49 =head3 Koha::Objects->new();
51 my $object = Koha::Objects->new();
53 =cut
55 sub new {
56 my ($class) = @_;
57 my $self = {};
59 bless( $self, $class );
62 =head3 Koha::Objects->_new_from_dbic();
64 my $object = Koha::Objects->_new_from_dbic( $resultset );
66 =cut
68 sub _new_from_dbic {
69 my ( $class, $resultset ) = @_;
70 my $self = { _resultset => $resultset };
72 bless( $self, $class );
75 =head3 Koha::Objects->find();
77 Similar to DBIx::Class::ResultSet->find this method accepts:
78 \%columns_values | @pk_values, { key => $unique_constraint, %attrs }?
79 Strictly speaking, columns_values should only refer to columns under an
80 unique constraint.
82 It returns undef if no results were found
84 my $object = Koha::Objects->find( { col1 => $val1, col2 => $val2 } );
85 my $object = Koha::Objects->find( $id );
86 my $object = Koha::Objects->find( $idpart1, $idpart2, $attrs ); # composite PK
88 =cut
90 sub find {
91 my ( $self, @pars ) = @_;
93 my $object;
95 unless (!@pars || none { defined($_) } @pars) {
96 my $result = $self->_resultset()->find(@pars);
97 if ($result) {
98 $object = $self->object_class()->_new_from_dbic($result);
102 return $object;
105 =head3 Koha::Objects->find_or_create();
107 my $object = Koha::Objects->find_or_create( $attrs );
109 =cut
111 sub find_or_create {
112 my ( $self, $params ) = @_;
114 my $result = $self->_resultset->find_or_create($params);
116 return unless $result;
118 my $object = $self->object_class->_new_from_dbic($result);
120 return $object;
123 =head3 search
125 # list context
126 my @objects = Koha::Objects->search([$params, $attributes]);
127 # scalar context
128 my $objects = Koha::Objects->search([$params, $attributes]);
129 while (my $object = $objects->next) {
130 do_stuff($object);
133 This B<instantiates> the I<Koha::Objects> class, and generates a resultset
134 based on the query I<$params> and I<$attributes> that are passed (like in DBIC).
136 In B<list context> it returns an array of I<Koha::Object> objects.
137 In B<scalar context> it returns an iterator.
139 =cut
141 sub search {
142 my ( $self, $params, $attributes ) = @_;
144 if (wantarray) {
145 my @dbic_rows = $self->_resultset()->search($params, $attributes);
147 return $self->_wrap(@dbic_rows);
150 else {
151 my $class = ref($self) ? ref($self) : $self;
152 my $rs = $self->_resultset()->search($params, $attributes);
154 return $class->_new_from_dbic($rs);
158 =head3 search_related
160 my @objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
161 my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
163 Searches the specified relationship, optionally specifying a condition and attributes for matching records.
165 =cut
167 sub search_related {
168 my ( $self, $rel_name, @params ) = @_;
170 return if !$rel_name;
171 if (wantarray) {
172 my @dbic_rows = $self->_resultset()->search_related($rel_name, @params);
173 return if !@dbic_rows;
174 my $object_class = _get_objects_class( $dbic_rows[0]->result_class );
176 eval "require $object_class";
177 return _wrap( $object_class, @dbic_rows );
179 } else {
180 my $rs = $self->_resultset()->search_related($rel_name, @params);
181 return if !$rs;
182 my $object_class = _get_objects_class( $rs->result_class );
184 eval "require $object_class";
185 return _new_from_dbic( $object_class, $rs );
189 =head3 delete
191 =cut
193 sub delete {
194 my ($self) = @_;
196 if ( Class::Inspector->function_exists( $self->object_class, 'delete' ) ) {
197 my $objects_deleted;
198 $self->_resultset->result_source->schema->txn_do( sub {
199 $self->reset; # If we iterated already over the set
200 while ( my $o = $self->next ) {
201 $o->delete;
202 $objects_deleted++;
205 return $objects_deleted;
208 return $self->_resultset->delete;
211 =head3 update
213 my $objects = Koha::Objects->new; # or Koha::Objects->search
214 $objects->update( $fields, [ { no_triggers => 0/1 } ] );
216 This method overloads the DBIC inherited one so if code-level triggers exist
217 (through the use of an overloaded I<update> or I<store> method in the Koha::Object
218 based class) those are called in a loop on the resultset.
220 If B<no_triggers> is passed and I<true>, then the DBIC update method is called
221 directly. This feature is important for performance, in cases where no code-level
222 triggers should be triggered. The developer will explicitly ask for this and QA should
223 catch wrong uses as well.
225 =cut
227 sub update {
228 my ($self, $fields, $options) = @_;
230 Koha::Exceptions::Object::NotInstantiated->throw(
231 method => 'update',
232 class => $self
233 ) unless ref $self;
235 my $no_triggers = $options->{no_triggers};
237 if (
238 !$no_triggers
239 && ( Class::Inspector->function_exists( $self->object_class, 'update' )
240 or Class::Inspector->function_exists( $self->object_class, 'store' ) )
243 my $objects_updated;
244 $self->_resultset->result_source->schema->txn_do( sub {
245 while ( my $o = $self->next ) {
246 $o->update($fields);
247 $objects_updated++;
250 return $objects_updated;
253 return $self->_resultset->update($fields);
256 =head3 filter_by_last_update
258 my $filtered_objects = $objects->filter_by_last_update
260 days exclusive
261 from inclusive
262 to inclusive
264 =cut
266 sub filter_by_last_update {
267 my ( $self, $params ) = @_;
268 my $timestamp_column_name = $params->{timestamp_column_name} || 'timestamp';
269 my $conditions;
270 Koha::Exceptions::MissingParameter->throw(
271 "Missing mandatory parameter: days or from or to")
272 unless exists $params->{days}
273 or exists $params->{from}
274 or exists $params->{to};
276 my $dtf = Koha::Database->new->schema->storage->datetime_parser;
277 if ( exists $params->{days} ) {
278 $conditions->{'<'} = $dtf->format_date( dt_from_string->subtract( days => $params->{days} ) );
280 if ( exists $params->{from} ) {
281 my $from = ref($params->{from}) ? $params->{from} : dt_from_string($params->{from});
282 $conditions->{'>='} = $dtf->format_date( $from );
284 if ( exists $params->{to} ) {
285 my $to = ref($params->{to}) ? $params->{to} : dt_from_string($params->{to});
286 $conditions->{'<='} = $dtf->format_date( $to );
289 return $self->_resultset->search(
291 $timestamp_column_name => $conditions
296 =head3 single
298 my $object = Koha::Objects->search({}, { rows => 1 })->single
300 Returns one and only one object that is part of this set.
301 Returns undef if there are no objects found.
303 This is optimal as it will grab the first returned result without instantiating
304 a cursor.
306 See:
307 http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod#Retrieve_one_and_only_one_row_from_a_resultset
309 =cut
311 sub single {
312 my ($self) = @_;
314 my $single = $self->_resultset()->single;
315 return unless $single;
317 return $self->object_class()->_new_from_dbic($single);
320 =head3 Koha::Objects->next();
322 my $object = Koha::Objects->next();
324 Returns the next object that is part of this set.
325 Returns undef if there are no more objects to return.
327 =cut
329 sub next {
330 my ( $self ) = @_;
332 my $result = $self->_resultset()->next();
333 return unless $result;
335 my $object = $self->object_class()->_new_from_dbic( $result );
337 return $object;
340 =head3 Koha::Objects->last;
342 my $object = Koha::Objects->last;
344 Returns the last object that is part of this set.
345 Returns undef if there are no object to return.
347 =cut
349 sub last {
350 my ( $self ) = @_;
352 my $count = $self->_resultset->count;
353 return unless $count;
355 my ( $result ) = $self->_resultset->slice($count - 1, $count - 1);
357 my $object = $self->object_class()->_new_from_dbic( $result );
359 return $object;
362 =head3 empty
364 my $empty_rs = Koha::Objects->new->empty;
366 Sets the resultset empty. This is handy for consistency on method returns
367 (e.g. if we know in advance we won't have results but want to keep returning
368 an iterator).
370 =cut
372 sub empty {
373 my ($self) = @_;
375 Koha::Exceptions::Object::NotInstantiated->throw(
376 method => 'empty',
377 class => $self
378 ) unless ref $self;
380 $self->_resultset()->set_cache([]);
382 return $self;
385 =head3 Koha::Objects->reset();
387 Koha::Objects->reset();
389 resets iteration so the next call to next() will start agein
390 with the first object in a set.
392 =cut
394 sub reset {
395 my ( $self ) = @_;
397 $self->_resultset()->reset();
399 return $self;
402 =head3 Koha::Objects->as_list();
404 Koha::Objects->as_list();
406 Returns an arrayref of the objects in this set.
408 =cut
410 sub as_list {
411 my ( $self ) = @_;
413 my @dbic_rows = $self->_resultset()->all();
415 my @objects = $self->_wrap(@dbic_rows);
417 return wantarray ? @objects : \@objects;
420 =head3 Koha::Objects->unblessed
422 Returns an unblessed representation of objects.
424 =cut
426 sub unblessed {
427 my ($self) = @_;
429 return [ map { $_->unblessed } $self->as_list ];
432 =head3 Koha::Objects->get_column
434 Return all the values of this set for a given column
436 =cut
438 sub get_column {
439 my ($self, $column_name) = @_;
440 return $self->_resultset->get_column( $column_name )->all;
443 =head3 Koha::Objects->TO_JSON
445 Returns an unblessed representation of objects, suitable for JSON output.
447 =cut
449 sub TO_JSON {
450 my ($self) = @_;
452 return [ map { $_->TO_JSON } $self->as_list ];
455 =head3 Koha::Objects->to_api
457 Returns a representation of the objects, suitable for API output .
459 =cut
461 sub to_api {
462 my ($self, $params) = @_;
464 return [ map { $_->to_api($params) } $self->as_list ];
467 =head3 attributes_from_api
469 my $attributes = $objects->attributes_from_api( $api_attributes );
471 Translates attributes from the API to DBIC
473 =cut
475 sub attributes_from_api {
476 my ( $self, $attributes ) = @_;
478 $self->{_singular_object} ||= $self->object_class->new();
479 return $self->{_singular_object}->attributes_from_api( $attributes );
482 =head3 from_api_mapping
484 my $mapped_attributes_hash = $objects->from_api_mapping;
486 Attributes map from the API to DBIC
488 =cut
490 sub from_api_mapping {
491 my ( $self ) = @_;
493 $self->{_singular_object} ||= $self->object_class->new();
494 return $self->{_singular_object}->from_api_mapping;
497 =head3 prefetch_whitelist
499 my $whitelist = $object->prefetch_whitelist()
501 Returns a hash of prefetchable subs and the type it returns
503 =cut
505 sub prefetch_whitelist {
506 my ( $self ) = @_;
508 $self->{_singular_object} ||= $self->object_class->new();
510 $self->{_singular_object}->prefetch_whitelist;
513 =head3 Koha::Objects->_wrap
515 wraps the DBIC object in a corresponding Koha object
517 =cut
519 sub _wrap {
520 my ( $self, @dbic_rows ) = @_;
522 my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;
524 return @objects;
527 =head3 Koha::Objects->_resultset
529 Returns the internal resultset or creates it if undefined
531 =cut
533 sub _resultset {
534 my ($self) = @_;
536 if ( ref($self) ) {
537 $self->{_resultset} ||=
538 Koha::Database->new()->schema()->resultset( $self->_type() );
540 return $self->{_resultset};
542 else {
543 return Koha::Database->new()->schema()->resultset( $self->_type() );
547 sub _get_objects_class {
548 my ( $type ) = @_;
549 return unless $type;
551 if( $type->can('koha_objects_class') ) {
552 return $type->koha_objects_class;
554 $type =~ s|Schema::Result::||;
555 return "${type}s";
558 =head3 columns
560 my @columns = Koha::Objects->columns
562 Return the table columns
564 =cut
566 sub columns {
567 my ( $class ) = @_;
568 return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
571 =head3 AUTOLOAD
573 The autoload method is used call DBIx::Class method on a resultset.
575 Important: If you plan to use one of the DBIx::Class methods you must provide
576 relevant tests in t/db_dependent/Koha/Objects.t
577 Currently count, is_paged, pager, result_class, single and slice are covered.
579 =cut
581 sub AUTOLOAD {
582 my ( $self, @params ) = @_;
584 my @known_methods = qw( count is_paged pager result_class single slice );
585 my $method = our $AUTOLOAD;
586 $method =~ s/.*:://;
589 unless ( grep { $_ eq $method } @known_methods ) {
590 my $class = ref($self) ? ref($self) : $self;
591 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
592 error => sprintf("The method %s->%s is not covered by tests!", $class, $method),
593 show_trace => 1
597 my $r = eval { $self->_resultset->$method(@params) };
598 if ( $@ ) {
599 carp "No method $method found for " . ref($self) . " " . $@;
600 return
602 return $r;
605 =head3 _type
607 The _type method must be set for all child classes.
608 The value returned by it should be the DBIC resultset name.
609 For example, for holds, _type should return 'Reserve'.
611 =cut
613 sub _type { }
615 =head3 object_class
617 This method must be set for all child classes.
618 The value returned by it should be the name of the Koha
619 object class that is returned by this class.
620 For example, for holds, object_class should return 'Koha::Hold'.
622 =cut
624 sub object_class { }
626 sub DESTROY { }
628 =head1 AUTHOR
630 Kyle M Hall <kyle@bywatersolutions.com>
632 =cut