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
 409             # TODO: Remove once the solution for
 410             # https://github.com/perl5-dbi/DBD-mysql/issues/212
 411             # is ported to whatever distro we support by that time
 412             # or we move to DBD::MariaDB
 413             $unblessed->{$col} += 0;
 414         }
 415         elsif ( _decimal_column_type( $columns_info->{$col}->{data_type} )
 416             and looks_like_number( $unblessed->{$col} )
 417         ) {
 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                 $unblessed->{$col} = output_pref({
 429                     dateformat => 'rfc3339',
 430                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 431                 });
 432             };
 433         }
 434     }
 435     return $unblessed;
 436 }
 437
 438 sub _date_or_datetime_column_type {
 439     my ($column_type) = @_;
 440
 441     my @dt_types = (
 442         'timestamp',
 443         'date',
 444         'datetime'
 445     );
 446
 447     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 448 }
 449 sub _datetime_column_type {
 450     my ($column_type) = @_;
 451
 452     my @dt_types = (
 453         'timestamp',
 454         'datetime'
 455     );
 456
 457     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 458 }
 459
 460 sub _numeric_column_type {
 461     # TODO: Remove once the solution for
 462     # https://github.com/perl5-dbi/DBD-mysql/issues/212
 463     # is ported to whatever distro we support by that time
 464     # or we move to DBD::MariaDB
 465     my ($column_type) = @_;
 466
 467     my @numeric_types = (
 468         'bigint',
 469         'integer',
 470         'int',
 471         'mediumint',
 472         'smallint',
 473         'tinyint',
 474     );
 475
 476     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 477 }
 478
 479 sub _decimal_column_type {
 480     # TODO: Remove once the solution for
 481     # https://github.com/perl5-dbi/DBD-mysql/issues/212
 482     # is ported to whatever distro we support by that time
 483     # or we move to DBD::MariaDB
 484     my ($column_type) = @_;
 485
 486     my @decimal_types = (
 487         'decimal',
 488         'double precision',
 489         'float'
 490     );
 491
 492     return ( grep { $column_type eq $_ } @decimal_types) ? 1 : 0;
 493 }
 494
 495 =head3 prefetch_whitelist
 496
 497     my $whitelist = $object->prefetch_whitelist()
 498
 499 Returns a hash of prefetchable subs and the type they return.
 500
 501 =cut
 502
 503 sub prefetch_whitelist {
 504     my ( $self ) = @_;
 505
 506     my $whitelist = {};
 507     my $relations = $self->_result->result_source->_relationships;
 508
 509     foreach my $key (keys %{$relations}) {
 510         if($self->can($key)) {
 511             my $result_class = $relations->{$key}->{class};
 512             my $obj = $result_class->new;
 513             try {
 514                 $whitelist->{$key} = Koha::Object::_get_object_class( $obj->result_class );
 515             } catch {
 516                 $whitelist->{$key} = undef;
 517             }
 518         }
 519     }
 520
 521     return $whitelist;
 522 }
 523
 524 =head3 to_api
 525
 526     my $object_for_api = $object->to_api(
 527         {
 528           [ embed => {
 529                 items => {
 530                     children => {
 531                         holds => {,
 532                             children => {
 533                               ...
 534                             }
 535                         }
 536                     }
 537                 },
 538                 library => {
 539                     ...
 540                 }
 541             },
 542             public => 0|1,
 543             ...
 544          ]
 545         }
 546     );
 547
 548 Returns a representation of the object, suitable for API output.
 549
 550 =cut
 551
 552 sub to_api {
 553     my ( $self, $params ) = @_;
 554
 555     return unless $self->is_accessible($params);
 556
 557     my $json_object = $self->TO_JSON;
 558
 559     # Make sure we duplicate the $params variable to avoid
 560     # breaking calls in a loop (Koha::Objects->to_api)
 561     $params = defined $params ? {%$params} : {};
 562
 563     # children should be able to handle without
 564     my $embeds  = delete $params->{embed};
 565     my $strings = delete $params->{strings};
 566
 567     # coded values handling
 568     my $string_map = {};
 569     if ( $strings and $self->can('strings_map') ) {
 570         $string_map = $self->strings_map($params);
 571     }
 572
 573     # Remove forbidden attributes if required (including their coded values)
 574     if ( $params->{public} ) {
 575         for my $field ( keys %{$json_object} ) {
 576             delete $json_object->{$field}
 577               unless any { $_ eq $field } @{ $self->public_read_list };
 578         }
 579
 580         if ($strings) {
 581             foreach my $field ( keys %{$string_map} ) {
 582                 delete $string_map->{$field}
 583                   unless any { $_ eq $field } @{ $self->public_read_list };
 584             }
 585         }
 586     }
 587
 588     my $to_api_mapping = $self->to_api_mapping;
 589
 590     # Rename attributes and coded values if there's a mapping
 591     if ( $self->can('to_api_mapping') ) {
 592         foreach my $column ( keys %{ $self->to_api_mapping } ) {
 593             my $mapped_column = $self->to_api_mapping->{$column};
 594             if ( exists $json_object->{$column}
 595                 && defined $mapped_column )
 596             {
 597
 598                 # key != undef
 599                 $json_object->{$mapped_column} = delete $json_object->{$column};
 600                 $string_map->{$mapped_column}  = delete $string_map->{$column}
 601                   if exists $string_map->{$column};
 602
 603             }
 604             elsif ( exists $json_object->{$column}
 605                 && !defined $mapped_column )
 606             {
 607
 608                 # key == undef
 609                 delete $json_object->{$column};
 610                 delete $string_map->{$column};
 611             }
 612         }
 613     }
 614
 615     $json_object->{_strings} = $string_map
 616       if $strings;
 617
 618     if ($embeds) {
 619         foreach my $embed ( keys %{$embeds} ) {
 620             if (    $embed =~ m/^(?<relation>.*)_count$/
 621                 and $embeds->{$embed}->{is_count} )
 622             {
 623
 624                 my $relation = $+{relation};
 625                 $json_object->{$embed} = $self->$relation->count;
 626             }
 627             else {
 628                 my $curr = $embed;
 629                 my $next = $embeds->{$curr}->{children};
 630
 631                 $params->{strings} = 1
 632                   if $embeds->{$embed}->{strings};
 633
 634                 my $children = $self->$curr;
 635
 636                 if ( defined $children and ref($children) eq 'ARRAY' ) {
 637                     my @list = map {
 638                         $self->_handle_to_api_child(
 639                             {
 640                                 child  => $_,
 641                                 next   => $next,
 642                                 curr   => $curr,
 643                                 params => $params
 644                             }
 645                         )
 646                     } @{$children};
 647                     $json_object->{$curr} = \@list;
 648                 }
 649                 else {
 650                     $json_object->{$curr} = $self->_handle_to_api_child(
 651                         {
 652                             child  => $children,
 653                             next   => $next,
 654                             curr   => $curr,
 655                             params => $params
 656                         }
 657                     );
 658                 }
 659             }
 660         }
 661     }
 662
 663     return $json_object;
 664 }
 665
 666 =head3 to_api_mapping
 667
 668     my $mapping = $object->to_api_mapping;
 669
 670 Generic method that returns the attribute name mappings required to
 671 render the object on the API.
 672
 673 Note: this only returns an empty I<hashref>. Each class should have its
 674 own mapping returned.
 675
 676 =cut
 677
 678 sub to_api_mapping {
 679     return {};
 680 }
 681
 682 =head3 strings_map
 683
 684     my $string_map = $object->strings_map($params);
 685
 686 Generic method that returns the string map for coded attributes.
 687
 688 Return should be a hashref keyed on database field name with the values
 689 being hashrefs containing 'str', 'type' and optionally 'category'.
 690
 691 This is then used in to_api to render the _strings embed when requested.
 692
 693 Note: this only returns an empty I<hashref>. Each class should have its
 694 own mapping returned.
 695
 696 =cut
 697
 698 sub strings_map {
 699     return {};
 700 }
 701
 702 =head3 public_read_list
 703
 704
 705     my @public_read_list = @{$object->public_read_list};
 706
 707 Generic method that returns the list of database columns that are allowed to
 708 be passed to render objects on the public API.
 709
 710 Note: this only returns an empty I<arrayref>. Each class should have its
 711 own implementation.
 712
 713 =cut
 714
 715 sub public_read_list
 716  {
 717     return [];
 718 }
 719
 720 =head3 from_api_mapping
 721
 722     my $mapping = $object->from_api_mapping;
 723
 724 Generic method that returns the attribute name mappings so the data that
 725 comes from the API is correctly renamed to match what is required for the DB.
 726
 727 =cut
 728
 729 sub from_api_mapping {
 730     my ( $self ) = @_;
 731
 732     my $to_api_mapping = $self->to_api_mapping;
 733
 734     unless ( defined $self->{_from_api_mapping} ) {
 735         $self->{_from_api_mapping} = {};
 736         while (my ($key, $value) = each %{ $to_api_mapping } ) {
 737             $self->{_from_api_mapping}->{$value} = $key
 738                 if defined $value;
 739         }
 740     }
 741
 742     return $self->{_from_api_mapping};
 743 }
 744
 745 =head3 new_from_api
 746
 747     my $object = Koha::Object->new_from_api;
 748     my $object = Koha::Object->new_from_api( $attrs );
 749
 750 Creates a new object, mapping the API attribute names to the ones on the DB schema.
 751
 752 =cut
 753
 754 sub new_from_api {
 755     my ( $class, $params ) = @_;
 756
 757     my $self = $class->new;
 758     return $self->set_from_api( $params );
 759 }
 760
 761 =head3 set_from_api
 762
 763     my $object = Koha::Object->new(...);
 764     $object->set_from_api( $attrs )
 765
 766 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
 767
 768 =cut
 769
 770 sub set_from_api {
 771     my ( $self, $from_api_params ) = @_;
 772
 773     return $self->set( $self->attributes_from_api( $from_api_params ) );
 774 }
 775
 776 =head3 attributes_from_api
 777
 778     my $attributes = attributes_from_api( $params );
 779
 780 Returns the passed params, converted from API naming into the model.
 781
 782 =cut
 783
 784 sub attributes_from_api {
 785     my ( $self, $from_api_params ) = @_;
 786
 787     my $from_api_mapping = $self->from_api_mapping;
 788
 789     my $params;
 790     my $columns_info = $self->_result->result_source->columns_info;
 791     my $dtf          = $self->_result->result_source->storage->datetime_parser;
 792
 793     while (my ($key, $value) = each %{ $from_api_params } ) {
 794         my $koha_field_name =
 795           exists $from_api_mapping->{$key}
 796           ? $from_api_mapping->{$key}
 797           : $key;
 798
 799         if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
 800             # TODO: Remove when D8 is formally deprecated
 801             # Handle booleans gracefully
 802             $value = ( $value ) ? 1 : 0;
 803         }
 804         elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
 805             try {
 806                 if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
 807                     $value = $dtf->format_date(dt_from_string($value, 'iso'))
 808                         if defined $value;
 809                 }
 810                 else {
 811                     $value = $dtf->format_datetime(dt_from_string($value, 'rfc3339'))
 812                         if defined $value;
 813                 }
 814             }
 815             catch {
 816                 Koha::Exceptions::BadParameter->throw( parameter => $key );
 817             };
 818         }
 819
 820         $params->{$koha_field_name} = $value;
 821     }
 822
 823     return $params;
 824 }
 825
 826 =head3 $object->unblessed_all_relateds
 827
 828 my $everything_into_one_hashref = $object->unblessed_all_relateds
 829
 830 The unblessed method only retrieves column' values for the column of the object.
 831 In a *few* cases we want to retrieve the information of all the prefetched data.
 832
 833 =cut
 834
 835 sub unblessed_all_relateds {
 836     my ($self) = @_;
 837
 838     my %data;
 839     my $related_resultsets = $self->_result->{related_resultsets} || {};
 840     my $rs = $self->_result;
 841     while ( $related_resultsets and %$related_resultsets ) {
 842         my @relations = keys %{ $related_resultsets };
 843         if ( @relations ) {
 844             my $relation = $relations[0];
 845             $rs = $rs->related_resultset($relation)->get_cache;
 846             $rs = $rs->[0]; # Does it makes sense to have several values here?
 847             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 848             my $koha_object = $object_class->_new_from_dbic( $rs );
 849             $related_resultsets = $rs->{related_resultsets};
 850             %data = ( %data, %{ $koha_object->unblessed } );
 851         }
 852     }
 853     %data = ( %data, %{ $self->unblessed } );
 854     return \%data;
 855 }
 856
 857 =head3 $object->_result();
 858
 859 Returns the internal DBIC Row object
 860
 861 =cut
 862
 863 sub _result {
 864     my ($self) = @_;
 865
 866     # If we don't have a dbic row at this point, we need to create an empty one
 867     $self->{_result} ||=
 868       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 869
 870     return $self->{_result};
 871 }
 872
 873 =head3 $object->_columns();
 874
 875 Returns an arrayref of the table columns
 876
 877 =cut
 878
 879 sub _columns {
 880     my ($self) = @_;
 881
 882     # If we don't have a dbic row at this point, we need to create an empty one
 883     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 884
 885     return $self->{_columns};
 886 }
 887
 888 sub _get_object_class {
 889     my ( $type ) = @_;
 890     return unless $type;
 891
 892     if( $type->can('koha_object_class') ) {
 893         return $type->koha_object_class;
 894     }
 895     $type =~ s|Schema::Result::||;
 896     return ${type};
 897 }
 898
 899 =head3 AUTOLOAD
 900
 901 The autoload method is used only to get and set values for an objects properties.
 902
 903 =cut
 904
 905 sub AUTOLOAD {
 906     my $self = shift;
 907
 908     my $method = our $AUTOLOAD;
 909     $method =~ s/.*://;
 910
 911     my @columns = @{$self->_columns()};
 912     if ( grep { $_ eq $method } @columns ) {
 913
 914         # Lazy definition of get/set accessors like $item->barcode; note that it contains $method
 915         my $accessor = sub {
 916             my $self = shift;
 917             if (@_) {
 918                 $self->_result()->set_column( $method, @_ );
 919                 return $self;
 920             } else {
 921                 return $self->_result()->get_column($method);
 922             }
 923         };
 924         no strict 'refs'; ## no critic (strict)
 925         *{$AUTOLOAD} = $accessor;
 926         return $accessor->( $self, @_ );
 927     }
 928
 929     my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
 930
 931     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 932         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 933         show_trace => 1
 934     ) unless grep { $_ eq $method } @known_methods;
 935
 936     my $r = eval { $self->_result->$method(@_) };
 937     if ( $@ ) {
 938         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 939     }
 940     return $r;
 941 }
 942
 943 =head3 _type
 944
 945 This method must be defined in the child class. The value is the name of the DBIC resultset.
 946 For example, for borrowers, the _type method will return "Borrower".
 947
 948 =cut
 949
 950 sub _type { }
 951
 952 =head3 _handle_to_api_child
 953
 954 =cut
 955
 956 sub _handle_to_api_child {
 957     my ($self, $args ) = @_;
 958
 959     my $child  = $args->{child};
 960     my $next   = $args->{next};
 961     my $curr   = $args->{curr};
 962     my $params = $args->{params};
 963
 964     my $res;
 965
 966     if ( defined $child ) {
 967
 968         Koha::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
 969             if defined $next and blessed $child and !$child->can('to_api');
 970
 971         if ( blessed $child ) {
 972             $params->{embed} = $next;
 973             $res = $child->to_api($params);
 974         }
 975         else {
 976             $res = $child;
 977         }
 978     }
 979
 980     return $res;
 981 }
 982
 983 =head3 is_accessible
 984
 985     if ( $object->is_accessible ) { ... }
 986
 987 Stub method that is expected to be overloaded (if required) by implementing classes.
 988
 989 =cut
 990
 991 sub is_accessible {
 992     my ($self) = @_;
 993
 994     return 1;
 995 }
 996
 997 sub DESTROY { }
 998
 999 =head1 AUTHOR
1000
1001 Kyle M Hall <kyle@bywatersolutions.com>
1002
1003 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
1004
1005 =cut
1006
1007 1;