Koha/Object.pm

   1 package Koha::Object;
   2
   3 # Copyright ByWater Solutions 2014
   4 # Copyright 2016 Koha Development Team
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 3 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along
  18 # with Koha; if not, write to the Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  20
  21 use Modern::Perl;
  22
  23 use Carp;
  24 use Mojo::JSON;
  25 use Scalar::Util qw( blessed looks_like_number );
  26 use Try::Tiny;
  27
  28 use Koha::Database;
  29 use Koha::Exceptions::Object;
  30 use Koha::DateUtils;
  31
  32 =head1 NAME
  33
  34 Koha::Object - Koha Object base class
  35
  36 =head1 SYNOPSIS
  37
  38     use Koha::Object;
  39     my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
  40
  41 =head1 DESCRIPTION
  42
  43 This class must always be subclassed.
  44
  45 =head1 API
  46
  47 =head2 Class Methods
  48
  49 =cut
  50
  51 =head3 Koha::Object->new();
  52
  53 my $object = Koha::Object->new();
  54 my $object = Koha::Object->new($attributes);
  55
  56 Note that this cannot be used to retrieve record from the DB.
  57
  58 =cut
  59
  60 sub new {
  61     my ( $class, $attributes ) = @_;
  62     my $self = {};
  63
  64     if ($attributes) {
  65         my $schema = Koha::Database->new->schema;
  66
  67         # Remove the arguments which exist, are not defined but NOT NULL to use the default value
  68         my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
  69         for my $column_name ( keys %$attributes ) {
  70             my $c_info = $columns_info->{$column_name};
  71             next if $c_info->{is_nullable};
  72             next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
  73             delete $attributes->{$column_name};
  74         }
  75
  76         $self->{_result} =
  77           $schema->resultset( $class->_type() )->new($attributes);
  78     }
  79
  80     croak("No _type found! Koha::Object must be subclassed!")
  81       unless $class->_type();
  82
  83     bless( $self, $class );
  84
  85 }
  86
  87 =head3 Koha::Object->_new_from_dbic();
  88
  89 my $object = Koha::Object->_new_from_dbic($dbic_row);
  90
  91 =cut
  92
  93 sub _new_from_dbic {
  94     my ( $class, $dbic_row ) = @_;
  95     my $self = {};
  96
  97     # DBIC result row
  98     $self->{_result} = $dbic_row;
  99
 100     croak("No _type found! Koha::Object must be subclassed!")
 101       unless $class->_type();
 102
 103     croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
 104       unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
 105
 106     bless( $self, $class );
 107
 108 }
 109
 110 =head3 $object->store();
 111
 112 Saves the object in storage.
 113 If the object is new, it will be created.
 114 If the object previously existed, it will be updated.
 115
 116 Returns:
 117     $self  if the store was a success
 118     undef  if the store failed
 119
 120 =cut
 121
 122 sub store {
 123     my ($self) = @_;
 124
 125     my $columns_info = $self->_result->result_source->columns_info;
 126
 127     # Handle not null and default values for integers and dates
 128     foreach my $col ( keys %{$columns_info} ) {
 129         # Integers
 130         if ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
 131             # Has been passed but not a number, usually an empty string
 132             my $value = $self->_result()->get_column($col);
 133             if ( defined $value and not looks_like_number( $value ) ) {
 134                 if ( $columns_info->{$col}->{is_nullable} ) {
 135                     # If nullable, default to null
 136                     $self->_result()->set_column($col => undef);
 137                 } else {
 138                     # If cannot be null, get the default value
 139                     # What if cannot be null and does not have a default value? Possible?
 140                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 141                 }
 142             }
 143         }
 144         elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 145             # Set to null if an empty string (or == 0 but should not happen)
 146             my $value = $self->_result()->get_column($col);
 147             if ( defined $value and not $value ) {
 148                 if ( $columns_info->{$col}->{is_nullable} ) {
 149                     $self->_result()->set_column($col => undef);
 150                 } else {
 151                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 152                 }
 153             }
 154         }
 155     }
 156
 157     try {
 158         return $self->_result()->update_or_insert() ? $self : undef;
 159     }
 160     catch {
 161         # Catch problems and raise relevant exceptions
 162         if (ref($_) eq 'DBIx::Class::Exception') {
 163             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 164                 # FK constraints
 165                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 166                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 167                     Koha::Exceptions::Object::FKConstraint->throw(
 168                         error     => 'Broken FK constraint',
 169                         broken_fk => $+{column}
 170                     );
 171                 }
 172             }
 173             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 174                 Koha::Exceptions::Object::DuplicateID->throw(
 175                     error => 'Duplicate ID',
 176                     duplicate_id => $+{key}
 177                 );
 178             }
 179             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
 180                 my $type = $+{type};
 181                 my $value = $+{value};
 182                 my $property = $+{property};
 183                 $property =~ s/['`]//g;
 184                 Koha::Exceptions::Object::BadValue->throw(
 185                     type     => $type,
 186                     value    => $value,
 187                     property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
 188                 );
 189             }
 190         }
 191         # Catch-all for foreign key breakages. It will help find other use cases
 192         $_->rethrow();
 193     }
 194 }
 195
 196 =head3 $object->delete();
 197
 198 Removes the object from storage.
 199
 200 Returns:
 201     1  if the deletion was a success
 202     0  if the deletion failed
 203     -1 if the object was never in storage
 204
 205 =cut
 206
 207 sub delete {
 208     my ($self) = @_;
 209
 210     # Deleting something not in storage throws an exception
 211     return -1 unless $self->_result()->in_storage();
 212
 213     # Return a boolean for succcess
 214     return $self->_result()->delete() ? 1 : 0;
 215 }
 216
 217 =head3 $object->set( $properties_hashref )
 218
 219 $object->set(
 220     {
 221         property1 => $property1,
 222         property2 => $property2,
 223         property3 => $propery3,
 224     }
 225 );
 226
 227 Enables multiple properties to be set at once
 228
 229 Returns:
 230     1      if all properties were set.
 231     0      if one or more properties do not exist.
 232     undef  if all properties exist but a different error
 233            prevents one or more properties from being set.
 234
 235 If one or more of the properties do not exist,
 236 no properties will be set.
 237
 238 =cut
 239
 240 sub set {
 241     my ( $self, $properties ) = @_;
 242
 243     my @columns = @{$self->_columns()};
 244
 245     foreach my $p ( keys %$properties ) {
 246         unless ( grep {/^$p$/} @columns ) {
 247             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 248         }
 249     }
 250
 251     return $self->_result()->set_columns($properties) ? $self : undef;
 252 }
 253
 254 =head3 $object->unblessed();
 255
 256 Returns an unblessed representation of object.
 257
 258 =cut
 259
 260 sub unblessed {
 261     my ($self) = @_;
 262
 263     return { $self->_result->get_columns };
 264 }
 265
 266 =head3 $object->get_from_storage;
 267
 268 =cut
 269
 270 sub get_from_storage {
 271     my ( $self, $attrs ) = @_;
 272     my $stored_object = $self->_result->get_from_storage($attrs);
 273     return unless $stored_object;
 274     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 275     return $object_class->_new_from_dbic($stored_object);
 276 }
 277
 278 =head3 $object->TO_JSON
 279
 280 Returns an unblessed representation of the object, suitable for JSON output.
 281
 282 =cut
 283
 284 sub TO_JSON {
 285
 286     my ($self) = @_;
 287
 288     my $unblessed    = $self->unblessed;
 289     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 290         ->result_source->{_columns};
 291
 292     foreach my $col ( keys %{$columns_info} ) {
 293
 294         if ( $columns_info->{$col}->{is_boolean} )
 295         {    # Handle booleans gracefully
 296             $unblessed->{$col}
 297                 = ( $unblessed->{$col} )
 298                 ? Mojo::JSON->true
 299                 : Mojo::JSON->false;
 300         }
 301         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 302             and looks_like_number( $unblessed->{$col} )
 303         ) {
 304
 305             # TODO: Remove once the solution for
 306             # https://rt.cpan.org/Ticket/Display.html?id=119904
 307             # is ported to whatever distro we support by that time
 308             $unblessed->{$col} += 0;
 309         }
 310         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 311             eval {
 312                 return unless $unblessed->{$col};
 313                 $unblessed->{$col} = output_pref({
 314                     dateformat => 'rfc3339',
 315                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 316                 });
 317             };
 318         }
 319     }
 320     return $unblessed;
 321 }
 322
 323 sub _date_or_datetime_column_type {
 324     my ($column_type) = @_;
 325
 326     my @dt_types = (
 327         'timestamp',
 328         'date',
 329         'datetime'
 330     );
 331
 332     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 333 }
 334 sub _datetime_column_type {
 335     my ($column_type) = @_;
 336
 337     my @dt_types = (
 338         'timestamp',
 339         'datetime'
 340     );
 341
 342     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 343 }
 344
 345 sub _numeric_column_type {
 346     # TODO: Remove once the solution for
 347     # https://rt.cpan.org/Ticket/Display.html?id=119904
 348     # is ported to whatever distro we support by that time
 349     my ($column_type) = @_;
 350
 351     my @numeric_types = (
 352         'bigint',
 353         'integer',
 354         'int',
 355         'mediumint',
 356         'smallint',
 357         'tinyint',
 358         'decimal',
 359         'double precision',
 360         'float'
 361     );
 362
 363     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 364 }
 365
 366 =head3 to_api
 367
 368     my $object_for_api = $object->to_api(
 369         {
 370           [ embed => {
 371                 items => {
 372                     children => {
 373                         holds => {,
 374                             children => {
 375                               ...
 376                             }
 377                         }
 378                     }
 379                 },
 380                 library => {
 381                     ...
 382                 }
 383             },
 384             ...
 385          ]
 386         }
 387     );
 388
 389 Returns a representation of the object, suitable for API output.
 390
 391 =cut
 392
 393 sub to_api {
 394     my ( $self, $params ) = @_;
 395     my $json_object = $self->TO_JSON;
 396
 397     my $to_api_mapping = $self->to_api_mapping;
 398
 399     # Rename attributes if there's a mapping
 400     if ( $self->can('to_api_mapping') ) {
 401         foreach my $column ( keys %{ $self->to_api_mapping } ) {
 402             my $mapped_column = $self->to_api_mapping->{$column};
 403             if ( exists $json_object->{$column}
 404                 && defined $mapped_column )
 405             {
 406                 # key != undef
 407                 $json_object->{$mapped_column} = delete $json_object->{$column};
 408             }
 409             elsif ( exists $json_object->{$column}
 410                 && !defined $mapped_column )
 411             {
 412                 # key == undef
 413                 delete $json_object->{$column};
 414             }
 415         }
 416     }
 417
 418     my $embeds = $params->{embed};
 419
 420     if ($embeds) {
 421         foreach my $embed ( keys %{$embeds} ) {
 422             my $curr = $embed;
 423             my $next = $embeds->{$curr}->{children};
 424
 425             my $children = $self->$curr;
 426
 427             if ( defined $children and ref($children) eq 'ARRAY' ) {
 428                 my @list = map {
 429                     $self->_handle_to_api_child(
 430                         { child => $_, next => $next, curr => $curr } )
 431                 } @{$children};
 432                 $json_object->{$curr} = \@list;
 433             }
 434             else {
 435                 $json_object->{$curr} = $self->_handle_to_api_child(
 436                     { child => $children, next => $next, curr => $curr } );
 437             }
 438         }
 439     }
 440
 441
 442
 443     return $json_object;
 444 }
 445
 446 =head3 to_api_mapping
 447
 448     my $mapping = $object->to_api_mapping;
 449
 450 Generic method that returns the attribute name mappings required to
 451 render the object on the API.
 452
 453 Note: this only returns an empty I<hashref>. Each class should have its
 454 own mapping returned.
 455
 456 =cut
 457
 458 sub to_api_mapping {
 459     return {};
 460 }
 461
 462 =head3 from_api_mapping
 463
 464     my $mapping = $object->from_api_mapping;
 465
 466 Generic method that returns the attribute name mappings so the data that
 467 comes from the API is correctly renamed to match what is required for the DB.
 468
 469 =cut
 470
 471 sub from_api_mapping {
 472     my ( $self ) = @_;
 473
 474     my $to_api_mapping = $self->to_api_mapping;
 475
 476     unless ( $self->{_from_api_mapping} ) {
 477         while (my ($key, $value) = each %{ $to_api_mapping } ) {
 478             $self->{_from_api_mapping}->{$value} = $key
 479                 if defined $value;
 480         }
 481     }
 482
 483     return $self->{_from_api_mapping};
 484 }
 485
 486 =head3 new_from_api
 487
 488     my $object = Koha::Object->new_from_api;
 489     my $object = Koha::Object->new_from_api( $attrs );
 490
 491 Creates a new object, mapping the API attribute names to the ones on the DB schema.
 492
 493 =cut
 494
 495 sub new_from_api {
 496     my ( $class, $params ) = @_;
 497
 498     my $self = $class->new;
 499     return $self->set_from_api( $params );
 500 }
 501
 502 =head3 set_from_api
 503
 504     my $object = Koha::Object->new(...);
 505     $object->set_from_api( $attrs )
 506
 507 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
 508
 509 =cut
 510
 511 sub set_from_api {
 512     my ( $self, $from_api_params ) = @_;
 513
 514     return $self->set( $self->attributes_from_api( $from_api_params ) );
 515 }
 516
 517 =head3 attributes_from_api
 518
 519     my $attributes = attributes_from_api( $params );
 520
 521 Returns the passed params, converted from API naming into the model.
 522
 523 =cut
 524
 525 sub attributes_from_api {
 526     my ( $self, $from_api_params ) = @_;
 527
 528     my $from_api_mapping = $self->from_api_mapping;
 529
 530     my $params;
 531     my $columns_info = $self->_result->result_source->columns_info;
 532
 533     while (my ($key, $value) = each %{ $from_api_params } ) {
 534         my $koha_field_name =
 535           exists $from_api_mapping->{$key}
 536           ? $from_api_mapping->{$key}
 537           : $key;
 538
 539         if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
 540             # TODO: Remove when D8 is formally deprecated
 541             # Handle booleans gracefully
 542             $value = ( $value ) ? 1 : 0;
 543         }
 544         elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
 545             try {
 546                 $value = dt_from_string($value, 'rfc3339');
 547             }
 548             catch {
 549                 Koha::Exceptions::BadParameter->throw( parameter => $key );
 550             };
 551         }
 552
 553         $params->{$koha_field_name} = $value;
 554     }
 555
 556     return $params;
 557 }
 558
 559 =head3 $object->unblessed_all_relateds
 560
 561 my $everything_into_one_hashref = $object->unblessed_all_relateds
 562
 563 The unblessed method only retrieves column' values for the column of the object.
 564 In a *few* cases we want to retrieve the information of all the prefetched data.
 565
 566 =cut
 567
 568 sub unblessed_all_relateds {
 569     my ($self) = @_;
 570
 571     my %data;
 572     my $related_resultsets = $self->_result->{related_resultsets} || {};
 573     my $rs = $self->_result;
 574     while ( $related_resultsets and %$related_resultsets ) {
 575         my @relations = keys %{ $related_resultsets };
 576         if ( @relations ) {
 577             my $relation = $relations[0];
 578             $rs = $rs->related_resultset($relation)->get_cache;
 579             $rs = $rs->[0]; # Does it makes sense to have several values here?
 580             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 581             my $koha_object = $object_class->_new_from_dbic( $rs );
 582             $related_resultsets = $rs->{related_resultsets};
 583             %data = ( %data, %{ $koha_object->unblessed } );
 584         }
 585     }
 586     %data = ( %data, %{ $self->unblessed } );
 587     return \%data;
 588 }
 589
 590 =head3 $object->_result();
 591
 592 Returns the internal DBIC Row object
 593
 594 =cut
 595
 596 sub _result {
 597     my ($self) = @_;
 598
 599     # If we don't have a dbic row at this point, we need to create an empty one
 600     $self->{_result} ||=
 601       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 602
 603     return $self->{_result};
 604 }
 605
 606 =head3 $object->_columns();
 607
 608 Returns an arrayref of the table columns
 609
 610 =cut
 611
 612 sub _columns {
 613     my ($self) = @_;
 614
 615     # If we don't have a dbic row at this point, we need to create an empty one
 616     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 617
 618     return $self->{_columns};
 619 }
 620
 621 sub _get_object_class {
 622     my ( $type ) = @_;
 623     return unless $type;
 624
 625     if( $type->can('koha_object_class') ) {
 626         return $type->koha_object_class;
 627     }
 628     $type =~ s|Schema::Result::||;
 629     return ${type};
 630 }
 631
 632 =head3 AUTOLOAD
 633
 634 The autoload method is used only to get and set values for an objects properties.
 635
 636 =cut
 637
 638 sub AUTOLOAD {
 639     my $self = shift;
 640
 641     my $method = our $AUTOLOAD;
 642     $method =~ s/.*://;
 643
 644     my @columns = @{$self->_columns()};
 645     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 646     if ( grep {/^$method$/} @columns ) {
 647         if ( @_ ) {
 648             $self->_result()->set_column( $method, @_ );
 649             return $self;
 650         } else {
 651             my $value = $self->_result()->get_column( $method );
 652             return $value;
 653         }
 654     }
 655
 656     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 657
 658     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 659         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 660         show_trace => 1
 661     ) unless grep { /^$method$/ } @known_methods;
 662
 663
 664     my $r = eval { $self->_result->$method(@_) };
 665     if ( $@ ) {
 666         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 667     }
 668     return $r;
 669 }
 670
 671 =head3 _type
 672
 673 This method must be defined in the child class. The value is the name of the DBIC resultset.
 674 For example, for borrowers, the _type method will return "Borrower".
 675
 676 =cut
 677
 678 sub _type { }
 679
 680 =head3 _handle_to_api_child
 681
 682 =cut
 683
 684 sub _handle_to_api_child {
 685     my ($self, $args ) = @_;
 686
 687     my $child = $args->{child};
 688     my $next  = $args->{next};
 689     my $curr  = $args->{curr};
 690
 691     my $res;
 692
 693     if ( defined $child ) {
 694
 695         Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
 696             if defined $next and blessed $child and !$child->can('to_api');
 697
 698         if ( blessed $child ) {
 699             $res = $child->to_api({ embed => $next });
 700         }
 701         else {
 702             $res = $child;
 703         }
 704     }
 705
 706     return $res;
 707 }
 708
 709 sub DESTROY { }
 710
 711 =head1 AUTHOR
 712
 713 Kyle M Hall <kyle@bywatersolutions.com>
 714
 715 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 716
 717 =cut
 718
 719 1;