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