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