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