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 \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
 178                 my $type = $+{type};
 179                 my $value = $+{value};
 180                 my $property = $+{property};
 181                 $property =~ s/['`]//g;
 182                 Koha::Exceptions::Object::BadValue->throw(
 183                     type     => $type,
 184                     value    => $value,
 185                     property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
 186                 );
 187             }
 188         }
 189         # Catch-all for foreign key breakages. It will help find other use cases
 190         $_->rethrow();
 191     }
 192 }
 193
 194 =head3 $object->delete();
 195
 196 Removes the object from storage.
 197
 198 Returns:
 199     1  if the deletion was a success
 200     0  if the deletion failed
 201     -1 if the object was never in storage
 202
 203 =cut
 204
 205 sub delete {
 206     my ($self) = @_;
 207
 208     # Deleting something not in storage throws an exception
 209     return -1 unless $self->_result()->in_storage();
 210
 211     # Return a boolean for succcess
 212     return $self->_result()->delete() ? 1 : 0;
 213 }
 214
 215 =head3 $object->set( $properties_hashref )
 216
 217 $object->set(
 218     {
 219         property1 => $property1,
 220         property2 => $property2,
 221         property3 => $propery3,
 222     }
 223 );
 224
 225 Enables multiple properties to be set at once
 226
 227 Returns:
 228     1      if all properties were set.
 229     0      if one or more properties do not exist.
 230     undef  if all properties exist but a different error
 231            prevents one or more properties from being set.
 232
 233 If one or more of the properties do not exist,
 234 no properties will be set.
 235
 236 =cut
 237
 238 sub set {
 239     my ( $self, $properties ) = @_;
 240
 241     my @columns = @{$self->_columns()};
 242
 243     foreach my $p ( keys %$properties ) {
 244         unless ( grep {/^$p$/} @columns ) {
 245             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 246         }
 247     }
 248
 249     return $self->_result()->set_columns($properties) ? $self : undef;
 250 }
 251
 252 =head3 $object->unblessed();
 253
 254 Returns an unblessed representation of object.
 255
 256 =cut
 257
 258 sub unblessed {
 259     my ($self) = @_;
 260
 261     return { $self->_result->get_columns };
 262 }
 263
 264 =head3 $object->get_from_storage;
 265
 266 =cut
 267
 268 sub get_from_storage {
 269     my ( $self, $attrs ) = @_;
 270     my $stored_object = $self->_result->get_from_storage($attrs);
 271     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 272     return $object_class->_new_from_dbic($stored_object);
 273 }
 274
 275 =head3 $object->TO_JSON
 276
 277 Returns an unblessed representation of the object, suitable for JSON output.
 278
 279 =cut
 280
 281 sub TO_JSON {
 282
 283     my ($self) = @_;
 284
 285     my $unblessed    = $self->unblessed;
 286     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 287         ->result_source->{_columns};
 288
 289     foreach my $col ( keys %{$columns_info} ) {
 290
 291         if ( $columns_info->{$col}->{is_boolean} )
 292         {    # Handle booleans gracefully
 293             $unblessed->{$col}
 294                 = ( $unblessed->{$col} )
 295                 ? Mojo::JSON->true
 296                 : Mojo::JSON->false;
 297         }
 298         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 299             and looks_like_number( $unblessed->{$col} )
 300         ) {
 301
 302             # TODO: Remove once the solution for
 303             # https://rt.cpan.org/Ticket/Display.html?id=119904
 304             # is ported to whatever distro we support by that time
 305             $unblessed->{$col} += 0;
 306         }
 307         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 308             eval {
 309                 return unless $unblessed->{$col};
 310                 $unblessed->{$col} = output_pref({
 311                     dateformat => 'rfc3339',
 312                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 313                 });
 314             };
 315         }
 316     }
 317     return $unblessed;
 318 }
 319
 320 sub _date_or_datetime_column_type {
 321     my ($column_type) = @_;
 322
 323     my @dt_types = (
 324         'timestamp',
 325         'date',
 326         'datetime'
 327     );
 328
 329     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 330 }
 331 sub _datetime_column_type {
 332     my ($column_type) = @_;
 333
 334     my @dt_types = (
 335         'timestamp',
 336         'datetime'
 337     );
 338
 339     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 340 }
 341
 342 sub _numeric_column_type {
 343     # TODO: Remove once the solution for
 344     # https://rt.cpan.org/Ticket/Display.html?id=119904
 345     # is ported to whatever distro we support by that time
 346     my ($column_type) = @_;
 347
 348     my @numeric_types = (
 349         'bigint',
 350         'integer',
 351         'int',
 352         'mediumint',
 353         'smallint',
 354         'tinyint',
 355         'decimal',
 356         'double precision',
 357         'float'
 358     );
 359
 360     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 361 }
 362
 363 =head3 to_api
 364
 365     my $object_for_api = $object->to_api;
 366
 367 Returns a representation of the object, suitable for API output.
 368
 369 =cut
 370
 371 sub to_api {
 372     my ( $self ) = @_;
 373     my $json_object = $self->TO_JSON;
 374
 375     my $to_api_mapping = $self->to_api_mapping;
 376
 377     # Rename attributes if there's a mapping
 378     foreach my $column ( keys %{$to_api_mapping} ) {
 379         my $mapped_column = $to_api_mapping->{$column};
 380         if ( exists $json_object->{$column}
 381             && defined $mapped_column )
 382         {
 383             # key != undef
 384             $json_object->{$mapped_column} = delete $json_object->{$column};
 385         }
 386         elsif ( exists $json_object->{$column}
 387             && !defined $mapped_column )
 388         {
 389             # key == undef
 390             delete $json_object->{$column};
 391         }
 392     }
 393
 394     return $json_object;
 395 }
 396
 397 =head3 to_api_mapping
 398
 399     my $mapping = $object->to_api_mapping;
 400
 401 Generic method that returns the attribute name mappings required to
 402 render the object on the API.
 403
 404 Note: this only returns an empty I<hashref>. Each class should have its
 405 own mapping returned.
 406
 407 =cut
 408
 409 sub to_api_mapping {
 410     return {};
 411 }
 412
 413 =head3 from_api_mapping
 414
 415     my $mapping = $object->from_api_mapping;
 416
 417 Generic method that returns the attribute name mappings so the data that
 418 comes from the API is correctly renamed to match what is required for the DB.
 419
 420 =cut
 421
 422 sub from_api_mapping {
 423     my ( $self ) = @_;
 424
 425     my $to_api_mapping = $self->to_api_mapping;
 426
 427     unless ( $self->{_from_api_mapping} ) {
 428         while (my ($key, $value) = each %{ $to_api_mapping } ) {
 429             $self->{_from_api_mapping}->{$value} = $key
 430                 if defined $value;
 431         }
 432     }
 433
 434     return $self->{_from_api_mapping};
 435 }
 436
 437 =head3 $object->unblessed_all_relateds
 438
 439 my $everything_into_one_hashref = $object->unblessed_all_relateds
 440
 441 The unblessed method only retrieves column' values for the column of the object.
 442 In a *few* cases we want to retrieve the information of all the prefetched data.
 443
 444 =cut
 445
 446 sub unblessed_all_relateds {
 447     my ($self) = @_;
 448
 449     my %data;
 450     my $related_resultsets = $self->_result->{related_resultsets} || {};
 451     my $rs = $self->_result;
 452     while ( $related_resultsets and %$related_resultsets ) {
 453         my @relations = keys %{ $related_resultsets };
 454         if ( @relations ) {
 455             my $relation = $relations[0];
 456             $rs = $rs->related_resultset($relation)->get_cache;
 457             $rs = $rs->[0]; # Does it makes sense to have several values here?
 458             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 459             my $koha_object = $object_class->_new_from_dbic( $rs );
 460             $related_resultsets = $rs->{related_resultsets};
 461             %data = ( %data, %{ $koha_object->unblessed } );
 462         }
 463     }
 464     %data = ( %data, %{ $self->unblessed } );
 465     return \%data;
 466 }
 467
 468 =head3 $object->_result();
 469
 470 Returns the internal DBIC Row object
 471
 472 =cut
 473
 474 sub _result {
 475     my ($self) = @_;
 476
 477     # If we don't have a dbic row at this point, we need to create an empty one
 478     $self->{_result} ||=
 479       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 480
 481     return $self->{_result};
 482 }
 483
 484 =head3 $object->_columns();
 485
 486 Returns an arrayref of the table columns
 487
 488 =cut
 489
 490 sub _columns {
 491     my ($self) = @_;
 492
 493     # If we don't have a dbic row at this point, we need to create an empty one
 494     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 495
 496     return $self->{_columns};
 497 }
 498
 499 sub _get_object_class {
 500     my ( $type ) = @_;
 501     return unless $type;
 502
 503     if( $type->can('koha_object_class') ) {
 504         return $type->koha_object_class;
 505     }
 506     $type =~ s|Schema::Result::||;
 507     return ${type};
 508 }
 509
 510 =head3 AUTOLOAD
 511
 512 The autoload method is used only to get and set values for an objects properties.
 513
 514 =cut
 515
 516 sub AUTOLOAD {
 517     my $self = shift;
 518
 519     my $method = our $AUTOLOAD;
 520     $method =~ s/.*://;
 521
 522     my @columns = @{$self->_columns()};
 523     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 524     if ( grep {/^$method$/} @columns ) {
 525         if ( @_ ) {
 526             $self->_result()->set_column( $method, @_ );
 527             return $self;
 528         } else {
 529             my $value = $self->_result()->get_column( $method );
 530             return $value;
 531         }
 532     }
 533
 534     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 535
 536     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 537         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 538         show_trace => 1
 539     ) unless grep { /^$method$/ } @known_methods;
 540
 541
 542     my $r = eval { $self->_result->$method(@_) };
 543     if ( $@ ) {
 544         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 545     }
 546     return $r;
 547 }
 548
 549 =head3 attributes_from_api
 550
 551     my $attributes = attributes_from_api( $params );
 552
 553 Returns the passed params, converted from API naming into the model.
 554
 555 =cut
 556
 557 sub attributes_from_api {
 558     my ( $self, $attributes ) = @_;
 559
 560     my $mapping = $self->from_api_mapping;
 561
 562     foreach my $attribute ( keys %{$mapping} ) {
 563         my $mapped_attribute = $mapping->{$attribute};
 564         if ( exists $attributes->{$attribute}
 565             && defined $mapped_attribute )
 566         {
 567             # key => !undef
 568             $attributes->{$mapped_attribute} = delete $attributes->{$attribute};
 569         }
 570         elsif ( exists $attributes->{$attribute}
 571             && !defined $mapped_attribute )
 572         {
 573             # key => undef / to be deleted
 574             delete $attributes->{$attribute};
 575         }
 576     }
 577
 578     return $attributes;
 579 }
 580
 581 =head3 _type
 582
 583 This method must be defined in the child class. The value is the name of the DBIC resultset.
 584 For example, for borrowers, the _type method will return "Borrower".
 585
 586 =cut
 587
 588 sub _type { }
 589
 590 sub DESTROY { }
 591
 592 =head1 AUTHOR
 593
 594 Kyle M Hall <kyle@bywatersolutions.com>
 595
 596 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 597
 598 =cut
 599
 600 1;