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