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
  29 =head1 NAME
  30
  31 Koha::Objects - Koha Object set base class
  32
  33 =head1 SYNOPSIS
  34
  35     use Koha::Objects;
  36     my $objects = Koha::Objects->search({ borrowernumber => $borrowernumber});
  37
  38 =head1 DESCRIPTION
  39
  40 This class must be subclassed.
  41
  42 =head1 API
  43
  44 =head2 Class Methods
  45
  46 =cut
  47
  48 =head3 Koha::Objects->new();
  49
  50 my $object = Koha::Objects->new();
  51
  52 =cut
  53
  54 sub new {
  55     my ($class) = @_;
  56     my $self = {};
  57
  58     bless( $self, $class );
  59 }
  60
  61 =head3 Koha::Objects->_new_from_dbic();
  62
  63 my $object = Koha::Objects->_new_from_dbic( $resultset );
  64
  65 =cut
  66
  67 sub _new_from_dbic {
  68     my ( $class, $resultset ) = @_;
  69     my $self = { _resultset => $resultset };
  70
  71     bless( $self, $class );
  72 }
  73
  74 =head3 Koha::Objects->find();
  75
  76 Similar to DBIx::Class::ResultSet->find this method accepts:
  77     \%columns_values | @pk_values, { key => $unique_constraint, %attrs }?
  78 Strictly speaking, columns_values should only refer to columns under an
  79 unique constraint.
  80
  81 It returns undef if no results were found
  82
  83 my $object = Koha::Objects->find( { col1 => $val1, col2 => $val2 } );
  84 my $object = Koha::Objects->find( $id );
  85 my $object = Koha::Objects->find( $idpart1, $idpart2, $attrs ); # composite PK
  86
  87 =cut
  88
  89 sub find {
  90     my ( $self, @pars ) = @_;
  91
  92     my $object;
  93
  94     unless (!@pars || none { defined($_) } @pars) {
  95         my $result = $self->_resultset()->find(@pars);
  96         if ($result) {
  97             $object = $self->object_class()->_new_from_dbic($result);
  98         }
  99     }
 100
 101     return $object;
 102 }
 103
 104 =head3 Koha::Objects->find_or_create();
 105
 106 my $object = Koha::Objects->find_or_create( $attrs );
 107
 108 =cut
 109
 110 sub find_or_create {
 111     my ( $self, $params ) = @_;
 112
 113     my $result = $self->_resultset->find_or_create($params);
 114
 115     return unless $result;
 116
 117     my $object = $self->object_class->_new_from_dbic($result);
 118
 119     return $object;
 120 }
 121
 122 =head3 search
 123
 124     # scalar context
 125     my $objects = Koha::Objects->search([$params, $attributes]);
 126     while (my $object = $objects->next) {
 127         do_stuff($object);
 128     }
 129
 130 This B<instantiates> the I<Koha::Objects> class, and generates a resultset
 131 based on the query I<$params> and I<$attributes> that are passed (like in DBIC).
 132
 133 =cut
 134
 135 sub search {
 136     my ( $self, $params, $attributes ) = @_;
 137
 138     my $class = ref($self) ? ref($self) : $self;
 139     my $rs = $self->_resultset()->search($params, $attributes);
 140
 141     return $class->_new_from_dbic($rs);
 142 }
 143
 144 =head3 search_related
 145
 146     my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
 147
 148 Searches the specified relationship, optionally specifying a condition and attributes for matching records.
 149
 150 =cut
 151
 152 sub search_related {
 153     my ( $self, $rel_name, @params ) = @_;
 154
 155     return if !$rel_name;
 156
 157     my $rs = $self->_resultset()->search_related($rel_name, @params);
 158     return if !$rs;
 159     my $object_class = _get_objects_class( $rs->result_class );
 160
 161     eval "require $object_class";
 162     return _new_from_dbic( $object_class, $rs );
 163 }
 164
 165 =head3 delete
 166
 167 =cut
 168
 169 sub delete {
 170     my ($self) = @_;
 171
 172     if ( Class::Inspector->function_exists( $self->object_class, 'delete' ) ) {
 173         my $objects_deleted;
 174         $self->_resultset->result_source->schema->txn_do( sub {
 175             $self->reset; # If we iterated already over the set
 176             while ( my $o = $self->next ) {
 177                 $o->delete;
 178                 $objects_deleted++;
 179             }
 180         });
 181         return $objects_deleted;
 182     }
 183
 184     return $self->_resultset->delete;
 185 }
 186
 187 =head3 update
 188
 189     my $objects = Koha::Objects->new; # or Koha::Objects->search
 190     $objects->update( $fields, [ { no_triggers => 0/1 } ] );
 191
 192 This method overloads the DBIC inherited one so if code-level triggers exist
 193 (through the use of an overloaded I<update> or I<store> method in the Koha::Object
 194 based class) those are called in a loop on the resultset.
 195
 196 If B<no_triggers> is passed and I<true>, then the DBIC update method is called
 197 directly. This feature is important for performance, in cases where no code-level
 198 triggers should be triggered. The developer will explicitly ask for this and QA should
 199 catch wrong uses as well.
 200
 201 =cut
 202
 203 sub update {
 204     my ($self, $fields, $options) = @_;
 205
 206     Koha::Exceptions::Object::NotInstantiated->throw(
 207         method => 'update',
 208         class  => $self
 209     ) unless ref $self;
 210
 211     my $no_triggers = $options->{no_triggers};
 212
 213     if (
 214         !$no_triggers
 215         && ( Class::Inspector->function_exists( $self->object_class, 'update' )
 216           or Class::Inspector->function_exists( $self->object_class, 'store' ) )
 217       )
 218     {
 219         my $objects_updated;
 220         $self->_resultset->result_source->schema->txn_do( sub {
 221             while ( my $o = $self->next ) {
 222                 $o->update($fields);
 223                 $objects_updated++;
 224             }
 225         });
 226         return $objects_updated;
 227     }
 228
 229     return $self->_resultset->update($fields);
 230 }
 231
 232 =head3 filter_by_last_update
 233
 234     my $filtered_objects = $objects->filter_by_last_update({
 235         from => $from_datetime, to => $to_datetime,
 236         days|older_than => $days, min_days => $days, younger_than => $days,
 237     });
 238
 239 You should pass at least one of the parameters: from, to, days|older_than,
 240 min_days or younger_than. Make sure that they do not conflict with each other
 241 to get meaningful results.
 242 Note: from, to and min_days are inclusive! And by nature days|older_than
 243 and younger_than are exclusive.
 244
 245 The from and to parameters must be DateTime objects.
 246
 247 =cut
 248
 249 sub filter_by_last_update {
 250     my ( $self, $params ) = @_;
 251     my $timestamp_column_name = $params->{timestamp_column_name} || 'timestamp';
 252     my $conditions;
 253     Koha::Exceptions::MissingParameter->throw("Please pass: days|from|to|older_than|younger_than")
 254         unless grep { exists $params->{$_} } qw/days from to older_than younger_than min_days/;
 255
 256     foreach my $key (qw(from to)) {
 257         if (exists $params->{$key} and ref $params->{$key} ne 'DateTime') {
 258             Koha::Exceptions::WrongParameter->throw("'$key' parameter must be a DateTime object");
 259         }
 260     }
 261
 262     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
 263     foreach my $p ( qw/days older_than younger_than min_days/  ) {
 264         next if !exists $params->{$p};
 265         my $days = $params->{$p};
 266         my $operator = { days => '<', older_than => '<', min_days => '<=' }->{$p} // '>';
 267         $conditions->{$operator} = \['DATE_SUB(CURDATE(), INTERVAL ? DAY)', $days];
 268     }
 269     if ( exists $params->{from} ) {
 270         $conditions->{'>='} = $dtf->format_datetime( $params->{from} );
 271     }
 272     if ( exists $params->{to} ) {
 273         $conditions->{'<='} = $dtf->format_datetime( $params->{to} );
 274     }
 275
 276     return $self->search(
 277         {
 278             $timestamp_column_name => $conditions
 279         }
 280     );
 281 }
 282
 283 =head3 single
 284
 285 my $object = Koha::Objects->search({}, { rows => 1 })->single
 286
 287 Returns one and only one object that is part of this set.
 288 Returns undef if there are no objects found.
 289
 290 This is optimal as it will grab the first returned result without instantiating
 291 a cursor.
 292
 293 See:
 294 http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod#Retrieve_one_and_only_one_row_from_a_resultset
 295
 296 =cut
 297
 298 sub single {
 299     my ($self) = @_;
 300
 301     my $single = $self->_resultset()->single;
 302     return unless $single;
 303
 304     return $self->object_class()->_new_from_dbic($single);
 305 }
 306
 307 =head3 Koha::Objects->next();
 308
 309 my $object = Koha::Objects->next();
 310
 311 Returns the next object that is part of this set.
 312 Returns undef if there are no more objects to return.
 313
 314 =cut
 315
 316 sub next {
 317     my ( $self ) = @_;
 318
 319     my $result = $self->_resultset()->next();
 320     return unless $result;
 321
 322     my $object = $self->object_class()->_new_from_dbic( $result );
 323
 324     return $object;
 325 }
 326
 327 =head3 Koha::Objects->last;
 328
 329 my $object = Koha::Objects->last;
 330
 331 Returns the last object that is part of this set.
 332 Returns undef if there are no object to return.
 333
 334 =cut
 335
 336 sub last {
 337     my ( $self ) = @_;
 338
 339     my $count = $self->_resultset->count;
 340     return unless $count;
 341
 342     my ( $result ) = $self->_resultset->slice($count - 1, $count - 1);
 343
 344     my $object = $self->object_class()->_new_from_dbic( $result );
 345
 346     return $object;
 347 }
 348
 349 =head3 empty
 350
 351     my $empty_rs = Koha::Objects->new->empty;
 352
 353 Sets the resultset empty. This is handy for consistency on method returns
 354 (e.g. if we know in advance we won't have results but want to keep returning
 355 an iterator).
 356
 357 =cut
 358
 359 sub empty {
 360     my ($self) = @_;
 361
 362     Koha::Exceptions::Object::NotInstantiated->throw(
 363         method => 'empty',
 364         class  => $self
 365     ) unless ref $self;
 366
 367     $self = $self->search(\'0 = 1');
 368     $self->_resultset()->set_cache([]);
 369
 370     return $self;
 371 }
 372
 373 =head3 Koha::Objects->reset();
 374
 375 Koha::Objects->reset();
 376
 377 resets iteration so the next call to next() will start agein
 378 with the first object in a set.
 379
 380 =cut
 381
 382 sub reset {
 383     my ( $self ) = @_;
 384
 385     $self->_resultset()->reset();
 386
 387     return $self;
 388 }
 389
 390 =head3 Koha::Objects->as_list();
 391
 392 Koha::Objects->as_list();
 393
 394 Returns an arrayref of the objects in this set.
 395
 396 =cut
 397
 398 sub as_list {
 399     my ( $self ) = @_;
 400
 401     my @dbic_rows = $self->_resultset()->all();
 402
 403     my @objects = $self->_wrap(@dbic_rows);
 404
 405     return wantarray ? @objects : \@objects;
 406 }
 407
 408 =head3 Koha::Objects->unblessed
 409
 410 Returns an unblessed representation of objects.
 411
 412 =cut
 413
 414 sub unblessed {
 415     my ($self) = @_;
 416
 417     return [ map { $_->unblessed } $self->as_list ];
 418 }
 419
 420 =head3 Koha::Objects->get_column
 421
 422 Return all the values of this set for a given column
 423
 424 =cut
 425
 426 sub get_column {
 427     my ($self, $column_name) = @_;
 428     return $self->_resultset->get_column( $column_name )->all;
 429 }
 430
 431 =head3 Koha::Objects->TO_JSON
 432
 433 Returns an unblessed representation of objects, suitable for JSON output.
 434
 435 =cut
 436
 437 sub TO_JSON {
 438     my ($self) = @_;
 439
 440     return [ map { $_->TO_JSON } $self->as_list ];
 441 }
 442
 443 =head3 Koha::Objects->to_api
 444
 445 Returns a representation of the objects, suitable for API output .
 446
 447 =cut
 448
 449 sub to_api {
 450     my ($self, $params) = @_;
 451
 452     return [ map { $_->to_api($params) } $self->as_list ];
 453 }
 454
 455 =head3 attributes_from_api
 456
 457     my $attributes = $objects->attributes_from_api( $api_attributes );
 458
 459 Translates attributes from the API to DBIC
 460
 461 =cut
 462
 463 sub attributes_from_api {
 464     my ( $self, $attributes ) = @_;
 465
 466     $self->{_singular_object} ||= $self->object_class->new();
 467     return $self->{_singular_object}->attributes_from_api( $attributes );
 468 }
 469
 470 =head3 from_api_mapping
 471
 472     my $mapped_attributes_hash = $objects->from_api_mapping;
 473
 474 Attributes map from the API to DBIC
 475
 476 =cut
 477
 478 sub from_api_mapping {
 479     my ( $self ) = @_;
 480
 481     $self->{_singular_object} ||= $self->object_class->new();
 482     return $self->{_singular_object}->from_api_mapping;
 483 }
 484
 485 =head3 prefetch_whitelist
 486
 487     my $whitelist = $object->prefetch_whitelist()
 488
 489 Returns a hash of prefetchable subs and the type it returns
 490
 491 =cut
 492
 493 sub prefetch_whitelist {
 494     my ( $self ) = @_;
 495
 496     $self->{_singular_object} ||= $self->object_class->new();
 497
 498     $self->{_singular_object}->prefetch_whitelist;
 499 }
 500
 501 =head3 Koha::Objects->_wrap
 502
 503 wraps the DBIC object in a corresponding Koha object
 504
 505 =cut
 506
 507 sub _wrap {
 508     my ( $self, @dbic_rows ) = @_;
 509
 510     my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;
 511
 512     return @objects;
 513 }
 514
 515 =head3 Koha::Objects->_resultset
 516
 517 Returns the internal resultset or creates it if undefined
 518
 519 =cut
 520
 521 sub _resultset {
 522     my ($self) = @_;
 523
 524     if ( ref($self) ) {
 525         $self->{_resultset} ||=
 526           Koha::Database->new()->schema()->resultset( $self->_type() );
 527
 528         return $self->{_resultset};
 529     }
 530     else {
 531         return Koha::Database->new()->schema()->resultset( $self->_type() );
 532     }
 533 }
 534
 535 sub _get_objects_class {
 536     my ( $type ) = @_;
 537     return unless $type;
 538
 539     if( $type->can('koha_objects_class') ) {
 540         return $type->koha_objects_class;
 541     }
 542     $type =~ s|Schema::Result::||;
 543     return "${type}s";
 544 }
 545
 546 =head3 columns
 547
 548 my @columns = Koha::Objects->columns
 549
 550 Return the table columns
 551
 552 =cut
 553
 554 sub columns {
 555     my ( $class ) = @_;
 556     return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
 557 }
 558
 559 =head3 AUTOLOAD
 560
 561 The autoload method is used call DBIx::Class method on a resultset.
 562
 563 Important: If you plan to use one of the DBIx::Class methods you must provide
 564 relevant tests in t/db_dependent/Koha/Objects.t
 565 Currently count, is_paged, pager, result_class, single and slice are covered.
 566
 567 =cut
 568
 569 sub AUTOLOAD {
 570     my ( $self, @params ) = @_;
 571
 572     my @known_methods = qw( count is_paged pager result_class single slice );
 573     my $method = our $AUTOLOAD;
 574     $method =~ s/.*:://;
 575
 576
 577     unless ( grep { $_ eq $method } @known_methods ) {
 578         my $class = ref($self) ? ref($self) : $self;
 579         Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 580             error      => sprintf("The method %s->%s is not covered by tests!", $class, $method),
 581             show_trace => 1
 582         );
 583     }
 584
 585     my $r = eval { $self->_resultset->$method(@params) };
 586     if ( $@ ) {
 587         carp "No method $method found for " . ref($self) . " " . $@;
 588         return
 589     }
 590     return $r;
 591 }
 592
 593 =head3 _type
 594
 595 The _type method must be set for all child classes.
 596 The value returned by it should be the DBIC resultset name.
 597 For example, for holds, _type should return 'Reserve'.
 598
 599 =cut
 600
 601 sub _type { }
 602
 603 =head3 object_class
 604
 605 This method must be set for all child classes.
 606 The value returned by it should be the name of the Koha
 607 object class that is returned by this class.
 608 For example, for holds, object_class should return 'Koha::Hold'.
 609
 610 =cut
 611
 612 sub object_class { }
 613
 614 sub DESTROY { }
 615
 616 =head1 AUTHOR
 617
 618 Kyle M Hall <kyle@bywatersolutions.com>
 619
 620 =cut
 621
 622 1;