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