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