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