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