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