Koha/Objects.pm

   1 package Koha::Objects;
   2
   3 # Copyright ByWater Solutions 2014
   4 #
   5 # This file is part of Koha.
   6 #
   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.
  11 #
  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.
  16 #
  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>.
  19
  20 use Modern::Perl;
  21
  22 use Carp;
  23 use List::MoreUtils qw( none );
  24 use Class::Inspector;
  25
  26 use Koha::Database;
  27 use Koha::Exceptions::Object;
  28 use Koha::DateUtils qw( dt_from_string );
  29
  30 =head1 NAME
  31
  32 Koha::Objects - Koha Object set base class
  33
  34 =head1 SYNOPSIS
  35
  36     use Koha::Objects;
  37     my @objects = Koha::Objects->search({ borrowernumber => $borrowernumber});
  38
  39 =head1 DESCRIPTION
  40
  41 This class must be subclassed.
  42
  43 =head1 API
  44
  45 =head2 Class Methods
  46
  47 =cut
  48
  49 =head3 Koha::Objects->new();
  50
  51 my $object = Koha::Objects->new();
  52
  53 =cut
  54
  55 sub new {
  56     my ($class) = @_;
  57     my $self = {};
  58
  59     bless( $self, $class );
  60 }
  61
  62 =head3 Koha::Objects->_new_from_dbic();
  63
  64 my $object = Koha::Objects->_new_from_dbic( $resultset );
  65
  66 =cut
  67
  68 sub _new_from_dbic {
  69     my ( $class, $resultset ) = @_;
  70     my $self = { _resultset => $resultset };
  71
  72     bless( $self, $class );
  73 }
  74
  75 =head3 Koha::Objects->find();
  76
  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.
  81
  82 It returns undef if no results were found
  83
  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
  87
  88 =cut
  89
  90 sub find {
  91     my ( $self, @pars ) = @_;
  92
  93     my $object;
  94
  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);
  99         }
 100     }
 101
 102     return $object;
 103 }
 104
 105 =head3 Koha::Objects->find_or_create();
 106
 107 my $object = Koha::Objects->find_or_create( $attrs );
 108
 109 =cut
 110
 111 sub find_or_create {
 112     my ( $self, $params ) = @_;
 113
 114     my $result = $self->_resultset->find_or_create($params);
 115
 116     return unless $result;
 117
 118     my $object = $self->object_class->_new_from_dbic($result);
 119
 120     return $object;
 121 }
 122
 123 =head3 search
 124
 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);
 131     }
 132
 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).
 135
 136 In B<list context> it returns an array of I<Koha::Object> objects.
 137 In B<scalar context> it returns an iterator.
 138
 139 =cut
 140
 141 sub search {
 142     my ( $self, $params, $attributes ) = @_;
 143
 144     if (wantarray) {
 145         my @dbic_rows = $self->_resultset()->search($params, $attributes);
 146
 147         return $self->_wrap(@dbic_rows);
 148
 149     }
 150     else {
 151         my $class = ref($self) ? ref($self) : $self;
 152         my $rs = $self->_resultset()->search($params, $attributes);
 153
 154         return $class->_new_from_dbic($rs);
 155     }
 156 }
 157
 158 =head3 search_related
 159
 160     my @objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
 161     my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
 162
 163 Searches the specified relationship, optionally specifying a condition and attributes for matching records.
 164
 165 =cut
 166
 167 sub search_related {
 168     my ( $self, $rel_name, @params ) = @_;
 169
 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 );
 175
 176         eval "require $object_class";
 177         return _wrap( $object_class, @dbic_rows );
 178
 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 );
 183
 184         eval "require $object_class";
 185         return _new_from_dbic( $object_class, $rs );
 186     }
 187 }
 188
 189 =head3 delete
 190
 191 =cut
 192
 193 sub delete {
 194     my ($self) = @_;
 195
 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++;
 203             }
 204         });
 205         return $objects_deleted;
 206     }
 207
 208     return $self->_resultset->delete;
 209 }
 210
 211 =head3 update
 212
 213     my $objects = Koha::Objects->new; # or Koha::Objects->search
 214     $objects->update( $fields, [ { no_triggers => 0/1 } ] );
 215
 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.
 219
 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.
 224
 225 =cut
 226
 227 sub update {
 228     my ($self, $fields, $options) = @_;
 229
 230     Koha::Exceptions::Object::NotInstantiated->throw(
 231         method => 'update',
 232         class  => $self
 233     ) unless ref $self;
 234
 235     my $no_triggers = $options->{no_triggers};
 236
 237     if (
 238         !$no_triggers
 239         && ( Class::Inspector->function_exists( $self->object_class, 'update' )
 240           or Class::Inspector->function_exists( $self->object_class, 'store' ) )
 241       )
 242     {
 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++;
 248             }
 249         });
 250         return $objects_updated;
 251     }
 252
 253     return $self->_resultset->update($fields);
 254 }
 255
 256 =head3 filter_by_last_update
 257
 258 my $filtered_objects = $objects->filter_by_last_update
 259
 260 days exclusive
 261 from inclusive
 262 to   inclusive
 263
 264 =cut
 265
 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};
 275
 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} ) );
 279     }
 280     if ( exists $params->{from} ) {
 281         my $from = ref($params->{from}) ? $params->{from} : dt_from_string($params->{from});
 282         $conditions->{'>='} = $dtf->format_date( $from );
 283     }
 284     if ( exists $params->{to} ) {
 285         my $to = ref($params->{to}) ? $params->{to} : dt_from_string($params->{to});
 286         $conditions->{'<='} = $dtf->format_date( $to );
 287     }
 288
 289     return $self->_resultset->search(
 290         {
 291             $timestamp_column_name => $conditions
 292         }
 293     );
 294 }
 295
 296 =head3 single
 297
 298 my $object = Koha::Objects->search({}, { rows => 1 })->single
 299
 300 Returns one and only one object that is part of this set.
 301 Returns undef if there are no objects found.
 302
 303 This is optimal as it will grab the first returned result without instantiating
 304 a cursor.
 305
 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
 308
 309 =cut
 310
 311 sub single {
 312     my ($self) = @_;
 313
 314     my $single = $self->_resultset()->single;
 315     return unless $single;
 316
 317     return $self->object_class()->_new_from_dbic($single);
 318 }
 319
 320 =head3 Koha::Objects->next();
 321
 322 my $object = Koha::Objects->next();
 323
 324 Returns the next object that is part of this set.
 325 Returns undef if there are no more objects to return.
 326
 327 =cut
 328
 329 sub next {
 330     my ( $self ) = @_;
 331
 332     my $result = $self->_resultset()->next();
 333     return unless $result;
 334
 335     my $object = $self->object_class()->_new_from_dbic( $result );
 336
 337     return $object;
 338 }
 339
 340 =head3 Koha::Objects->last;
 341
 342 my $object = Koha::Objects->last;
 343
 344 Returns the last object that is part of this set.
 345 Returns undef if there are no object to return.
 346
 347 =cut
 348
 349 sub last {
 350     my ( $self ) = @_;
 351
 352     my $count = $self->_resultset->count;
 353     return unless $count;
 354
 355     my ( $result ) = $self->_resultset->slice($count - 1, $count - 1);
 356
 357     my $object = $self->object_class()->_new_from_dbic( $result );
 358
 359     return $object;
 360 }
 361
 362 =head3 empty
 363
 364     my $empty_rs = Koha::Objects->new->empty;
 365
 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).
 369
 370 =cut
 371
 372 sub empty {
 373     my ($self) = @_;
 374
 375     Koha::Exceptions::Object::NotInstantiated->throw(
 376         method => 'empty',
 377         class  => $self
 378     ) unless ref $self;
 379
 380     $self->_resultset()->set_cache([]);
 381
 382     return $self;
 383 }
 384
 385 =head3 Koha::Objects->reset();
 386
 387 Koha::Objects->reset();
 388
 389 resets iteration so the next call to next() will start agein
 390 with the first object in a set.
 391
 392 =cut
 393
 394 sub reset {
 395     my ( $self ) = @_;
 396
 397     $self->_resultset()->reset();
 398
 399     return $self;
 400 }
 401
 402 =head3 Koha::Objects->as_list();
 403
 404 Koha::Objects->as_list();
 405
 406 Returns an arrayref of the objects in this set.
 407
 408 =cut
 409
 410 sub as_list {
 411     my ( $self ) = @_;
 412
 413     my @dbic_rows = $self->_resultset()->all();
 414
 415     my @objects = $self->_wrap(@dbic_rows);
 416
 417     return wantarray ? @objects : \@objects;
 418 }
 419
 420 =head3 Koha::Objects->unblessed
 421
 422 Returns an unblessed representation of objects.
 423
 424 =cut
 425
 426 sub unblessed {
 427     my ($self) = @_;
 428
 429     return [ map { $_->unblessed } $self->as_list ];
 430 }
 431
 432 =head3 Koha::Objects->get_column
 433
 434 Return all the values of this set for a given column
 435
 436 =cut
 437
 438 sub get_column {
 439     my ($self, $column_name) = @_;
 440     return $self->_resultset->get_column( $column_name )->all;
 441 }
 442
 443 =head3 Koha::Objects->TO_JSON
 444
 445 Returns an unblessed representation of objects, suitable for JSON output.
 446
 447 =cut
 448
 449 sub TO_JSON {
 450     my ($self) = @_;
 451
 452     return [ map { $_->TO_JSON } $self->as_list ];
 453 }
 454
 455 =head3 Koha::Objects->to_api
 456
 457 Returns a representation of the objects, suitable for API output .
 458
 459 =cut
 460
 461 sub to_api {
 462     my ($self, $params) = @_;
 463
 464     return [ map { $_->to_api($params) } $self->as_list ];
 465 }
 466
 467 =head3 attributes_from_api
 468
 469     my $attributes = $objects->attributes_from_api( $api_attributes );
 470
 471 Translates attributes from the API to DBIC
 472
 473 =cut
 474
 475 sub attributes_from_api {
 476     my ( $self, $attributes ) = @_;
 477
 478     $self->{_singular_object} ||= $self->object_class->new();
 479     return $self->{_singular_object}->attributes_from_api( $attributes );
 480 }
 481
 482 =head3 from_api_mapping
 483
 484     my $mapped_attributes_hash = $objects->from_api_mapping;
 485
 486 Attributes map from the API to DBIC
 487
 488 =cut
 489
 490 sub from_api_mapping {
 491     my ( $self ) = @_;
 492
 493     $self->{_singular_object} ||= $self->object_class->new();
 494     return $self->{_singular_object}->from_api_mapping;
 495 }
 496
 497 =head3 prefetch_whitelist
 498
 499     my $whitelist = $object->prefetch_whitelist()
 500
 501 Returns a hash of prefetchable subs and the type it returns
 502
 503 =cut
 504
 505 sub prefetch_whitelist {
 506     my ( $self ) = @_;
 507
 508     $self->{_singular_object} ||= $self->object_class->new();
 509
 510     $self->{_singular_object}->prefetch_whitelist;
 511 }
 512
 513 =head3 Koha::Objects->_wrap
 514
 515 wraps the DBIC object in a corresponding Koha object
 516
 517 =cut
 518
 519 sub _wrap {
 520     my ( $self, @dbic_rows ) = @_;
 521
 522     my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;
 523
 524     return @objects;
 525 }
 526
 527 =head3 Koha::Objects->_resultset
 528
 529 Returns the internal resultset or creates it if undefined
 530
 531 =cut
 532
 533 sub _resultset {
 534     my ($self) = @_;
 535
 536     if ( ref($self) ) {
 537         $self->{_resultset} ||=
 538           Koha::Database->new()->schema()->resultset( $self->_type() );
 539
 540         return $self->{_resultset};
 541     }
 542     else {
 543         return Koha::Database->new()->schema()->resultset( $self->_type() );
 544     }
 545 }
 546
 547 sub _get_objects_class {
 548     my ( $type ) = @_;
 549     return unless $type;
 550
 551     if( $type->can('koha_objects_class') ) {
 552         return $type->koha_objects_class;
 553     }
 554     $type =~ s|Schema::Result::||;
 555     return "${type}s";
 556 }
 557
 558 =head3 columns
 559
 560 my @columns = Koha::Objects->columns
 561
 562 Return the table columns
 563
 564 =cut
 565
 566 sub columns {
 567     my ( $class ) = @_;
 568     return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
 569 }
 570
 571 =head3 AUTOLOAD
 572
 573 The autoload method is used call DBIx::Class method on a resultset.
 574
 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.
 578
 579 =cut
 580
 581 sub AUTOLOAD {
 582     my ( $self, @params ) = @_;
 583
 584     my @known_methods = qw( count is_paged pager result_class single slice );
 585     my $method = our $AUTOLOAD;
 586     $method =~ s/.*:://;
 587
 588
 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
 594         );
 595     }
 596
 597     my $r = eval { $self->_resultset->$method(@params) };
 598     if ( $@ ) {
 599         carp "No method $method found for " . ref($self) . " " . $@;
 600         return
 601     }
 602     return $r;
 603 }
 604
 605 =head3 _type
 606
 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'.
 610
 611 =cut
 612
 613 sub _type { }
 614
 615 =head3 object_class
 616
 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'.
 621
 622 =cut
 623
 624 sub object_class { }
 625
 626 sub DESTROY { }
 627
 628 =head1 AUTHOR
 629
 630 Kyle M Hall <kyle@bywatersolutions.com>
 631
 632 =cut
 633
 634 1;