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     # 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 by default (will be inclusive if days_inclusive is passed and set)
 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 $days_inclusive = $params->{days_inclusive} || 0;
 270     my $conditions;
 271     Koha::Exceptions::MissingParameter->throw(
 272         "Missing mandatory parameter: days or from or to")
 273       unless exists $params->{days}
 274           or exists $params->{from}
 275           or exists $params->{to};
 276
 277     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
 278     if ( exists $params->{days} ) {
 279         my $dt = Koha::DateUtils::dt_from_string();
 280         my $operator = $days_inclusive ? '<=' : '<';
 281         $conditions->{$operator} = $dtf->format_date( $dt->subtract( days => $params->{days} ) );
 282     }
 283     if ( exists $params->{from} ) {
 284         my $from = ref($params->{from}) ? $params->{from} : dt_from_string($params->{from});
 285         $conditions->{'>='} = $dtf->format_date( $from );
 286     }
 287     if ( exists $params->{to} ) {
 288         my $to = ref($params->{to}) ? $params->{to} : dt_from_string($params->{to});
 289         $conditions->{'<='} = $dtf->format_date( $to );
 290     }
 291
 292     return $self->search(
 293         {
 294             $timestamp_column_name => $conditions
 295         }
 296     );
 297 }
 298
 299 =head3 single
 300
 301 my $object = Koha::Objects->search({}, { rows => 1 })->single
 302
 303 Returns one and only one object that is part of this set.
 304 Returns undef if there are no objects found.
 305
 306 This is optimal as it will grab the first returned result without instantiating
 307 a cursor.
 308
 309 See:
 310 http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod#Retrieve_one_and_only_one_row_from_a_resultset
 311
 312 =cut
 313
 314 sub single {
 315     my ($self) = @_;
 316
 317     my $single = $self->_resultset()->single;
 318     return unless $single;
 319
 320     return $self->object_class()->_new_from_dbic($single);
 321 }
 322
 323 =head3 Koha::Objects->next();
 324
 325 my $object = Koha::Objects->next();
 326
 327 Returns the next object that is part of this set.
 328 Returns undef if there are no more objects to return.
 329
 330 =cut
 331
 332 sub next {
 333     my ( $self ) = @_;
 334
 335     my $result = $self->_resultset()->next();
 336     return unless $result;
 337
 338     my $object = $self->object_class()->_new_from_dbic( $result );
 339
 340     return $object;
 341 }
 342
 343 =head3 Koha::Objects->last;
 344
 345 my $object = Koha::Objects->last;
 346
 347 Returns the last object that is part of this set.
 348 Returns undef if there are no object to return.
 349
 350 =cut
 351
 352 sub last {
 353     my ( $self ) = @_;
 354
 355     my $count = $self->_resultset->count;
 356     return unless $count;
 357
 358     my ( $result ) = $self->_resultset->slice($count - 1, $count - 1);
 359
 360     my $object = $self->object_class()->_new_from_dbic( $result );
 361
 362     return $object;
 363 }
 364
 365 =head3 empty
 366
 367     my $empty_rs = Koha::Objects->new->empty;
 368
 369 Sets the resultset empty. This is handy for consistency on method returns
 370 (e.g. if we know in advance we won't have results but want to keep returning
 371 an iterator).
 372
 373 =cut
 374
 375 sub empty {
 376     my ($self) = @_;
 377
 378     Koha::Exceptions::Object::NotInstantiated->throw(
 379         method => 'empty',
 380         class  => $self
 381     ) unless ref $self;
 382
 383     $self = $self->search(\'0 = 1');
 384     $self->_resultset()->set_cache([]);
 385
 386     return $self;
 387 }
 388
 389 =head3 Koha::Objects->reset();
 390
 391 Koha::Objects->reset();
 392
 393 resets iteration so the next call to next() will start agein
 394 with the first object in a set.
 395
 396 =cut
 397
 398 sub reset {
 399     my ( $self ) = @_;
 400
 401     $self->_resultset()->reset();
 402
 403     return $self;
 404 }
 405
 406 =head3 Koha::Objects->as_list();
 407
 408 Koha::Objects->as_list();
 409
 410 Returns an arrayref of the objects in this set.
 411
 412 =cut
 413
 414 sub as_list {
 415     my ( $self ) = @_;
 416
 417     my @dbic_rows = $self->_resultset()->all();
 418
 419     my @objects = $self->_wrap(@dbic_rows);
 420
 421     return wantarray ? @objects : \@objects;
 422 }
 423
 424 =head3 Koha::Objects->unblessed
 425
 426 Returns an unblessed representation of objects.
 427
 428 =cut
 429
 430 sub unblessed {
 431     my ($self) = @_;
 432
 433     return [ map { $_->unblessed } $self->as_list ];
 434 }
 435
 436 =head3 Koha::Objects->get_column
 437
 438 Return all the values of this set for a given column
 439
 440 =cut
 441
 442 sub get_column {
 443     my ($self, $column_name) = @_;
 444     return $self->_resultset->get_column( $column_name )->all;
 445 }
 446
 447 =head3 Koha::Objects->TO_JSON
 448
 449 Returns an unblessed representation of objects, suitable for JSON output.
 450
 451 =cut
 452
 453 sub TO_JSON {
 454     my ($self) = @_;
 455
 456     return [ map { $_->TO_JSON } $self->as_list ];
 457 }
 458
 459 =head3 Koha::Objects->to_api
 460
 461 Returns a representation of the objects, suitable for API output .
 462
 463 =cut
 464
 465 sub to_api {
 466     my ($self, $params) = @_;
 467
 468     return [ map { $_->to_api($params) } $self->as_list ];
 469 }
 470
 471 =head3 attributes_from_api
 472
 473     my $attributes = $objects->attributes_from_api( $api_attributes );
 474
 475 Translates attributes from the API to DBIC
 476
 477 =cut
 478
 479 sub attributes_from_api {
 480     my ( $self, $attributes ) = @_;
 481
 482     $self->{_singular_object} ||= $self->object_class->new();
 483     return $self->{_singular_object}->attributes_from_api( $attributes );
 484 }
 485
 486 =head3 from_api_mapping
 487
 488     my $mapped_attributes_hash = $objects->from_api_mapping;
 489
 490 Attributes map from the API to DBIC
 491
 492 =cut
 493
 494 sub from_api_mapping {
 495     my ( $self ) = @_;
 496
 497     $self->{_singular_object} ||= $self->object_class->new();
 498     return $self->{_singular_object}->from_api_mapping;
 499 }
 500
 501 =head3 prefetch_whitelist
 502
 503     my $whitelist = $object->prefetch_whitelist()
 504
 505 Returns a hash of prefetchable subs and the type it returns
 506
 507 =cut
 508
 509 sub prefetch_whitelist {
 510     my ( $self ) = @_;
 511
 512     $self->{_singular_object} ||= $self->object_class->new();
 513
 514     $self->{_singular_object}->prefetch_whitelist;
 515 }
 516
 517 =head3 Koha::Objects->_wrap
 518
 519 wraps the DBIC object in a corresponding Koha object
 520
 521 =cut
 522
 523 sub _wrap {
 524     my ( $self, @dbic_rows ) = @_;
 525
 526     my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;
 527
 528     return @objects;
 529 }
 530
 531 =head3 Koha::Objects->_resultset
 532
 533 Returns the internal resultset or creates it if undefined
 534
 535 =cut
 536
 537 sub _resultset {
 538     my ($self) = @_;
 539
 540     if ( ref($self) ) {
 541         $self->{_resultset} ||=
 542           Koha::Database->new()->schema()->resultset( $self->_type() );
 543
 544         return $self->{_resultset};
 545     }
 546     else {
 547         return Koha::Database->new()->schema()->resultset( $self->_type() );
 548     }
 549 }
 550
 551 sub _get_objects_class {
 552     my ( $type ) = @_;
 553     return unless $type;
 554
 555     if( $type->can('koha_objects_class') ) {
 556         return $type->koha_objects_class;
 557     }
 558     $type =~ s|Schema::Result::||;
 559     return "${type}s";
 560 }
 561
 562 =head3 columns
 563
 564 my @columns = Koha::Objects->columns
 565
 566 Return the table columns
 567
 568 =cut
 569
 570 sub columns {
 571     my ( $class ) = @_;
 572     return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
 573 }
 574
 575 =head3 AUTOLOAD
 576
 577 The autoload method is used call DBIx::Class method on a resultset.
 578
 579 Important: If you plan to use one of the DBIx::Class methods you must provide
 580 relevant tests in t/db_dependent/Koha/Objects.t
 581 Currently count, is_paged, pager, result_class, single and slice are covered.
 582
 583 =cut
 584
 585 sub AUTOLOAD {
 586     my ( $self, @params ) = @_;
 587
 588     my @known_methods = qw( count is_paged pager result_class single slice );
 589     my $method = our $AUTOLOAD;
 590     $method =~ s/.*:://;
 591
 592
 593     unless ( grep { $_ eq $method } @known_methods ) {
 594         my $class = ref($self) ? ref($self) : $self;
 595         Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 596             error      => sprintf("The method %s->%s is not covered by tests!", $class, $method),
 597             show_trace => 1
 598         );
 599     }
 600
 601     my $r = eval { $self->_resultset->$method(@params) };
 602     if ( $@ ) {
 603         carp "No method $method found for " . ref($self) . " " . $@;
 604         return
 605     }
 606     return $r;
 607 }
 608
 609 =head3 _type
 610
 611 The _type method must be set for all child classes.
 612 The value returned by it should be the DBIC resultset name.
 613 For example, for holds, _type should return 'Reserve'.
 614
 615 =cut
 616
 617 sub _type { }
 618
 619 =head3 object_class
 620
 621 This method must be set for all child classes.
 622 The value returned by it should be the name of the Koha
 623 object class that is returned by this class.
 624 For example, for holds, object_class should return 'Koha::Hold'.
 625
 626 =cut
 627
 628 sub object_class { }
 629
 630 sub DESTROY { }
 631
 632 =head1 AUTHOR
 633
 634 Kyle M Hall <kyle@bywatersolutions.com>
 635
 636 =cut
 637
 638 1;