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 qw( 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     # scalar context
 126     my $objects = Koha::Objects->search([$params, $attributes]);
 127     while (my $object = $objects->next) {
 128         do_stuff($object);
 129     }
 130
 131 This B<instantiates> the I<Koha::Objects> class, and generates a resultset
 132 based on the query I<$params> and I<$attributes> that are passed (like in DBIC).
 133
 134 =cut
 135
 136 sub search {
 137     my ( $self, $params, $attributes ) = @_;
 138
 139     my $class = ref($self) ? ref($self) : $self;
 140     my $rs = $self->_resultset()->search($params, $attributes);
 141
 142     return $class->_new_from_dbic($rs);
 143 }
 144
 145 =head3 search_limited
 146
 147     my $rs = $self->search_limited
 148
 149 Generic method that is just a pass through for I<search>. It is expected to be overloaded
 150 locally on classes. It's main purpose is to avoid the need to check if the class implements
 151 the method locally.
 152
 153 =cut
 154
 155 sub search_limited {
 156     my ( $self, $params, $attributes ) = @_;
 157     return $self->search( $params, $attributes );
 158 }
 159
 160 =head3 search_related
 161
 162     my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
 163
 164 Searches the specified relationship, optionally specifying a condition and attributes for matching records.
 165
 166 =cut
 167
 168 sub search_related {
 169     my ( $self, $rel_name, @params ) = @_;
 170
 171     return if !$rel_name;
 172
 173     my $rs = $self->_resultset()->search_related($rel_name, @params);
 174     return if !$rs;
 175     my $object_class = _get_objects_class( $rs->result_class );
 176
 177     eval "require $object_class";
 178     return _new_from_dbic( $object_class, $rs );
 179 }
 180
 181 =head3 delete
 182
 183 =cut
 184
 185 sub delete {
 186     my ($self) = @_;
 187
 188     if ( Class::Inspector->function_exists( $self->object_class, 'delete' ) ) {
 189         my $objects_deleted;
 190         $self->_resultset->result_source->schema->txn_do( sub {
 191             $self->reset; # If we iterated already over the set
 192             while ( my $o = $self->next ) {
 193                 $o->delete;
 194                 $objects_deleted++;
 195             }
 196         });
 197         return $objects_deleted;
 198     }
 199
 200     return $self->_resultset->delete;
 201 }
 202
 203 =head3 update
 204
 205     my $objects = Koha::Objects->new; # or Koha::Objects->search
 206     $objects->update( $fields, [ { no_triggers => 0/1 } ] );
 207
 208 This method overloads the DBIC inherited one so if code-level triggers exist
 209 (through the use of an overloaded I<update> or I<store> method in the Koha::Object
 210 based class) those are called in a loop on the resultset.
 211
 212 If B<no_triggers> is passed and I<true>, then the DBIC update method is called
 213 directly. This feature is important for performance, in cases where no code-level
 214 triggers should be triggered. The developer will explicitly ask for this and QA should
 215 catch wrong uses as well.
 216
 217 =cut
 218
 219 sub update {
 220     my ($self, $fields, $options) = @_;
 221
 222     Koha::Exceptions::Object::NotInstantiated->throw(
 223         method => 'update',
 224         class  => $self
 225     ) unless ref $self;
 226
 227     my $no_triggers = $options->{no_triggers};
 228
 229     if (
 230         !$no_triggers
 231         && ( Class::Inspector->function_exists( $self->object_class, 'update' )
 232           or Class::Inspector->function_exists( $self->object_class, 'store' ) )
 233       )
 234     {
 235         my $objects_updated;
 236         $self->_resultset->result_source->schema->txn_do( sub {
 237             while ( my $o = $self->next ) {
 238                 $o->update($fields);
 239                 $objects_updated++;
 240             }
 241         });
 242         return $objects_updated;
 243     }
 244
 245     return $self->_resultset->update($fields);
 246 }
 247
 248 =head3 filter_by_last_update
 249
 250 my $filtered_objects = $objects->filter_by_last_update({
 251     from => $date1, to => $date2,
 252     days|older_than => $days, min_days => $days, younger_than => $days,
 253 });
 254
 255 You should pass at least one of the parameters: from, to, days|older_than,
 256 min_days or younger_than. Make sure that they do not conflict with each other
 257 to get meaningful results.
 258 Note: from, to and min_days are inclusive! And by nature days|older_than
 259 and younger_than are exclusive.
 260
 261 The from and to parameters can be DateTime objects or date strings.
 262
 263 =cut
 264
 265 sub filter_by_last_update {
 266     my ( $self, $params ) = @_;
 267     my $timestamp_column_name = $params->{timestamp_column_name} || 'timestamp';
 268     my $conditions;
 269     Koha::Exceptions::MissingParameter->throw("Please pass: days|from|to|older_than|younger_than")
 270         unless grep { exists $params->{$_} } qw/days from to older_than younger_than min_days/;
 271
 272     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
 273     foreach my $p ( qw/days older_than younger_than min_days/  ) {
 274         next if !exists $params->{$p};
 275         my $dt = Koha::DateUtils::dt_from_string();
 276         my $operator = { days => '<', older_than => '<', min_days => '<=' }->{$p} // '>';
 277         $dt->subtract( days => $params->{$p} )->truncate( to => 'day' );
 278         $conditions->{$operator} = $dtf->format_datetime( $dt );
 279     }
 280     if ( exists $params->{from} ) {
 281         my $from = ref($params->{from}) ? $params->{from} : dt_from_string($params->{from});
 282         $conditions->{'>='} = $dtf->format_datetime( $from );
 283     }
 284     if ( exists $params->{to} ) {
 285         my $to = ref($params->{to}) ? $params->{to} : dt_from_string($params->{to});
 286         $conditions->{'<='} = $dtf->format_datetime( $to );
 287     }
 288
 289     return $self->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 = $self->search(\'0 = 1');
 381     $self->_resultset()->set_cache([]);
 382
 383     return $self;
 384 }
 385
 386 =head3 Koha::Objects->reset();
 387
 388 Koha::Objects->reset();
 389
 390 resets iteration so the next call to next() will start agein
 391 with the first object in a set.
 392
 393 =cut
 394
 395 sub reset {
 396     my ( $self ) = @_;
 397
 398     $self->_resultset()->reset();
 399
 400     return $self;
 401 }
 402
 403 =head3 Koha::Objects->as_list();
 404
 405 Koha::Objects->as_list();
 406
 407 Returns an arrayref of the objects in this set.
 408
 409 =cut
 410
 411 sub as_list {
 412     my ( $self ) = @_;
 413
 414     my @dbic_rows = $self->_resultset()->all();
 415
 416     my @objects = $self->_wrap(@dbic_rows);
 417
 418     return wantarray ? @objects : \@objects;
 419 }
 420
 421 =head3 Koha::Objects->unblessed
 422
 423 Returns an unblessed representation of objects.
 424
 425 =cut
 426
 427 sub unblessed {
 428     my ($self) = @_;
 429
 430     return [ map { $_->unblessed } $self->as_list ];
 431 }
 432
 433 =head3 Koha::Objects->get_column
 434
 435 Return all the values of this set for a given column
 436
 437 =cut
 438
 439 sub get_column {
 440     my ($self, $column_name) = @_;
 441     return $self->_resultset->get_column( $column_name )->all;
 442 }
 443
 444 =head3 Koha::Objects->TO_JSON
 445
 446 Returns an unblessed representation of objects, suitable for JSON output.
 447
 448 =cut
 449
 450 sub TO_JSON {
 451     my ($self) = @_;
 452
 453     return [ map { $_->TO_JSON } $self->as_list ];
 454 }
 455
 456 =head3 Koha::Objects->to_api
 457
 458 Returns a representation of the objects, suitable for API output .
 459
 460 =cut
 461
 462 sub to_api {
 463     my ($self, $params) = @_;
 464
 465     return [ map { $_->to_api($params) } $self->as_list ];
 466 }
 467
 468 =head3 attributes_from_api
 469
 470     my $attributes = $objects->attributes_from_api( $api_attributes );
 471
 472 Translates attributes from the API to DBIC
 473
 474 =cut
 475
 476 sub attributes_from_api {
 477     my ( $self, $attributes ) = @_;
 478
 479     $self->{_singular_object} ||= $self->object_class->new();
 480     return $self->{_singular_object}->attributes_from_api( $attributes );
 481 }
 482
 483 =head3 from_api_mapping
 484
 485     my $mapped_attributes_hash = $objects->from_api_mapping;
 486
 487 Attributes map from the API to DBIC
 488
 489 =cut
 490
 491 sub from_api_mapping {
 492     my ( $self ) = @_;
 493
 494     $self->{_singular_object} ||= $self->object_class->new();
 495     return $self->{_singular_object}->from_api_mapping;
 496 }
 497
 498 =head3 prefetch_whitelist
 499
 500     my $whitelist = $object->prefetch_whitelist()
 501
 502 Returns a hash of prefetchable subs and the type it returns
 503
 504 =cut
 505
 506 sub prefetch_whitelist {
 507     my ( $self ) = @_;
 508
 509     $self->{_singular_object} ||= $self->object_class->new();
 510
 511     $self->{_singular_object}->prefetch_whitelist;
 512 }
 513
 514 =head3 Koha::Objects->_wrap
 515
 516 wraps the DBIC object in a corresponding Koha object
 517
 518 =cut
 519
 520 sub _wrap {
 521     my ( $self, @dbic_rows ) = @_;
 522
 523     my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;
 524
 525     return @objects;
 526 }
 527
 528 =head3 Koha::Objects->_resultset
 529
 530 Returns the internal resultset or creates it if undefined
 531
 532 =cut
 533
 534 sub _resultset {
 535     my ($self) = @_;
 536
 537     if ( ref($self) ) {
 538         $self->{_resultset} ||=
 539           Koha::Database->new()->schema()->resultset( $self->_type() );
 540
 541         return $self->{_resultset};
 542     }
 543     else {
 544         return Koha::Database->new()->schema()->resultset( $self->_type() );
 545     }
 546 }
 547
 548 sub _get_objects_class {
 549     my ( $type ) = @_;
 550     return unless $type;
 551
 552     if( $type->can('koha_objects_class') ) {
 553         return $type->koha_objects_class;
 554     }
 555     $type =~ s|Schema::Result::||;
 556     return "${type}s";
 557 }
 558
 559 =head3 columns
 560
 561 my @columns = Koha::Objects->columns
 562
 563 Return the table columns
 564
 565 =cut
 566
 567 sub columns {
 568     my ( $class ) = @_;
 569     return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
 570 }
 571
 572 =head3 AUTOLOAD
 573
 574 The autoload method is used call DBIx::Class method on a resultset.
 575
 576 Important: If you plan to use one of the DBIx::Class methods you must provide
 577 relevant tests in t/db_dependent/Koha/Objects.t
 578 Currently count, is_paged, pager, result_class, single and slice are covered.
 579
 580 =cut
 581
 582 sub AUTOLOAD {
 583     my ( $self, @params ) = @_;
 584
 585     my @known_methods = qw( count is_paged pager result_class single slice );
 586     my $method = our $AUTOLOAD;
 587     $method =~ s/.*:://;
 588
 589
 590     unless ( grep { $_ eq $method } @known_methods ) {
 591         my $class = ref($self) ? ref($self) : $self;
 592         Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 593             error      => sprintf("The method %s->%s is not covered by tests!", $class, $method),
 594             show_trace => 1
 595         );
 596     }
 597
 598     my $r = eval { $self->_resultset->$method(@params) };
 599     if ( $@ ) {
 600         carp "No method $method found for " . ref($self) . " " . $@;
 601         return
 602     }
 603     return $r;
 604 }
 605
 606 =head3 _type
 607
 608 The _type method must be set for all child classes.
 609 The value returned by it should be the DBIC resultset name.
 610 For example, for holds, _type should return 'Reserve'.
 611
 612 =cut
 613
 614 sub _type { }
 615
 616 =head3 object_class
 617
 618 This method must be set for all child classes.
 619 The value returned by it should be the name of the Koha
 620 object class that is returned by this class.
 621 For example, for holds, object_class should return 'Koha::Hold'.
 622
 623 =cut
 624
 625 sub object_class { }
 626
 627 sub DESTROY { }
 628
 629 =head1 AUTHOR
 630
 631 Kyle M Hall <kyle@bywatersolutions.com>
 632
 633 =cut
 634
 635 1;