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