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
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 use Modern::Perl;
  22
  23 use Carp qw( croak );
  24 use Mojo::JSON;
  25 use Scalar::Util qw( blessed looks_like_number );
  26 use Try::Tiny qw( catch try );
  27 use List::MoreUtils qw( any );
  28 use DateTime::Format::MySQL;
  29
  30 use Koha::Database;
  31 use Koha::DateTime::Format::RFC3339;
  32 use Koha::DateTime::Format::SQL;
  33 use Koha::Exceptions::Object;
  34 use Koha::Object::Message;
  35
  36 =head1 NAME
  37
  38 Koha::Object - Koha Object base class
  39
  40 =head1 SYNOPSIS
  41
  42     use Koha::Object;
  43     my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
  44
  45 =head1 DESCRIPTION
  46
  47 This class must always be subclassed.
  48
  49 =head1 API
  50
  51 =head2 Class Methods
  52
  53 =cut
  54
  55 =head3 Koha::Object->new();
  56
  57 my $object = Koha::Object->new();
  58 my $object = Koha::Object->new($attributes);
  59
  60 Note that this cannot be used to retrieve record from the DB.
  61
  62 =cut
  63
  64 sub new {
  65     my ( $class, $attributes ) = @_;
  66     my $self = {};
  67
  68     if ($attributes) {
  69         my $schema = Koha::Database->new->schema;
  70
  71         # Remove the arguments which exist, are not defined but NOT NULL to use the default value
  72         my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
  73         for my $column_name ( keys %$attributes ) {
  74             my $c_info = $columns_info->{$column_name};
  75             next if $c_info->{is_nullable};
  76             next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
  77             delete $attributes->{$column_name};
  78         }
  79
  80         $self->{_result} =
  81           $schema->resultset( $class->_type() )->new($attributes);
  82     }
  83
  84     $self->{_messages} = [];
  85
  86     croak("No _type found! Koha::Object must be subclassed!")
  87       unless $class->_type();
  88
  89     bless( $self, $class );
  90
  91 }
  92
  93 =head3 Koha::Object->_new_from_dbic();
  94
  95 my $object = Koha::Object->_new_from_dbic($dbic_row);
  96
  97 =cut
  98
  99 sub _new_from_dbic {
 100     my ( $class, $dbic_row ) = @_;
 101     my $self = {};
 102
 103     # DBIC result row
 104     $self->{_result} = $dbic_row;
 105
 106     croak("No _type found! Koha::Object must be subclassed!")
 107       unless $class->_type();
 108
 109     croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
 110       unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
 111
 112     bless( $self, $class );
 113
 114 }
 115
 116 =head3 $object->store();
 117
 118 Saves the object in storage.
 119 If the object is new, it will be created.
 120 If the object previously existed, it will be updated.
 121
 122 Returns:
 123     $self  if the store was a success
 124     undef  if the store failed
 125
 126 =cut
 127
 128 sub store {
 129     my ($self) = @_;
 130
 131     my $columns_info = $self->_result->result_source->columns_info;
 132
 133     # Handle not null and default values for integers and dates
 134     foreach my $col ( keys %{$columns_info} ) {
 135         # Integers
 136         if (   _numeric_column_type( $columns_info->{$col}->{data_type} )
 137             or _decimal_column_type( $columns_info->{$col}->{data_type} )
 138         ) {
 139             # Has been passed but not a number, usually an empty string
 140             my $value = $self->_result()->get_column($col);
 141             if ( defined $value and not looks_like_number( $value ) ) {
 142                 if ( $columns_info->{$col}->{is_nullable} ) {
 143                     # If nullable, default to null
 144                     $self->_result()->set_column($col => undef);
 145                 } else {
 146                     # If cannot be null, get the default value
 147                     # What if cannot be null and does not have a default value? Possible?
 148                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 149                 }
 150             }
 151         }
 152         elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 153             # Set to null if an empty string (or == 0 but should not happen)
 154             my $value = $self->_result()->get_column($col);
 155             if ( defined $value and not $value ) {
 156                 if ( $columns_info->{$col}->{is_nullable} ) {
 157                     $self->_result()->set_column($col => undef);
 158                 } else {
 159                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 160                 }
 161             }
 162             elsif ( not defined $self->$col
 163                   && $columns_info->{$col}->{datetime_undef_if_invalid} )
 164               {
 165                   # timestamp
 166                   $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 167               }
 168         }
 169     }
 170
 171     try {
 172         return $self->_result()->update_or_insert() ? $self : undef;
 173     }
 174     catch {
 175         # Catch problems and raise relevant exceptions
 176         if (ref($_) eq 'DBIx::Class::Exception') {
 177             warn $_->{msg};
 178             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 179                 # FK constraints
 180                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 181                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 182                     Koha::Exceptions::Object::FKConstraint->throw(
 183                         error     => 'Broken FK constraint',
 184                         broken_fk => $+{column}
 185                     );
 186                 }
 187             }
 188             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 189                 Koha::Exceptions::Object::DuplicateID->throw(
 190                     error => 'Duplicate ID',
 191                     duplicate_id => $+{key}
 192                 );
 193             }
 194             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
 195                 my $type = $+{type};
 196                 my $value = $+{value};
 197                 my $property = $+{property};
 198                 $property =~ s/['`]//g;
 199                 Koha::Exceptions::Object::BadValue->throw(
 200                     type     => $type,
 201                     value    => $value,
 202                     property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
 203                 );
 204             }
 205         }
 206         # Catch-all for foreign key breakages. It will help find other use cases
 207         $_->rethrow();
 208     }
 209 }
 210
 211 =head3 $object->update();
 212
 213 A shortcut for set + store in one call.
 214
 215 =cut
 216
 217 sub update {
 218     my ($self, $values) = @_;
 219     Koha::Exceptions::Object::NotInStorage->throw unless $self->in_storage;
 220     $self->set($values)->store();
 221 }
 222
 223 =head3 $object->delete();
 224
 225 Removes the object from storage.
 226
 227 Returns:
 228     The item object if deletion was a success
 229     The DBIX::Class error if deletion failed
 230
 231 =cut
 232
 233 sub delete {
 234     my ($self) = @_;
 235
 236     my $deleted = $self->_result()->delete;
 237     if ( ref $deleted ) {
 238         my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 239         $deleted = $object_class->_new_from_dbic($deleted);
 240     }
 241     return $deleted;
 242 }
 243
 244 =head3 $object->set( $properties_hashref )
 245
 246 $object->set(
 247     {
 248         property1 => $property1,
 249         property2 => $property2,
 250         property3 => $propery3,
 251     }
 252 );
 253
 254 Enables multiple properties to be set at once
 255
 256 Returns:
 257     1      if all properties were set.
 258     0      if one or more properties do not exist.
 259     undef  if all properties exist but a different error
 260            prevents one or more properties from being set.
 261
 262 If one or more of the properties do not exist,
 263 no properties will be set.
 264
 265 =cut
 266
 267 sub set {
 268     my ( $self, $properties ) = @_;
 269
 270     my @columns = @{$self->_columns()};
 271
 272     foreach my $p ( keys %$properties ) {
 273         unless ( grep { $_ eq $p } @columns ) {
 274             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 275         }
 276     }
 277
 278     return $self->_result()->set_columns($properties) ? $self : undef;
 279 }
 280
 281 =head3 $object->set_or_blank( $properties_hashref )
 282
 283 $object->set_or_blank(
 284     {
 285         property1 => $property1,
 286         property2 => $property2,
 287         property3 => $propery3,
 288     }
 289 );
 290
 291 If not listed in $properties_hashref, the property will be set to the default
 292 value defined at DB level, or nulled.
 293
 294 =cut
 295
 296
 297 sub set_or_blank {
 298     my ( $self, $properties ) = @_;
 299
 300     my $columns_info = $self->_result->result_source->columns_info;
 301
 302     foreach my $col ( keys %{$columns_info} ) {
 303
 304         next if exists $properties->{$col};
 305
 306         if ( $columns_info->{$col}->{is_nullable} ) {
 307             $properties->{$col} = undef;
 308         } else {
 309             $properties->{$col} = $columns_info->{$col}->{default_value};
 310         }
 311     }
 312
 313     return $self->set($properties);
 314 }
 315
 316 =head3 $object->unblessed();
 317
 318 Returns an unblessed representation of object.
 319
 320 =cut
 321
 322 sub unblessed {
 323     my ($self) = @_;
 324
 325     return { $self->_result->get_columns };
 326 }
 327
 328 =head3 $object->get_from_storage;
 329
 330 =cut
 331
 332 sub get_from_storage {
 333     my ( $self, $attrs ) = @_;
 334     my $stored_object = $self->_result->get_from_storage($attrs);
 335     return unless $stored_object;
 336     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 337     return $object_class->_new_from_dbic($stored_object);
 338 }
 339
 340 =head3 $object->object_messages
 341
 342     my @messages = @{ $object->object_messages };
 343
 344 Returns the (probably non-fatal) messages that were recorded on the object.
 345
 346 =cut
 347
 348 sub object_messages {
 349     my ( $self ) = @_;
 350
 351     $self->{_messages} = []
 352         unless defined $self->{_messages};
 353
 354     return $self->{_messages};
 355 }
 356
 357 =head3 $object->add_message
 358
 359     try {
 360         <some action that might fail>
 361     }
 362     catch {
 363         if ( <fatal condition> ) {
 364             Koha::Exception->throw...
 365         }
 366
 367         # This is a non fatal error, notify the caller
 368         $self->add_message({ message => $error, type => 'error' });
 369     }
 370     return $self;
 371
 372 Adds a message.
 373
 374 =cut
 375
 376 sub add_message {
 377     my ( $self, $params ) = @_;
 378
 379     push @{ $self->{_messages} }, Koha::Object::Message->new($params);
 380
 381     return $self;
 382 }
 383
 384 =head3 $object->TO_JSON
 385
 386 Returns an unblessed representation of the object, suitable for JSON output.
 387
 388 =cut
 389
 390 sub TO_JSON {
 391
 392     my ($self) = @_;
 393
 394     my $unblessed    = $self->unblessed;
 395     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 396         ->result_source->{_columns};
 397
 398     foreach my $col ( keys %{$columns_info} ) {
 399
 400         if ( $columns_info->{$col}->{is_boolean} )
 401         {    # Handle booleans gracefully
 402             $unblessed->{$col}
 403                 = ( $unblessed->{$col} )
 404                 ? Mojo::JSON->true
 405                 : Mojo::JSON->false;
 406         }
 407         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 408             and looks_like_number( $unblessed->{$col} )
 409         ) {
 410             # TODO: Remove once the solution for
 411             # https://github.com/perl5-dbi/DBD-mysql/issues/212
 412             # is ported to whatever distro we support by that time
 413             # or we move to DBD::MariaDB
 414             $unblessed->{$col} += 0;
 415         }
 416         elsif ( _decimal_column_type( $columns_info->{$col}->{data_type} )
 417             and looks_like_number( $unblessed->{$col} )
 418         ) {
 419             # TODO: Remove once the solution for
 420             # https://github.com/perl5-dbi/DBD-mysql/issues/212
 421             # is ported to whatever distro we support by that time
 422             # or we move to DBD::MariaDB
 423             $unblessed->{$col} += 0.00;
 424         }
 425         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 426             eval {
 427                 return unless $unblessed->{$col};
 428                 my $dt = Koha::DateTime::Format::SQL->parse_datetime( $unblessed->{$col} );
 429                 $unblessed->{$col} = Koha::DateTime::Format::RFC3339->format_datetime($dt);
 430             };
 431         }
 432     }
 433     return $unblessed;
 434 }
 435
 436 sub _date_or_datetime_column_type {
 437     my ($column_type) = @_;
 438
 439     my @dt_types = (
 440         'timestamp',
 441         'date',
 442         'datetime'
 443     );
 444
 445     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 446 }
 447 sub _datetime_column_type {
 448     my ($column_type) = @_;
 449
 450     my @dt_types = (
 451         'timestamp',
 452         'datetime'
 453     );
 454
 455     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 456 }
 457
 458 sub _numeric_column_type {
 459     # TODO: Remove once the solution for
 460     # https://github.com/perl5-dbi/DBD-mysql/issues/212
 461     # is ported to whatever distro we support by that time
 462     # or we move to DBD::MariaDB
 463     my ($column_type) = @_;
 464
 465     my @numeric_types = (
 466         'bigint',
 467         'integer',
 468         'int',
 469         'mediumint',
 470         'smallint',
 471         'tinyint',
 472     );
 473
 474     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 475 }
 476
 477 sub _decimal_column_type {
 478     # TODO: Remove once the solution for
 479     # https://github.com/perl5-dbi/DBD-mysql/issues/212
 480     # is ported to whatever distro we support by that time
 481     # or we move to DBD::MariaDB
 482     my ($column_type) = @_;
 483
 484     my @decimal_types = (
 485         'decimal',
 486         'double precision',
 487         'float'
 488     );
 489
 490     return ( grep { $column_type eq $_ } @decimal_types) ? 1 : 0;
 491 }
 492
 493 =head3 prefetch_whitelist
 494
 495     my $whitelist = $object->prefetch_whitelist()
 496
 497 Returns a hash of prefetchable subs and the type they return.
 498
 499 =cut
 500
 501 sub prefetch_whitelist {
 502     my ( $self ) = @_;
 503
 504     my $whitelist = {};
 505     my $relations = $self->_result->result_source->_relationships;
 506
 507     foreach my $key (keys %{$relations}) {
 508         if($self->can($key)) {
 509             my $result_class = $relations->{$key}->{class};
 510             my $obj = $result_class->new;
 511             try {
 512                 $whitelist->{$key} = Koha::Object::_get_object_class( $obj->result_class );
 513             } catch {
 514                 $whitelist->{$key} = undef;
 515             }
 516         }
 517     }
 518
 519     return $whitelist;
 520 }
 521
 522 =head3 to_api
 523
 524     my $object_for_api = $object->to_api(
 525         {
 526           [ embed => {
 527                 items => {
 528                     children => {
 529                         holds => {,
 530                             children => {
 531                               ...
 532                             }
 533                         }
 534                     }
 535                 },
 536                 library => {
 537                     ...
 538                 }
 539             },
 540             public => 0|1,
 541             ...
 542          ]
 543         }
 544     );
 545
 546 Returns a representation of the object, suitable for API output.
 547
 548 =cut
 549
 550 sub to_api {
 551     my ( $self, $params ) = @_;
 552
 553     my $json_object = $self->TO_JSON;
 554
 555     # Make sure we duplicate the $params variable to avoid
 556     # breaking calls in a loop (Koha::Objects->to_api)
 557     $params = defined $params ? {%$params} : {};
 558
 559     # children should be able to handle without
 560     my $embeds  = delete $params->{embed};
 561     my $strings = delete $params->{strings};
 562
 563     # coded values handling
 564     my $string_map = {};
 565     if ( $strings and $self->can('strings_map') ) {
 566         $string_map = $self->strings_map($params);
 567     }
 568
 569     # Remove forbidden attributes if required (including their coded values)
 570     if ( $params->{public} ) {
 571         for my $field ( keys %{$json_object} ) {
 572             delete $json_object->{$field}
 573               unless any { $_ eq $field } @{ $self->public_read_list };
 574         }
 575
 576         if ($strings) {
 577             foreach my $field ( keys %{$string_map} ) {
 578                 delete $string_map->{$field}
 579                   unless any { $_ eq $field } @{ $self->public_read_list };
 580             }
 581         }
 582     }
 583
 584     # Remove forbidden attributes if required (including their coded values)
 585     if ( !$self->is_accessible($params) ) {
 586         for my $field ( keys %{$json_object} ) {
 587             unless ( any { $_ eq $field } @{ $self->unredact_list } ) {
 588                 $json_object->{$field} = undef;
 589             }
 590         }
 591
 592         if ($strings) {
 593             foreach my $field ( keys %{$string_map} ) {
 594                 unless ( any { $_ eq $field } @{ $self->unredact_list } ) {
 595                     $string_map->{$field} = undef;
 596                 }
 597             }
 598         }
 599     }
 600
 601     my $to_api_mapping = $self->to_api_mapping;
 602
 603     # Rename attributes and coded values if there's a mapping
 604     if ( $self->can('to_api_mapping') ) {
 605         foreach my $column ( keys %{ $self->to_api_mapping } ) {
 606             my $mapped_column = $self->to_api_mapping->{$column};
 607             if ( exists $json_object->{$column}
 608                 && defined $mapped_column )
 609             {
 610
 611                 # key != undef
 612                 $json_object->{$mapped_column} = delete $json_object->{$column};
 613                 $string_map->{$mapped_column}  = delete $string_map->{$column}
 614                   if exists $string_map->{$column};
 615
 616             }
 617             elsif ( exists $json_object->{$column}
 618                 && !defined $mapped_column )
 619             {
 620
 621                 # key == undef
 622                 delete $json_object->{$column};
 623                 delete $string_map->{$column};
 624             }
 625         }
 626     }
 627
 628     $json_object->{_strings} = $string_map
 629       if $strings;
 630
 631     if ($embeds) {
 632         foreach my $embed ( keys %{$embeds} ) {
 633             if (    $embed =~ m/^(?<relation>.*)_count$/
 634                 and $embeds->{$embed}->{is_count} )
 635             {
 636
 637                 my $relation = $+{relation};
 638                 $json_object->{$embed} = $self->$relation->count;
 639             }
 640             else {
 641                 my $curr = $embed;
 642                 my $next = $embeds->{$curr}->{children};
 643
 644                 $params->{strings} = 1
 645                   if $embeds->{$embed}->{strings};
 646
 647                 my $children = $self->$curr;
 648
 649                 if ( defined $children and ref($children) eq 'ARRAY' ) {
 650                     my @list = map {
 651                         $self->_handle_to_api_child(
 652                             {
 653                                 child  => $_,
 654                                 next   => $next,
 655                                 curr   => $curr,
 656                                 params => $params
 657                             }
 658                         )
 659                     } @{$children};
 660                     $json_object->{$curr} = \@list;
 661                 }
 662                 else {
 663                     $json_object->{$curr} = $self->_handle_to_api_child(
 664                         {
 665                             child  => $children,
 666                             next   => $next,
 667                             curr   => $curr,
 668                             params => $params
 669                         }
 670                     );
 671                 }
 672             }
 673         }
 674     }
 675
 676     return $json_object;
 677 }
 678
 679 =head3 to_api_mapping
 680
 681     my $mapping = $object->to_api_mapping;
 682
 683 Generic method that returns the attribute name mappings required to
 684 render the object on the API.
 685
 686 Note: this only returns an empty I<hashref>. Each class should have its
 687 own mapping returned.
 688
 689 =cut
 690
 691 sub to_api_mapping {
 692     return {};
 693 }
 694
 695 =head3 strings_map
 696
 697     my $string_map = $object->strings_map($params);
 698
 699 Generic method that returns the string map for coded attributes.
 700
 701 Return should be a hashref keyed on database field name with the values
 702 being hashrefs containing 'str', 'type' and optionally 'category'.
 703
 704 This is then used in to_api to render the _strings embed when requested.
 705
 706 Note: this only returns an empty I<hashref>. Each class should have its
 707 own mapping returned.
 708
 709 =cut
 710
 711 sub strings_map {
 712     return {};
 713 }
 714
 715 =head3 public_read_list
 716
 717
 718     my @public_read_list = @{$object->public_read_list};
 719
 720 Generic method that returns the list of database columns that are allowed to
 721 be passed to render objects on the public API.
 722
 723 Note: this only returns an empty I<arrayref>. Each class should have its
 724 own implementation.
 725
 726 =cut
 727
 728 sub public_read_list
 729  {
 730     return [];
 731 }
 732
 733 =head3 unredact_list
 734
 735     my @unredact_list = @{$object->unredact_list};
 736
 737 Generic method that returns the list of database columns that are allowed to
 738 be passed to render objects on the API when the user making the request should
 739 not ordinarily have unrestricted access to the data (as returned by the is_accesible method).
 740
 741 Note: this only returns an empty I<arrayref>. Each class should have its
 742 own implementation.
 743
 744 =cut
 745
 746 sub unredact_list {
 747     return [];
 748 }
 749
 750 =head3 from_api_mapping
 751
 752     my $mapping = $object->from_api_mapping;
 753
 754 Generic method that returns the attribute name mappings so the data that
 755 comes from the API is correctly renamed to match what is required for the DB.
 756
 757 =cut
 758
 759 sub from_api_mapping {
 760     my ( $self ) = @_;
 761
 762     my $to_api_mapping = $self->to_api_mapping;
 763
 764     unless ( defined $self->{_from_api_mapping} ) {
 765         $self->{_from_api_mapping} = {};
 766         while (my ($key, $value) = each %{ $to_api_mapping } ) {
 767             $self->{_from_api_mapping}->{$value} = $key
 768                 if defined $value;
 769         }
 770     }
 771
 772     return $self->{_from_api_mapping};
 773 }
 774
 775 =head3 new_from_api
 776
 777     my $object = Koha::Object->new_from_api;
 778     my $object = Koha::Object->new_from_api( $attrs );
 779
 780 Creates a new object, mapping the API attribute names to the ones on the DB schema.
 781
 782 =cut
 783
 784 sub new_from_api {
 785     my ( $class, $params ) = @_;
 786
 787     my $self = $class->new;
 788     return $self->set_from_api( $params );
 789 }
 790
 791 =head3 set_from_api
 792
 793     my $object = Koha::Object->new(...);
 794     $object->set_from_api( $attrs )
 795
 796 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
 797
 798 =cut
 799
 800 sub set_from_api {
 801     my ( $self, $from_api_params ) = @_;
 802
 803     return $self->set( $self->attributes_from_api( $from_api_params ) );
 804 }
 805
 806 =head3 attributes_from_api
 807
 808     my $attributes = attributes_from_api( $params );
 809
 810 Returns the passed params, converted from API naming into the model.
 811
 812 =cut
 813
 814 sub attributes_from_api {
 815     my ( $self, $from_api_params ) = @_;
 816
 817     my $from_api_mapping = $self->from_api_mapping;
 818
 819     my $params;
 820     my $columns_info = $self->_result->result_source->columns_info;
 821     my $dtf          = $self->_result->result_source->storage->datetime_parser;
 822
 823     while (my ($key, $value) = each %{ $from_api_params } ) {
 824         my $koha_field_name =
 825           exists $from_api_mapping->{$key}
 826           ? $from_api_mapping->{$key}
 827           : $key;
 828
 829         if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
 830             # TODO: Remove when D8 is formally deprecated
 831             # Handle booleans gracefully
 832             $value = ( $value ) ? 1 : 0;
 833         }
 834         elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
 835             if (defined $value) {
 836                 try {
 837                     if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
 838                         my $dt = DateTime::Format::MySQL->parse_date($value);
 839                         $value = $dtf->format_date($dt);
 840                     }
 841                     else {
 842                         my $dt = Koha::DateTime::Format::RFC3339->parse_datetime($value);
 843                         $value = $dtf->format_datetime($dt);
 844                     }
 845                 }
 846                 catch {
 847                     Koha::Exceptions::BadParameter->throw( parameter => $key );
 848                 };
 849             }
 850         }
 851
 852         $params->{$koha_field_name} = $value;
 853     }
 854
 855     return $params;
 856 }
 857
 858 =head3 $object->unblessed_all_relateds
 859
 860 my $everything_into_one_hashref = $object->unblessed_all_relateds
 861
 862 The unblessed method only retrieves column' values for the column of the object.
 863 In a *few* cases we want to retrieve the information of all the prefetched data.
 864
 865 =cut
 866
 867 sub unblessed_all_relateds {
 868     my ($self) = @_;
 869
 870     my %data;
 871     my $related_resultsets = $self->_result->{related_resultsets} || {};
 872     my $rs = $self->_result;
 873     while ( $related_resultsets and %$related_resultsets ) {
 874         my @relations = keys %{ $related_resultsets };
 875         if ( @relations ) {
 876             my $relation = $relations[0];
 877             $rs = $rs->related_resultset($relation)->get_cache;
 878             $rs = $rs->[0]; # Does it makes sense to have several values here?
 879             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 880             my $koha_object = $object_class->_new_from_dbic( $rs );
 881             $related_resultsets = $rs->{related_resultsets};
 882             %data = ( %data, %{ $koha_object->unblessed } );
 883         }
 884     }
 885     %data = ( %data, %{ $self->unblessed } );
 886     return \%data;
 887 }
 888
 889 =head3 $object->_result();
 890
 891 Returns the internal DBIC Row object
 892
 893 =cut
 894
 895 sub _result {
 896     my ($self) = @_;
 897
 898     # If we don't have a dbic row at this point, we need to create an empty one
 899     $self->{_result} ||=
 900       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 901
 902     return $self->{_result};
 903 }
 904
 905 =head3 $object->_columns();
 906
 907 Returns an arrayref of the table columns
 908
 909 =cut
 910
 911 sub _columns {
 912     my ($self) = @_;
 913
 914     # If we don't have a dbic row at this point, we need to create an empty one
 915     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 916
 917     return $self->{_columns};
 918 }
 919
 920 sub _get_object_class {
 921     my ( $type ) = @_;
 922     return unless $type;
 923
 924     if( $type->can('koha_object_class') ) {
 925         return $type->koha_object_class;
 926     }
 927     $type =~ s|Schema::Result::||;
 928     return ${type};
 929 }
 930
 931 =head3 AUTOLOAD
 932
 933 The autoload method is used only to get and set values for an objects properties.
 934
 935 =cut
 936
 937 sub AUTOLOAD {
 938     my $self = shift;
 939
 940     my $method = our $AUTOLOAD;
 941     $method =~ s/.*://;
 942
 943     my @columns = @{$self->_columns()};
 944     if ( grep { $_ eq $method } @columns ) {
 945
 946         # Lazy definition of get/set accessors like $item->barcode; note that it contains $method
 947         my $accessor = sub {
 948             my $self = shift;
 949             if (@_) {
 950                 $self->_result()->set_column( $method, @_ );
 951                 return $self;
 952             } else {
 953                 return $self->_result()->get_column($method);
 954             }
 955         };
 956         # If called from child class as $self->SUPER-><accessor_name>
 957         # $AUTOLOAD will contain ::SUPER which breaks method lookup
 958         # therefore we cannot write those entries into the symbol table
 959         unless ( $AUTOLOAD =~ /::SUPER::/ ) {
 960             no strict 'refs'; ## no critic (strict)
 961             *{$AUTOLOAD} = $accessor;
 962         }
 963         return $accessor->( $self, @_ );
 964     }
 965
 966     my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
 967
 968     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 969         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 970         show_trace => 1
 971     ) unless grep { $_ eq $method } @known_methods;
 972
 973     my $r = eval { $self->_result->$method(@_) };
 974     if ( $@ ) {
 975         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 976     }
 977     return $r;
 978 }
 979
 980 =head3 _type
 981
 982 This method must be defined in the child class. The value is the name of the DBIC resultset.
 983 For example, for borrowers, the _type method will return "Borrower".
 984
 985 =cut
 986
 987 sub _type { }
 988
 989 =head3 _handle_to_api_child
 990
 991 =cut
 992
 993 sub _handle_to_api_child {
 994     my ($self, $args ) = @_;
 995
 996     my $child  = $args->{child};
 997     my $next   = $args->{next};
 998     my $curr   = $args->{curr};
 999     my $params = $args->{params};
1000
1001     my $res;
1002
1003     if ( defined $child ) {
1004
1005         Koha::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
1006             if defined $next and blessed $child and !$child->can('to_api');
1007
1008         if ( blessed $child ) {
1009             $params->{embed} = $next;
1010             $res = $child->to_api($params);
1011         }
1012         else {
1013             $res = $child;
1014         }
1015     }
1016
1017     return $res;
1018 }
1019
1020 =head3 is_accessible
1021
1022     if ( $object->is_accessible ) { ... }
1023
1024 Stub method that is expected to be overloaded (if required) by implementing classes.
1025
1026 =cut
1027
1028 sub is_accessible {
1029     my ($self) = @_;
1030
1031     return 1;
1032 }
1033
1034 sub DESTROY { }
1035
1036 =head1 AUTHOR
1037
1038 Kyle M Hall <kyle@bywatersolutions.com>
1039
1040 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
1041
1042 =cut
1043
1044 1;