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
  29 use Koha::Database;
  30 use Koha::Exceptions::Object;
  31 use Koha::DateUtils qw( dt_from_string output_pref );
  32 use Koha::Object::Message;
  33
  34 =head1 NAME
  35
  36 Koha::Object - Koha Object base class
  37
  38 =head1 SYNOPSIS
  39
  40     use Koha::Object;
  41     my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
  42
  43 =head1 DESCRIPTION
  44
  45 This class must always be subclassed.
  46
  47 =head1 API
  48
  49 =head2 Class Methods
  50
  51 =cut
  52
  53 =head3 Koha::Object->new();
  54
  55 my $object = Koha::Object->new();
  56 my $object = Koha::Object->new($attributes);
  57
  58 Note that this cannot be used to retrieve record from the DB.
  59
  60 =cut
  61
  62 sub new {
  63     my ( $class, $attributes ) = @_;
  64     my $self = {};
  65
  66     if ($attributes) {
  67         my $schema = Koha::Database->new->schema;
  68
  69         # Remove the arguments which exist, are not defined but NOT NULL to use the default value
  70         my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
  71         for my $column_name ( keys %$attributes ) {
  72             my $c_info = $columns_info->{$column_name};
  73             next if $c_info->{is_nullable};
  74             next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
  75             delete $attributes->{$column_name};
  76         }
  77
  78         $self->{_result} =
  79           $schema->resultset( $class->_type() )->new($attributes);
  80     }
  81
  82     $self->{_messages} = [];
  83
  84     croak("No _type found! Koha::Object must be subclassed!")
  85       unless $class->_type();
  86
  87     bless( $self, $class );
  88
  89 }
  90
  91 =head3 Koha::Object->_new_from_dbic();
  92
  93 my $object = Koha::Object->_new_from_dbic($dbic_row);
  94
  95 =cut
  96
  97 sub _new_from_dbic {
  98     my ( $class, $dbic_row ) = @_;
  99     my $self = {};
 100
 101     # DBIC result row
 102     $self->{_result} = $dbic_row;
 103
 104     croak("No _type found! Koha::Object must be subclassed!")
 105       unless $class->_type();
 106
 107     croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
 108       unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
 109
 110     bless( $self, $class );
 111
 112 }
 113
 114 =head3 $object->store();
 115
 116 Saves the object in storage.
 117 If the object is new, it will be created.
 118 If the object previously existed, it will be updated.
 119
 120 Returns:
 121     $self  if the store was a success
 122     undef  if the store failed
 123
 124 =cut
 125
 126 sub store {
 127     my ($self) = @_;
 128
 129     my $columns_info = $self->_result->result_source->columns_info;
 130
 131     # Handle not null and default values for integers and dates
 132     foreach my $col ( keys %{$columns_info} ) {
 133         # Integers
 134         if (   _numeric_column_type( $columns_info->{$col}->{data_type} )
 135             or _decimal_column_type( $columns_info->{$col}->{data_type} )
 136         ) {
 137             # Has been passed but not a number, usually an empty string
 138             my $value = $self->_result()->get_column($col);
 139             if ( defined $value and not looks_like_number( $value ) ) {
 140                 if ( $columns_info->{$col}->{is_nullable} ) {
 141                     # If nullable, default to null
 142                     $self->_result()->set_column($col => undef);
 143                 } else {
 144                     # If cannot be null, get the default value
 145                     # What if cannot be null and does not have a default value? Possible?
 146                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 147                 }
 148             }
 149         }
 150         elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 151             # Set to null if an empty string (or == 0 but should not happen)
 152             my $value = $self->_result()->get_column($col);
 153             if ( defined $value and not $value ) {
 154                 if ( $columns_info->{$col}->{is_nullable} ) {
 155                     $self->_result()->set_column($col => undef);
 156                 } else {
 157                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 158                 }
 159             }
 160             elsif ( not defined $self->$col
 161                   && $columns_info->{$col}->{datetime_undef_if_invalid} )
 162               {
 163                   # timestamp
 164                   $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 165               }
 166         }
 167     }
 168
 169     try {
 170         return $self->_result()->update_or_insert() ? $self : undef;
 171     }
 172     catch {
 173         # Catch problems and raise relevant exceptions
 174         if (ref($_) eq 'DBIx::Class::Exception') {
 175             warn $_->{msg};
 176             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 177                 # FK constraints
 178                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 179                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 180                     Koha::Exceptions::Object::FKConstraint->throw(
 181                         error     => 'Broken FK constraint',
 182                         broken_fk => $+{column}
 183                     );
 184                 }
 185             }
 186             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 187                 Koha::Exceptions::Object::DuplicateID->throw(
 188                     error => 'Duplicate ID',
 189                     duplicate_id => $+{key}
 190                 );
 191             }
 192             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
 193                 my $type = $+{type};
 194                 my $value = $+{value};
 195                 my $property = $+{property};
 196                 $property =~ s/['`]//g;
 197                 Koha::Exceptions::Object::BadValue->throw(
 198                     type     => $type,
 199                     value    => $value,
 200                     property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
 201                 );
 202             }
 203         }
 204         # Catch-all for foreign key breakages. It will help find other use cases
 205         $_->rethrow();
 206     }
 207 }
 208
 209 =head3 $object->update();
 210
 211 A shortcut for set + store in one call.
 212
 213 =cut
 214
 215 sub update {
 216     my ($self, $values) = @_;
 217     Koha::Exceptions::Object::NotInStorage->throw unless $self->in_storage;
 218     $self->set($values)->store();
 219 }
 220
 221 =head3 $object->delete();
 222
 223 Removes the object from storage.
 224
 225 Returns:
 226     The item object if deletion was a success
 227     The DBIX::Class error if deletion failed
 228
 229 =cut
 230
 231 sub delete {
 232     my ($self) = @_;
 233
 234     my $deleted = $self->_result()->delete;
 235     if ( ref $deleted ) {
 236         my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 237         $deleted = $object_class->_new_from_dbic($deleted);
 238     }
 239     return $deleted;
 240 }
 241
 242 =head3 $object->set( $properties_hashref )
 243
 244 $object->set(
 245     {
 246         property1 => $property1,
 247         property2 => $property2,
 248         property3 => $propery3,
 249     }
 250 );
 251
 252 Enables multiple properties to be set at once
 253
 254 Returns:
 255     1      if all properties were set.
 256     0      if one or more properties do not exist.
 257     undef  if all properties exist but a different error
 258            prevents one or more properties from being set.
 259
 260 If one or more of the properties do not exist,
 261 no properties will be set.
 262
 263 =cut
 264
 265 sub set {
 266     my ( $self, $properties ) = @_;
 267
 268     my @columns = @{$self->_columns()};
 269
 270     foreach my $p ( keys %$properties ) {
 271         unless ( grep { $_ eq $p } @columns ) {
 272             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 273         }
 274     }
 275
 276     return $self->_result()->set_columns($properties) ? $self : undef;
 277 }
 278
 279 =head3 $object->set_or_blank( $properties_hashref )
 280
 281 $object->set_or_blank(
 282     {
 283         property1 => $property1,
 284         property2 => $property2,
 285         property3 => $propery3,
 286     }
 287 );
 288
 289 If not listed in $properties_hashref, the property will be set to the default
 290 value defined at DB level, or nulled.
 291
 292 =cut
 293
 294
 295 sub set_or_blank {
 296     my ( $self, $properties ) = @_;
 297
 298     my $columns_info = $self->_result->result_source->columns_info;
 299
 300     foreach my $col ( keys %{$columns_info} ) {
 301
 302         next if exists $properties->{$col};
 303
 304         if ( $columns_info->{$col}->{is_nullable} ) {
 305             $properties->{$col} = undef;
 306         } else {
 307             $properties->{$col} = $columns_info->{$col}->{default_value};
 308         }
 309     }
 310
 311     return $self->set($properties);
 312 }
 313
 314 =head3 $object->unblessed();
 315
 316 Returns an unblessed representation of object.
 317
 318 =cut
 319
 320 sub unblessed {
 321     my ($self) = @_;
 322
 323     return { $self->_result->get_columns };
 324 }
 325
 326 =head3 $object->get_from_storage;
 327
 328 =cut
 329
 330 sub get_from_storage {
 331     my ( $self, $attrs ) = @_;
 332     my $stored_object = $self->_result->get_from_storage($attrs);
 333     return unless $stored_object;
 334     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 335     return $object_class->_new_from_dbic($stored_object);
 336 }
 337
 338 =head3 $object->object_messages
 339
 340     my @messages = @{ $object->object_messages };
 341
 342 Returns the (probably non-fatal) messages that were recorded on the object.
 343
 344 =cut
 345
 346 sub object_messages {
 347     my ( $self ) = @_;
 348
 349     $self->{_messages} = []
 350         unless defined $self->{_messages};
 351
 352     return $self->{_messages};
 353 }
 354
 355 =head3 $object->add_message
 356
 357     try {
 358         <some action that might fail>
 359     }
 360     catch {
 361         if ( <fatal condition> ) {
 362             Koha::Exception->throw...
 363         }
 364
 365         # This is a non fatal error, notify the caller
 366         $self->add_message({ message => $error, type => 'error' });
 367     }
 368     return $self;
 369
 370 Adds a message.
 371
 372 =cut
 373
 374 sub add_message {
 375     my ( $self, $params ) = @_;
 376
 377     push @{ $self->{_messages} }, Koha::Object::Message->new($params);
 378
 379     return $self;
 380 }
 381
 382 =head3 $object->TO_JSON
 383
 384 Returns an unblessed representation of the object, suitable for JSON output.
 385
 386 =cut
 387
 388 sub TO_JSON {
 389
 390     my ($self) = @_;
 391
 392     my $unblessed    = $self->unblessed;
 393     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 394         ->result_source->{_columns};
 395
 396     foreach my $col ( keys %{$columns_info} ) {
 397
 398         if ( $columns_info->{$col}->{is_boolean} )
 399         {    # Handle booleans gracefully
 400             $unblessed->{$col}
 401                 = ( $unblessed->{$col} )
 402                 ? Mojo::JSON->true
 403                 : Mojo::JSON->false;
 404         }
 405         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 406             and looks_like_number( $unblessed->{$col} )
 407         ) {
 408             # TODO: Remove once the solution for
 409             # https://github.com/perl5-dbi/DBD-mysql/issues/212
 410             # is ported to whatever distro we support by that time
 411             # or we move to DBD::MariaDB
 412             $unblessed->{$col} += 0;
 413         }
 414         elsif ( _decimal_column_type( $columns_info->{$col}->{data_type} )
 415             and looks_like_number( $unblessed->{$col} )
 416         ) {
 417             # TODO: Remove once the solution for
 418             # https://github.com/perl5-dbi/DBD-mysql/issues/212
 419             # is ported to whatever distro we support by that time
 420             # or we move to DBD::MariaDB
 421             $unblessed->{$col} += 0.00;
 422         }
 423         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 424             eval {
 425                 return unless $unblessed->{$col};
 426                 $unblessed->{$col} = output_pref({
 427                     dateformat => 'rfc3339',
 428                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 429                 });
 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             try {
 836                 if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
 837                     $value = $dtf->format_date(dt_from_string($value, 'iso'))
 838                         if defined $value;
 839                 }
 840                 else {
 841                     $value = $dtf->format_datetime(dt_from_string($value, 'rfc3339'))
 842                         if defined $value;
 843                 }
 844             }
 845             catch {
 846                 Koha::Exceptions::BadParameter->throw( parameter => $key );
 847             };
 848         }
 849
 850         $params->{$koha_field_name} = $value;
 851     }
 852
 853     return $params;
 854 }
 855
 856 =head3 $object->unblessed_all_relateds
 857
 858 my $everything_into_one_hashref = $object->unblessed_all_relateds
 859
 860 The unblessed method only retrieves column' values for the column of the object.
 861 In a *few* cases we want to retrieve the information of all the prefetched data.
 862
 863 =cut
 864
 865 sub unblessed_all_relateds {
 866     my ($self) = @_;
 867
 868     my %data;
 869     my $related_resultsets = $self->_result->{related_resultsets} || {};
 870     my $rs = $self->_result;
 871     while ( $related_resultsets and %$related_resultsets ) {
 872         my @relations = keys %{ $related_resultsets };
 873         if ( @relations ) {
 874             my $relation = $relations[0];
 875             $rs = $rs->related_resultset($relation)->get_cache;
 876             $rs = $rs->[0]; # Does it makes sense to have several values here?
 877             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 878             my $koha_object = $object_class->_new_from_dbic( $rs );
 879             $related_resultsets = $rs->{related_resultsets};
 880             %data = ( %data, %{ $koha_object->unblessed } );
 881         }
 882     }
 883     %data = ( %data, %{ $self->unblessed } );
 884     return \%data;
 885 }
 886
 887 =head3 $object->_result();
 888
 889 Returns the internal DBIC Row object
 890
 891 =cut
 892
 893 sub _result {
 894     my ($self) = @_;
 895
 896     # If we don't have a dbic row at this point, we need to create an empty one
 897     $self->{_result} ||=
 898       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 899
 900     return $self->{_result};
 901 }
 902
 903 =head3 $object->_columns();
 904
 905 Returns an arrayref of the table columns
 906
 907 =cut
 908
 909 sub _columns {
 910     my ($self) = @_;
 911
 912     # If we don't have a dbic row at this point, we need to create an empty one
 913     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 914
 915     return $self->{_columns};
 916 }
 917
 918 sub _get_object_class {
 919     my ( $type ) = @_;
 920     return unless $type;
 921
 922     if( $type->can('koha_object_class') ) {
 923         return $type->koha_object_class;
 924     }
 925     $type =~ s|Schema::Result::||;
 926     return ${type};
 927 }
 928
 929 =head3 AUTOLOAD
 930
 931 The autoload method is used only to get and set values for an objects properties.
 932
 933 =cut
 934
 935 sub AUTOLOAD {
 936     my $self = shift;
 937
 938     my $method = our $AUTOLOAD;
 939     $method =~ s/.*://;
 940
 941     my @columns = @{$self->_columns()};
 942     if ( grep { $_ eq $method } @columns ) {
 943
 944         # Lazy definition of get/set accessors like $item->barcode; note that it contains $method
 945         my $accessor = sub {
 946             my $self = shift;
 947             if (@_) {
 948                 $self->_result()->set_column( $method, @_ );
 949                 return $self;
 950             } else {
 951                 return $self->_result()->get_column($method);
 952             }
 953         };
 954         no strict 'refs'; ## no critic (strict)
 955         *{$AUTOLOAD} = $accessor;
 956         return $accessor->( $self, @_ );
 957     }
 958
 959     my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
 960
 961     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 962         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 963         show_trace => 1
 964     ) unless grep { $_ eq $method } @known_methods;
 965
 966     my $r = eval { $self->_result->$method(@_) };
 967     if ( $@ ) {
 968         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 969     }
 970     return $r;
 971 }
 972
 973 =head3 _type
 974
 975 This method must be defined in the child class. The value is the name of the DBIC resultset.
 976 For example, for borrowers, the _type method will return "Borrower".
 977
 978 =cut
 979
 980 sub _type { }
 981
 982 =head3 _handle_to_api_child
 983
 984 =cut
 985
 986 sub _handle_to_api_child {
 987     my ($self, $args ) = @_;
 988
 989     my $child  = $args->{child};
 990     my $next   = $args->{next};
 991     my $curr   = $args->{curr};
 992     my $params = $args->{params};
 993
 994     my $res;
 995
 996     if ( defined $child ) {
 997
 998         Koha::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
 999             if defined $next and blessed $child and !$child->can('to_api');
1000
1001         if ( blessed $child ) {
1002             $params->{embed} = $next;
1003             $res = $child->to_api($params);
1004         }
1005         else {
1006             $res = $child;
1007         }
1008     }
1009
1010     return $res;
1011 }
1012
1013 =head3 is_accessible
1014
1015     if ( $object->is_accessible ) { ... }
1016
1017 Stub method that is expected to be overloaded (if required) by implementing classes.
1018
1019 =cut
1020
1021 sub is_accessible {
1022     my ($self) = @_;
1023
1024     return 1;
1025 }
1026
1027 sub DESTROY { }
1028
1029 =head1 AUTHOR
1030
1031 Kyle M Hall <kyle@bywatersolutions.com>
1032
1033 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
1034
1035 =cut
1036
1037 1;