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 under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 3 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  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 my $object = Koha::Objects->find( { col1 => $val1, col2 => $val2 } );
  80 my $object = Koha::Objects->find( $id );
  81 my $object = Koha::Objects->find( $idpart1, $idpart2, $attrs ); # composite PK
  82
  83 =cut
  84
  85 sub find {
  86     my ( $self, @pars ) = @_;
  87
  88     croak 'Cannot use "->find" in list context' if wantarray;
  89
  90     return if !@pars || none { defined($_) } @pars;
  91
  92     my $result = $self->_resultset()->find( @pars );
  93
  94     return unless $result;
  95
  96     my $object = $self->object_class()->_new_from_dbic( $result );
  97
  98     return $object;
  99 }
 100
 101 =head3 Koha::Objects->find_or_create();
 102
 103 my $object = Koha::Objects->find_or_create( $attrs );
 104
 105 =cut
 106
 107 sub find_or_create {
 108     my ( $self, $params ) = @_;
 109
 110     my $result = $self->_resultset->find_or_create($params);
 111
 112     return unless $result;
 113
 114     my $object = $self->object_class->_new_from_dbic($result);
 115
 116     return $object;
 117 }
 118
 119 =head3 Koha::Objects->search();
 120
 121 my @objects = Koha::Objects->search($params);
 122
 123 =cut
 124
 125 sub search {
 126     my ( $self, $params, $attributes ) = @_;
 127
 128     if (wantarray) {
 129         my @dbic_rows = $self->_resultset()->search($params, $attributes);
 130
 131         return $self->_wrap(@dbic_rows);
 132
 133     }
 134     else {
 135         my $class = ref($self) ? ref($self) : $self;
 136         my $rs = $self->_resultset()->search($params, $attributes);
 137
 138         return $class->_new_from_dbic($rs);
 139     }
 140 }
 141
 142 =head3 search_related
 143
 144     my @objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
 145     my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
 146
 147 Searches the specified relationship, optionally specifying a condition and attributes for matching records.
 148
 149 =cut
 150
 151 sub search_related {
 152     my ( $self, $rel_name, @params ) = @_;
 153
 154     return if !$rel_name;
 155     if (wantarray) {
 156         my @dbic_rows = $self->_resultset()->search_related($rel_name, @params);
 157         return if !@dbic_rows;
 158         my $object_class = _get_objects_class( $dbic_rows[0]->result_class );
 159
 160         eval "require $object_class";
 161         return _wrap( $object_class, @dbic_rows );
 162
 163     } else {
 164         my $rs = $self->_resultset()->search_related($rel_name, @params);
 165         return if !$rs;
 166         my $object_class = _get_objects_class( $rs->result_class );
 167
 168         eval "require $object_class";
 169         return _new_from_dbic( $object_class, $rs );
 170     }
 171 }
 172
 173 =head3 single
 174
 175 my $object = Koha::Objects->search({}, { rows => 1 })->single
 176
 177 Returns one and only one object that is part of this set.
 178 Returns undef if there are no objects found.
 179
 180 This is optimal as it will grab the first returned result without instantiating
 181 a cursor.
 182
 183 See:
 184 http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod#Retrieve_one_and_only_one_row_from_a_resultset
 185
 186 =cut
 187
 188 sub single {
 189     my ($self) = @_;
 190
 191     my $single = $self->_resultset()->single;
 192     return unless $single;
 193
 194     return $self->object_class()->_new_from_dbic($single);
 195 }
 196
 197 =head3 Koha::Objects->next();
 198
 199 my $object = Koha::Objects->next();
 200
 201 Returns the next object that is part of this set.
 202 Returns undef if there are no more objects to return.
 203
 204 =cut
 205
 206 sub next {
 207     my ( $self ) = @_;
 208
 209     my $result = $self->_resultset()->next();
 210     return unless $result;
 211
 212     my $object = $self->object_class()->_new_from_dbic( $result );
 213
 214     return $object;
 215 }
 216
 217 =head3 Koha::Objects->last;
 218
 219 my $object = Koha::Objects->last;
 220
 221 Returns the last object that is part of this set.
 222 Returns undef if there are no object to return.
 223
 224 =cut
 225
 226 sub last {
 227     my ( $self ) = @_;
 228
 229     my $count = $self->_resultset->count;
 230     return unless $count;
 231
 232     my ( $result ) = $self->_resultset->slice($count - 1, $count - 1);
 233
 234     my $object = $self->object_class()->_new_from_dbic( $result );
 235
 236     return $object;
 237 }
 238
 239
 240
 241 =head3 Koha::Objects->reset();
 242
 243 Koha::Objects->reset();
 244
 245 resets iteration so the next call to next() will start agein
 246 with the first object in a set.
 247
 248 =cut
 249
 250 sub reset {
 251     my ( $self ) = @_;
 252
 253     $self->_resultset()->reset();
 254
 255     return $self;
 256 }
 257
 258 =head3 Koha::Objects->as_list();
 259
 260 Koha::Objects->as_list();
 261
 262 Returns an arrayref of the objects in this set.
 263
 264 =cut
 265
 266 sub as_list {
 267     my ( $self ) = @_;
 268
 269     my @dbic_rows = $self->_resultset()->all();
 270
 271     my @objects = $self->_wrap(@dbic_rows);
 272
 273     return wantarray ? @objects : \@objects;
 274 }
 275
 276 =head3 Koha::Objects->unblessed
 277
 278 Returns an unblessed representation of objects.
 279
 280 =cut
 281
 282 sub unblessed {
 283     my ($self) = @_;
 284
 285     return [ map { $_->unblessed } $self->as_list ];
 286 }
 287
 288 =head3 Koha::Objects->get_column
 289
 290 Return all the values of this set for a given column
 291
 292 =cut
 293
 294 sub get_column {
 295     my ($self, $column_name) = @_;
 296     return $self->_resultset->get_column( $column_name )->all;
 297 }
 298
 299 =head3 Koha::Objects->TO_JSON
 300
 301 Returns an unblessed representation of objects, suitable for JSON output.
 302
 303 =cut
 304
 305 sub TO_JSON {
 306     my ($self) = @_;
 307
 308     return [ map { $_->TO_JSON } $self->as_list ];
 309 }
 310
 311 =head3 Koha::Objects->_wrap
 312
 313 wraps the DBIC object in a corresponding Koha object
 314
 315 =cut
 316
 317 sub _wrap {
 318     my ( $self, @dbic_rows ) = @_;
 319
 320     my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;
 321
 322     return @objects;
 323 }
 324
 325 =head3 Koha::Objects->_resultset
 326
 327 Returns the internal resultset or creates it if undefined
 328
 329 =cut
 330
 331 sub _resultset {
 332     my ($self) = @_;
 333
 334     if ( ref($self) ) {
 335         $self->{_resultset} ||=
 336           Koha::Database->new()->schema()->resultset( $self->_type() );
 337
 338         return $self->{_resultset};
 339     }
 340     else {
 341         return Koha::Database->new()->schema()->resultset( $self->_type() );
 342     }
 343 }
 344
 345 sub _get_objects_class {
 346     my ( $type ) = @_;
 347     return unless $type;
 348
 349     if( $type->can('koha_objects_class') ) {
 350         return $type->koha_objects_class;
 351     }
 352     $type =~ s|Schema::Result::||;
 353     return "${type}s";
 354 }
 355
 356 =head3 columns
 357
 358 my @columns = Koha::Objects->columns
 359
 360 Return the table columns
 361
 362 =cut
 363
 364 sub columns {
 365     my ( $class ) = @_;
 366     return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
 367 }
 368
 369 =head3 AUTOLOAD
 370
 371 The autoload method is used call DBIx::Class method on a resultset.
 372
 373 Important: If you plan to use one of the DBIx::Class methods you must provide
 374 relevant tests in t/db_dependent/Koha/Objects.t
 375 Currently count, pager, update and delete are covered.
 376
 377 =cut
 378
 379 sub AUTOLOAD {
 380     my ( $self, @params ) = @_;
 381
 382     my @known_methods = qw( count is_paged pager update delete result_class single slice );
 383     my $method = our $AUTOLOAD;
 384     $method =~ s/.*:://;
 385
 386
 387     unless ( grep { /^$method$/ } @known_methods ) {
 388         my $class = ref($self) ? ref($self) : $self;
 389         Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 390             error      => sprintf("The method %s->%s is not covered by tests!", $class, $method),
 391             show_trace => 1
 392         );
 393     }
 394
 395     my $r = eval { $self->_resultset->$method(@params) };
 396     if ( $@ ) {
 397         carp "No method $method found for " . ref($self) . " " . $@;
 398         return
 399     }
 400     return $r;
 401 }
 402
 403 =head3 _type
 404
 405 The _type method must be set for all child classes.
 406 The value returned by it should be the DBIC resultset name.
 407 For example, for holds, _type should return 'Reserve'.
 408
 409 =cut
 410
 411 sub _type { }
 412
 413 =head3 object_class
 414
 415 This method must be set for all child classes.
 416 The value returned by it should be the name of the Koha
 417 object class that is returned by this class.
 418 For example, for holds, object_class should return 'Koha::Hold'.
 419
 420 =cut
 421
 422 sub object_class { }
 423
 424 sub DESTROY { }
 425
 426 =head1 AUTHOR
 427
 428 Kyle M Hall <kyle@bywatersolutions.com>
 429
 430 =cut
 431
 432 1;