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     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 125         ->result_source->{_columns};
 126
 127     # Handle not null and default values for integers and dates
 128     foreach my $col ( keys %{$columns_info} ) {
 129         # Integers
 130         if ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
 131             # Has been passed but not a number, usually an empty string
 132             if ( defined $self->$col and not looks_like_number( $self->$col ) ) {
 133                 if ( $columns_info->{$col}->{is_nullable} ) {
 134                     # If nullable, default to null
 135                     $self->$col(undef);
 136                 } else {
 137                     # If cannot be null, get the default value
 138                     # What if cannot be null and does not have a default value? Possible?
 139                     $self->$col($columns_info->{$col}->{default_value});
 140                 }
 141             }
 142         }
 143         elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 144             # Set to null if an empty string (or == 0 but should not happen)
 145             $self->$col(undef) unless $self->$col;
 146         }
 147     }
 148
 149     try {
 150         return $self->_result()->update_or_insert() ? $self : undef;
 151     }
 152     catch {
 153         # Catch problems and raise relevant exceptions
 154         if (ref($_) eq 'DBIx::Class::Exception') {
 155             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 156                 # FK constraints
 157                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 158                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 159                     Koha::Exceptions::Object::FKConstraint->throw(
 160                         error     => 'Broken FK constraint',
 161                         broken_fk => $+{column}
 162                     );
 163                 }
 164             }
 165             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 166                 Koha::Exceptions::Object::DuplicateID->throw(
 167                     error => 'Duplicate ID',
 168                     duplicate_id => $+{key}
 169                 );
 170             }
 171             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column '(?<property>\w+)'/ ) {
 172                 Koha::Exceptions::Object::BadValue->throw(
 173                     type     => $+{type},
 174                     value    => $+{value},
 175                     property => $+{property}
 176                 );
 177             }
 178         }
 179         # Catch-all for foreign key breakages. It will help find other use cases
 180         $_->rethrow();
 181     }
 182 }
 183
 184 =head3 $object->delete();
 185
 186 Removes the object from storage.
 187
 188 Returns:
 189     1  if the deletion was a success
 190     0  if the deletion failed
 191     -1 if the object was never in storage
 192
 193 =cut
 194
 195 sub delete {
 196     my ($self) = @_;
 197
 198     # Deleting something not in storage throws an exception
 199     return -1 unless $self->_result()->in_storage();
 200
 201     # Return a boolean for succcess
 202     return $self->_result()->delete() ? 1 : 0;
 203 }
 204
 205 =head3 $object->set( $properties_hashref )
 206
 207 $object->set(
 208     {
 209         property1 => $property1,
 210         property2 => $property2,
 211         property3 => $propery3,
 212     }
 213 );
 214
 215 Enables multiple properties to be set at once
 216
 217 Returns:
 218     1      if all properties were set.
 219     0      if one or more properties do not exist.
 220     undef  if all properties exist but a different error
 221            prevents one or more properties from being set.
 222
 223 If one or more of the properties do not exist,
 224 no properties will be set.
 225
 226 =cut
 227
 228 sub set {
 229     my ( $self, $properties ) = @_;
 230
 231     my @columns = @{$self->_columns()};
 232
 233     foreach my $p ( keys %$properties ) {
 234         unless ( grep {/^$p$/} @columns ) {
 235             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 236         }
 237     }
 238
 239     return $self->_result()->set_columns($properties) ? $self : undef;
 240 }
 241
 242 =head3 $object->unblessed();
 243
 244 Returns an unblessed representation of object.
 245
 246 =cut
 247
 248 sub unblessed {
 249     my ($self) = @_;
 250
 251     return { $self->_result->get_columns };
 252 }
 253
 254 =head3 $object->get_from_storage;
 255
 256 =cut
 257
 258 sub get_from_storage {
 259     my ( $self, $attrs ) = @_;
 260     my $stored_object = $self->_result->get_from_storage($attrs);
 261     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 262     return $object_class->_new_from_dbic($stored_object);
 263 }
 264
 265 =head3 $object->TO_JSON
 266
 267 Returns an unblessed representation of the object, suitable for JSON output.
 268
 269 =cut
 270
 271 sub TO_JSON {
 272
 273     my ($self) = @_;
 274
 275     my $unblessed    = $self->unblessed;
 276     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 277         ->result_source->{_columns};
 278
 279     foreach my $col ( keys %{$columns_info} ) {
 280
 281         if ( $columns_info->{$col}->{is_boolean} )
 282         {    # Handle booleans gracefully
 283             $unblessed->{$col}
 284                 = ( $unblessed->{$col} )
 285                 ? Mojo::JSON->true
 286                 : Mojo::JSON->false;
 287         }
 288         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 289             and looks_like_number( $unblessed->{$col} )
 290         ) {
 291
 292             # TODO: Remove once the solution for
 293             # https://rt.cpan.org/Ticket/Display.html?id=119904
 294             # is ported to whatever distro we support by that time
 295             $unblessed->{$col} += 0;
 296         }
 297         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 298             eval {
 299                 return unless $unblessed->{$col};
 300                 $unblessed->{$col} = output_pref({
 301                     dateformat => 'rfc3339',
 302                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 303                 });
 304             };
 305         }
 306     }
 307     return $unblessed;
 308 }
 309
 310 sub _date_or_datetime_column_type {
 311     my ($column_type) = @_;
 312
 313     my @dt_types = (
 314         'timestamp',
 315         'date',
 316         'datetime'
 317     );
 318
 319     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 320 }
 321 sub _datetime_column_type {
 322     my ($column_type) = @_;
 323
 324     my @dt_types = (
 325         'timestamp',
 326         'datetime'
 327     );
 328
 329     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 330 }
 331
 332 sub _numeric_column_type {
 333     # TODO: Remove once the solution for
 334     # https://rt.cpan.org/Ticket/Display.html?id=119904
 335     # is ported to whatever distro we support by that time
 336     my ($column_type) = @_;
 337
 338     my @numeric_types = (
 339         'bigint',
 340         'integer',
 341         'int',
 342         'mediumint',
 343         'smallint',
 344         'tinyint',
 345         'decimal',
 346         'double precision',
 347         'float'
 348     );
 349
 350     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 351 }
 352
 353 =head3 $object->unblessed_all_relateds
 354
 355 my $everything_into_one_hashref = $object->unblessed_all_relateds
 356
 357 The unblessed method only retrieves column' values for the column of the object.
 358 In a *few* cases we want to retrieve the information of all the prefetched data.
 359
 360 =cut
 361
 362 sub unblessed_all_relateds {
 363     my ($self) = @_;
 364
 365     my %data;
 366     my $related_resultsets = $self->_result->{related_resultsets} || {};
 367     my $rs = $self->_result;
 368     while ( $related_resultsets and %$related_resultsets ) {
 369         my @relations = keys %{ $related_resultsets };
 370         if ( @relations ) {
 371             my $relation = $relations[0];
 372             $rs = $rs->related_resultset($relation)->get_cache;
 373             $rs = $rs->[0]; # Does it makes sense to have several values here?
 374             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 375             my $koha_object = $object_class->_new_from_dbic( $rs );
 376             $related_resultsets = $rs->{related_resultsets};
 377             %data = ( %data, %{ $koha_object->unblessed } );
 378         }
 379     }
 380     %data = ( %data, %{ $self->unblessed } );
 381     return \%data;
 382 }
 383
 384 =head3 $object->_result();
 385
 386 Returns the internal DBIC Row object
 387
 388 =cut
 389
 390 sub _result {
 391     my ($self) = @_;
 392
 393     # If we don't have a dbic row at this point, we need to create an empty one
 394     $self->{_result} ||=
 395       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 396
 397     return $self->{_result};
 398 }
 399
 400 =head3 $object->_columns();
 401
 402 Returns an arrayref of the table columns
 403
 404 =cut
 405
 406 sub _columns {
 407     my ($self) = @_;
 408
 409     # If we don't have a dbic row at this point, we need to create an empty one
 410     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 411
 412     return $self->{_columns};
 413 }
 414
 415 sub _get_object_class {
 416     my ( $type ) = @_;
 417     return unless $type;
 418
 419     if( $type->can('koha_object_class') ) {
 420         return $type->koha_object_class;
 421     }
 422     $type =~ s|Schema::Result::||;
 423     return ${type};
 424 }
 425
 426 =head3 AUTOLOAD
 427
 428 The autoload method is used only to get and set values for an objects properties.
 429
 430 =cut
 431
 432 sub AUTOLOAD {
 433     my $self = shift;
 434
 435     my $method = our $AUTOLOAD;
 436     $method =~ s/.*://;
 437
 438     my @columns = @{$self->_columns()};
 439     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 440     if ( grep {/^$method$/} @columns ) {
 441         if ( @_ ) {
 442             $self->_result()->set_column( $method, @_ );
 443             return $self;
 444         } else {
 445             my $value = $self->_result()->get_column( $method );
 446             return $value;
 447         }
 448     }
 449
 450     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 451
 452     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 453         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 454         show_trace => 1
 455     ) unless grep { /^$method$/ } @known_methods;
 456
 457
 458     my $r = eval { $self->_result->$method(@_) };
 459     if ( $@ ) {
 460         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 461     }
 462     return $r;
 463 }
 464
 465 =head3 _type
 466
 467 This method must be defined in the child class. The value is the name of the DBIC resultset.
 468 For example, for borrowers, the _type method will return "Borrower".
 469
 470 =cut
 471
 472 sub _type { }
 473
 474 sub DESTROY { }
 475
 476 =head1 AUTHOR
 477
 478 Kyle M Hall <kyle@bywatersolutions.com>
 479
 480 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 481
 482 =cut
 483
 484 1;