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