Koha/Object.pm

   1 package Koha::Object;
   2
   3 # Copyright ByWater Solutions 2014
   4 # Copyright 2016 Koha Development Team
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 3 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along
  18 # with Koha; if not, write to the Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  20
  21 use Modern::Perl;
  22
  23 use Carp;
  24 use Mojo::JSON;
  25 use Scalar::Util qw( looks_like_number );
  26 use Try::Tiny;
  27
  28 use Koha::Database;
  29 use Koha::Exceptions::Object;
  30 use Koha::DateUtils;
  31
  32 =head1 NAME
  33
  34 Koha::Object - Koha Object base class
  35
  36 =head1 SYNOPSIS
  37
  38     use Koha::Object;
  39     my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
  40
  41 =head1 DESCRIPTION
  42
  43 This class must always be subclassed.
  44
  45 =head1 API
  46
  47 =head2 Class Methods
  48
  49 =cut
  50
  51 =head3 Koha::Object->new();
  52
  53 my $object = Koha::Object->new();
  54 my $object = Koha::Object->new($attributes);
  55
  56 Note that this cannot be used to retrieve record from the DB.
  57
  58 =cut
  59
  60 sub new {
  61     my ( $class, $attributes ) = @_;
  62     my $self = {};
  63
  64     if ($attributes) {
  65         my $schema = Koha::Database->new->schema;
  66
  67         # Remove the arguments which exist, are not defined but NOT NULL to use the default value
  68         my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
  69         for my $column_name ( keys %$attributes ) {
  70             my $c_info = $columns_info->{$column_name};
  71             next if $c_info->{is_nullable};
  72             next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
  73             delete $attributes->{$column_name};
  74         }
  75         $self->{_result} = $schema->resultset( $class->_type() )
  76           ->new($attributes);
  77     }
  78
  79     croak("No _type found! Koha::Object must be subclassed!")
  80       unless $class->_type();
  81
  82     bless( $self, $class );
  83
  84 }
  85
  86 =head3 Koha::Object->_new_from_dbic();
  87
  88 my $object = Koha::Object->_new_from_dbic($dbic_row);
  89
  90 =cut
  91
  92 sub _new_from_dbic {
  93     my ( $class, $dbic_row ) = @_;
  94     my $self = {};
  95
  96     # DBIC result row
  97     $self->{_result} = $dbic_row;
  98
  99     croak("No _type found! Koha::Object must be subclassed!")
 100       unless $class->_type();
 101
 102     croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
 103       unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
 104
 105     bless( $self, $class );
 106
 107 }
 108
 109 =head3 $object->store();
 110
 111 Saves the object in storage.
 112 If the object is new, it will be created.
 113 If the object previously existed, it will be updated.
 114
 115 Returns:
 116     $self  if the store was a success
 117     undef  if the store failed
 118
 119 =cut
 120
 121 sub store {
 122     my ($self) = @_;
 123
 124     try {
 125         return $self->_result()->update_or_insert() ? $self : undef;
 126     }
 127     catch {
 128         # Catch problems and raise relevant exceptions
 129         if (ref($_) eq 'DBIx::Class::Exception') {
 130             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 131                 # FK constraints
 132                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 133                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 134                     Koha::Exceptions::Object::FKConstraint->throw(
 135                         error     => 'Broken FK constraint',
 136                         broken_fk => $+{column}
 137                     );
 138                 }
 139             }
 140             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 141                 Koha::Exceptions::Object::DuplicateID->throw(
 142                     error => 'Duplicate ID',
 143                     duplicate_id => $+{key}
 144                 );
 145             }
 146             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column '(?<property>\w+)'/ ) {
 147                 Koha::Exceptions::Object::BadValue->throw(
 148                     type     => $+{type},
 149                     value    => $+{value},
 150                     property => $+{property}
 151                 );
 152             }
 153         }
 154         # Catch-all for foreign key breakages. It will help find other use cases
 155         $_->rethrow();
 156     }
 157 }
 158
 159 =head3 $object->delete();
 160
 161 Removes the object from storage.
 162
 163 Returns:
 164     1  if the deletion was a success
 165     0  if the deletion failed
 166     -1 if the object was never in storage
 167
 168 =cut
 169
 170 sub delete {
 171     my ($self) = @_;
 172
 173     # Deleting something not in storage throws an exception
 174     return -1 unless $self->_result()->in_storage();
 175
 176     # Return a boolean for succcess
 177     return $self->_result()->delete() ? 1 : 0;
 178 }
 179
 180 =head3 $object->set( $properties_hashref )
 181
 182 $object->set(
 183     {
 184         property1 => $property1,
 185         property2 => $property2,
 186         property3 => $propery3,
 187     }
 188 );
 189
 190 Enables multiple properties to be set at once
 191
 192 Returns:
 193     1      if all properties were set.
 194     0      if one or more properties do not exist.
 195     undef  if all properties exist but a different error
 196            prevents one or more properties from being set.
 197
 198 If one or more of the properties do not exist,
 199 no properties will be set.
 200
 201 =cut
 202
 203 sub set {
 204     my ( $self, $properties ) = @_;
 205
 206     my @columns = @{$self->_columns()};
 207
 208     foreach my $p ( keys %$properties ) {
 209         unless ( grep {/^$p$/} @columns ) {
 210             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 211         }
 212     }
 213
 214     return $self->_result()->set_columns($properties) ? $self : undef;
 215 }
 216
 217 =head3 $object->unblessed();
 218
 219 Returns an unblessed representation of object.
 220
 221 =cut
 222
 223 sub unblessed {
 224     my ($self) = @_;
 225
 226     return { $self->_result->get_columns };
 227 }
 228
 229 =head3 $object->get_from_storage;
 230
 231 =cut
 232
 233 sub get_from_storage {
 234     my ( $self, $attrs ) = @_;
 235     my $stored_object = $self->_result->get_from_storage($attrs);
 236     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 237     return $object_class->_new_from_dbic($stored_object);
 238 }
 239
 240 =head3 $object->TO_JSON
 241
 242 Returns an unblessed representation of the object, suitable for JSON output.
 243
 244 =cut
 245
 246 sub TO_JSON {
 247
 248     my ($self) = @_;
 249
 250     my $unblessed    = $self->unblessed;
 251     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 252         ->result_source->{_columns};
 253
 254     foreach my $col ( keys %{$columns_info} ) {
 255
 256         if ( $columns_info->{$col}->{is_boolean} )
 257         {    # Handle booleans gracefully
 258             $unblessed->{$col}
 259                 = ( $unblessed->{$col} )
 260                 ? Mojo::JSON->true
 261                 : Mojo::JSON->false;
 262         }
 263         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 264             and looks_like_number( $unblessed->{$col} )
 265         ) {
 266
 267             # TODO: Remove once the solution for
 268             # https://rt.cpan.org/Ticket/Display.html?id=119904
 269             # is ported to whatever distro we support by that time
 270             $unblessed->{$col} += 0;
 271         }
 272         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 273             eval {
 274                 return unless $unblessed->{$col};
 275                 $unblessed->{$col} = output_pref({
 276                     dateformat => 'rfc3339',
 277                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 278                 });
 279             };
 280         }
 281     }
 282     return $unblessed;
 283 }
 284
 285 sub _datetime_column_type {
 286     my ($column_type) = @_;
 287
 288     my @dt_types = (
 289         'timestamp',
 290         'datetime'
 291     );
 292
 293     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 294 }
 295
 296 sub _numeric_column_type {
 297     # TODO: Remove once the solution for
 298     # https://rt.cpan.org/Ticket/Display.html?id=119904
 299     # is ported to whatever distro we support by that time
 300     my ($column_type) = @_;
 301
 302     my @numeric_types = (
 303         'bigint',
 304         'integer',
 305         'int',
 306         'mediumint',
 307         'smallint',
 308         'tinyint',
 309         'decimal',
 310         'double precision',
 311         'float'
 312     );
 313
 314     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 315 }
 316
 317 =head3 $object->unblessed_all_relateds
 318
 319 my $everything_into_one_hashref = $object->unblessed_all_relateds
 320
 321 The unblessed method only retrieves column' values for the column of the object.
 322 In a *few* cases we want to retrieve the information of all the prefetched data.
 323
 324 =cut
 325
 326 sub unblessed_all_relateds {
 327     my ($self) = @_;
 328
 329     my %data;
 330     my $related_resultsets = $self->_result->{related_resultsets} || {};
 331     my $rs = $self->_result;
 332     while ( $related_resultsets and %$related_resultsets ) {
 333         my @relations = keys %{ $related_resultsets };
 334         if ( @relations ) {
 335             my $relation = $relations[0];
 336             $rs = $rs->related_resultset($relation)->get_cache;
 337             $rs = $rs->[0]; # Does it makes sense to have several values here?
 338             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 339             my $koha_object = $object_class->_new_from_dbic( $rs );
 340             $related_resultsets = $rs->{related_resultsets};
 341             %data = ( %data, %{ $koha_object->unblessed } );
 342         }
 343     }
 344     %data = ( %data, %{ $self->unblessed } );
 345     return \%data;
 346 }
 347
 348 =head3 $object->_result();
 349
 350 Returns the internal DBIC Row object
 351
 352 =cut
 353
 354 sub _result {
 355     my ($self) = @_;
 356
 357     # If we don't have a dbic row at this point, we need to create an empty one
 358     $self->{_result} ||=
 359       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 360
 361     return $self->{_result};
 362 }
 363
 364 =head3 $object->_columns();
 365
 366 Returns an arrayref of the table columns
 367
 368 =cut
 369
 370 sub _columns {
 371     my ($self) = @_;
 372
 373     # If we don't have a dbic row at this point, we need to create an empty one
 374     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 375
 376     return $self->{_columns};
 377 }
 378
 379 sub _get_object_class {
 380     my ( $type ) = @_;
 381     return unless $type;
 382
 383     if( $type->can('koha_object_class') ) {
 384         return $type->koha_object_class;
 385     }
 386     $type =~ s|Schema::Result::||;
 387     return ${type};
 388 }
 389
 390 =head3 AUTOLOAD
 391
 392 The autoload method is used only to get and set values for an objects properties.
 393
 394 =cut
 395
 396 sub AUTOLOAD {
 397     my $self = shift;
 398
 399     my $method = our $AUTOLOAD;
 400     $method =~ s/.*://;
 401
 402     my @columns = @{$self->_columns()};
 403     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 404     if ( grep {/^$method$/} @columns ) {
 405         if ( @_ ) {
 406             $self->_result()->set_column( $method, @_ );
 407             return $self;
 408         } else {
 409             my $value = $self->_result()->get_column( $method );
 410             return $value;
 411         }
 412     }
 413
 414     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 415
 416     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 417         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 418         show_trace => 1
 419     ) unless grep { /^$method$/ } @known_methods;
 420
 421
 422     my $r = eval { $self->_result->$method(@_) };
 423     if ( $@ ) {
 424         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 425     }
 426     return $r;
 427 }
 428
 429 =head3 _type
 430
 431 This method must be defined in the child class. The value is the name of the DBIC resultset.
 432 For example, for borrowers, the _type method will return "Borrower".
 433
 434 =cut
 435
 436 sub _type { }
 437
 438 sub DESTROY { }
 439
 440 =head1 AUTHOR
 441
 442 Kyle M Hall <kyle@bywatersolutions.com>
 443
 444 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 445
 446 =cut
 447
 448 1;