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