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;
  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             elsif ( not defined $self->$col
 155                   && $columns_info->{$col}->{datetime_undef_if_invalid} )
 156               {
 157                   # timestamp
 158                   $self->$col( $columns_info->{$col}->{default_value} );
 159               }
 160         }
 161     }
 162
 163     try {
 164         return $self->_result()->update_or_insert() ? $self : undef;
 165     }
 166     catch {
 167         # Catch problems and raise relevant exceptions
 168         if (ref($_) eq 'DBIx::Class::Exception') {
 169             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 170                 # FK constraints
 171                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 172                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 173                     Koha::Exceptions::Object::FKConstraint->throw(
 174                         error     => 'Broken FK constraint',
 175                         broken_fk => $+{column}
 176                     );
 177                 }
 178             }
 179             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 180                 Koha::Exceptions::Object::DuplicateID->throw(
 181                     error => 'Duplicate ID',
 182                     duplicate_id => $+{key}
 183                 );
 184             }
 185             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
 186                 my $type = $+{type};
 187                 my $value = $+{value};
 188                 my $property = $+{property};
 189                 $property =~ s/['`]//g;
 190                 Koha::Exceptions::Object::BadValue->throw(
 191                     type     => $type,
 192                     value    => $value,
 193                     property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
 194                 );
 195             }
 196         }
 197         # Catch-all for foreign key breakages. It will help find other use cases
 198         $_->rethrow();
 199     }
 200 }
 201
 202 =head3 $object->update();
 203
 204 A shortcut for set + store in one call.
 205
 206 =cut
 207
 208 sub update {
 209     my ($self, $values) = @_;
 210     return $self->set($values)->store();
 211 }
 212
 213 =head3 $object->delete();
 214
 215 Removes the object from storage.
 216
 217 Returns:
 218     1  if the deletion was a success
 219     0  if the deletion failed
 220     -1 if the object was never in storage
 221
 222 =cut
 223
 224 sub delete {
 225     my ($self) = @_;
 226
 227     my $deleted = $self->_result()->delete;
 228     if ( ref $deleted ) {
 229         my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 230         $deleted = $object_class->_new_from_dbic($deleted);
 231     }
 232     return $deleted;
 233 }
 234
 235 =head3 $object->set( $properties_hashref )
 236
 237 $object->set(
 238     {
 239         property1 => $property1,
 240         property2 => $property2,
 241         property3 => $propery3,
 242     }
 243 );
 244
 245 Enables multiple properties to be set at once
 246
 247 Returns:
 248     1      if all properties were set.
 249     0      if one or more properties do not exist.
 250     undef  if all properties exist but a different error
 251            prevents one or more properties from being set.
 252
 253 If one or more of the properties do not exist,
 254 no properties will be set.
 255
 256 =cut
 257
 258 sub set {
 259     my ( $self, $properties ) = @_;
 260
 261     my @columns = @{$self->_columns()};
 262
 263     foreach my $p ( keys %$properties ) {
 264         unless ( grep { $_ eq $p } @columns ) {
 265             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 266         }
 267     }
 268
 269     return $self->_result()->set_columns($properties) ? $self : undef;
 270 }
 271
 272 =head3 $object->unblessed();
 273
 274 Returns an unblessed representation of object.
 275
 276 =cut
 277
 278 sub unblessed {
 279     my ($self) = @_;
 280
 281     return { $self->_result->get_columns };
 282 }
 283
 284 =head3 $object->get_from_storage;
 285
 286 =cut
 287
 288 sub get_from_storage {
 289     my ( $self, $attrs ) = @_;
 290     my $stored_object = $self->_result->get_from_storage($attrs);
 291     return unless $stored_object;
 292     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 293     return $object_class->_new_from_dbic($stored_object);
 294 }
 295
 296 =head3 $object->TO_JSON
 297
 298 Returns an unblessed representation of the object, suitable for JSON output.
 299
 300 =cut
 301
 302 sub TO_JSON {
 303
 304     my ($self) = @_;
 305
 306     my $unblessed    = $self->unblessed;
 307     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 308         ->result_source->{_columns};
 309
 310     foreach my $col ( keys %{$columns_info} ) {
 311
 312         if ( $columns_info->{$col}->{is_boolean} )
 313         {    # Handle booleans gracefully
 314             $unblessed->{$col}
 315                 = ( $unblessed->{$col} )
 316                 ? Mojo::JSON->true
 317                 : Mojo::JSON->false;
 318         }
 319         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 320             and looks_like_number( $unblessed->{$col} )
 321         ) {
 322
 323             # TODO: Remove once the solution for
 324             # https://rt.cpan.org/Ticket/Display.html?id=119904
 325             # is ported to whatever distro we support by that time
 326             $unblessed->{$col} += 0;
 327         }
 328         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 329             eval {
 330                 return unless $unblessed->{$col};
 331                 $unblessed->{$col} = output_pref({
 332                     dateformat => 'rfc3339',
 333                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 334                 });
 335             };
 336         }
 337     }
 338     return $unblessed;
 339 }
 340
 341 sub _date_or_datetime_column_type {
 342     my ($column_type) = @_;
 343
 344     my @dt_types = (
 345         'timestamp',
 346         'date',
 347         'datetime'
 348     );
 349
 350     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 351 }
 352 sub _datetime_column_type {
 353     my ($column_type) = @_;
 354
 355     my @dt_types = (
 356         'timestamp',
 357         'datetime'
 358     );
 359
 360     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 361 }
 362
 363 sub _numeric_column_type {
 364     # TODO: Remove once the solution for
 365     # https://rt.cpan.org/Ticket/Display.html?id=119904
 366     # is ported to whatever distro we support by that time
 367     my ($column_type) = @_;
 368
 369     my @numeric_types = (
 370         'bigint',
 371         'integer',
 372         'int',
 373         'mediumint',
 374         'smallint',
 375         'tinyint',
 376         'decimal',
 377         'double precision',
 378         'float'
 379     );
 380
 381     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 382 }
 383
 384 =head3 prefetch_whitelist
 385
 386     my $whitelist = $object->prefetch_whitelist()
 387
 388 Returns a hash of prefetchable subs and the type they return.
 389
 390 =cut
 391
 392 sub prefetch_whitelist {
 393     my ( $self ) = @_;
 394
 395     my $whitelist = {};
 396     my $relations = $self->_result->result_source->_relationships;
 397
 398     foreach my $key (keys %{$relations}) {
 399         if($self->can($key)) {
 400             my $result_class = $relations->{$key}->{class};
 401             my $obj = $result_class->new;
 402             try {
 403                 $whitelist->{$key} = $obj->koha_object_class;
 404             } catch {
 405                 $whitelist->{$key} = undef;
 406             }
 407         }
 408     }
 409
 410     return $whitelist;
 411 }
 412
 413 =head3 to_api
 414
 415     my $object_for_api = $object->to_api(
 416         {
 417           [ embed => {
 418                 items => {
 419                     children => {
 420                         holds => {,
 421                             children => {
 422                               ...
 423                             }
 424                         }
 425                     }
 426                 },
 427                 library => {
 428                     ...
 429                 }
 430             },
 431             ...
 432          ]
 433         }
 434     );
 435
 436 Returns a representation of the object, suitable for API output.
 437
 438 =cut
 439
 440 sub to_api {
 441     my ( $self, $params ) = @_;
 442     my $json_object = $self->TO_JSON;
 443
 444     my $to_api_mapping = $self->to_api_mapping;
 445
 446     # Rename attributes if there's a mapping
 447     if ( $self->can('to_api_mapping') ) {
 448         foreach my $column ( keys %{ $self->to_api_mapping } ) {
 449             my $mapped_column = $self->to_api_mapping->{$column};
 450             if ( exists $json_object->{$column}
 451                 && defined $mapped_column )
 452             {
 453                 # key != undef
 454                 $json_object->{$mapped_column} = delete $json_object->{$column};
 455             }
 456             elsif ( exists $json_object->{$column}
 457                 && !defined $mapped_column )
 458             {
 459                 # key == undef
 460                 delete $json_object->{$column};
 461             }
 462         }
 463     }
 464
 465     my $embeds = $params->{embed};
 466
 467     if ($embeds) {
 468         foreach my $embed ( keys %{$embeds} ) {
 469             if ( $embed =~ m/^(?<relation>.*)_count$/
 470                 and $embeds->{$embed}->{is_count} ) {
 471
 472                 my $relation = $+{relation};
 473                 $json_object->{$embed} = $self->$relation->count;
 474             }
 475             else {
 476                 my $curr = $embed;
 477                 my $next = $embeds->{$curr}->{children};
 478
 479                 my $children = $self->$curr;
 480
 481                 if ( defined $children and ref($children) eq 'ARRAY' ) {
 482                     my @list = map {
 483                         $self->_handle_to_api_child(
 484                             { child => $_, next => $next, curr => $curr } )
 485                     } @{$children};
 486                     $json_object->{$curr} = \@list;
 487                 }
 488                 else {
 489                     $json_object->{$curr} = $self->_handle_to_api_child(
 490                         { child => $children, next => $next, curr => $curr } );
 491                 }
 492             }
 493         }
 494     }
 495
 496
 497
 498     return $json_object;
 499 }
 500
 501 =head3 to_api_mapping
 502
 503     my $mapping = $object->to_api_mapping;
 504
 505 Generic method that returns the attribute name mappings required to
 506 render the object on the API.
 507
 508 Note: this only returns an empty I<hashref>. Each class should have its
 509 own mapping returned.
 510
 511 =cut
 512
 513 sub to_api_mapping {
 514     return {};
 515 }
 516
 517 =head3 from_api_mapping
 518
 519     my $mapping = $object->from_api_mapping;
 520
 521 Generic method that returns the attribute name mappings so the data that
 522 comes from the API is correctly renamed to match what is required for the DB.
 523
 524 =cut
 525
 526 sub from_api_mapping {
 527     my ( $self ) = @_;
 528
 529     my $to_api_mapping = $self->to_api_mapping;
 530
 531     unless ( $self->{_from_api_mapping} ) {
 532         while (my ($key, $value) = each %{ $to_api_mapping } ) {
 533             $self->{_from_api_mapping}->{$value} = $key
 534                 if defined $value;
 535         }
 536     }
 537
 538     return $self->{_from_api_mapping};
 539 }
 540
 541 =head3 new_from_api
 542
 543     my $object = Koha::Object->new_from_api;
 544     my $object = Koha::Object->new_from_api( $attrs );
 545
 546 Creates a new object, mapping the API attribute names to the ones on the DB schema.
 547
 548 =cut
 549
 550 sub new_from_api {
 551     my ( $class, $params ) = @_;
 552
 553     my $self = $class->new;
 554     return $self->set_from_api( $params );
 555 }
 556
 557 =head3 set_from_api
 558
 559     my $object = Koha::Object->new(...);
 560     $object->set_from_api( $attrs )
 561
 562 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
 563
 564 =cut
 565
 566 sub set_from_api {
 567     my ( $self, $from_api_params ) = @_;
 568
 569     return $self->set( $self->attributes_from_api( $from_api_params ) );
 570 }
 571
 572 =head3 attributes_from_api
 573
 574     my $attributes = attributes_from_api( $params );
 575
 576 Returns the passed params, converted from API naming into the model.
 577
 578 =cut
 579
 580 sub attributes_from_api {
 581     my ( $self, $from_api_params ) = @_;
 582
 583     my $from_api_mapping = $self->from_api_mapping;
 584
 585     my $params;
 586     my $columns_info = $self->_result->result_source->columns_info;
 587
 588     while (my ($key, $value) = each %{ $from_api_params } ) {
 589         my $koha_field_name =
 590           exists $from_api_mapping->{$key}
 591           ? $from_api_mapping->{$key}
 592           : $key;
 593
 594         if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
 595             # TODO: Remove when D8 is formally deprecated
 596             # Handle booleans gracefully
 597             $value = ( $value ) ? 1 : 0;
 598         }
 599         elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
 600             try {
 601                 $value = dt_from_string($value, 'rfc3339');
 602             }
 603             catch {
 604                 Koha::Exceptions::BadParameter->throw( parameter => $key );
 605             };
 606         }
 607
 608         $params->{$koha_field_name} = $value;
 609     }
 610
 611     return $params;
 612 }
 613
 614 =head3 $object->unblessed_all_relateds
 615
 616 my $everything_into_one_hashref = $object->unblessed_all_relateds
 617
 618 The unblessed method only retrieves column' values for the column of the object.
 619 In a *few* cases we want to retrieve the information of all the prefetched data.
 620
 621 =cut
 622
 623 sub unblessed_all_relateds {
 624     my ($self) = @_;
 625
 626     my %data;
 627     my $related_resultsets = $self->_result->{related_resultsets} || {};
 628     my $rs = $self->_result;
 629     while ( $related_resultsets and %$related_resultsets ) {
 630         my @relations = keys %{ $related_resultsets };
 631         if ( @relations ) {
 632             my $relation = $relations[0];
 633             $rs = $rs->related_resultset($relation)->get_cache;
 634             $rs = $rs->[0]; # Does it makes sense to have several values here?
 635             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 636             my $koha_object = $object_class->_new_from_dbic( $rs );
 637             $related_resultsets = $rs->{related_resultsets};
 638             %data = ( %data, %{ $koha_object->unblessed } );
 639         }
 640     }
 641     %data = ( %data, %{ $self->unblessed } );
 642     return \%data;
 643 }
 644
 645 =head3 $object->_result();
 646
 647 Returns the internal DBIC Row object
 648
 649 =cut
 650
 651 sub _result {
 652     my ($self) = @_;
 653
 654     # If we don't have a dbic row at this point, we need to create an empty one
 655     $self->{_result} ||=
 656       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 657
 658     return $self->{_result};
 659 }
 660
 661 =head3 $object->_columns();
 662
 663 Returns an arrayref of the table columns
 664
 665 =cut
 666
 667 sub _columns {
 668     my ($self) = @_;
 669
 670     # If we don't have a dbic row at this point, we need to create an empty one
 671     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 672
 673     return $self->{_columns};
 674 }
 675
 676 sub _get_object_class {
 677     my ( $type ) = @_;
 678     return unless $type;
 679
 680     if( $type->can('koha_object_class') ) {
 681         return $type->koha_object_class;
 682     }
 683     $type =~ s|Schema::Result::||;
 684     return ${type};
 685 }
 686
 687 =head3 AUTOLOAD
 688
 689 The autoload method is used only to get and set values for an objects properties.
 690
 691 =cut
 692
 693 sub AUTOLOAD {
 694     my $self = shift;
 695
 696     my $method = our $AUTOLOAD;
 697     $method =~ s/.*://;
 698
 699     my @columns = @{$self->_columns()};
 700     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 701     if ( grep { $_ eq $method } @columns ) {
 702         if ( @_ ) {
 703             $self->_result()->set_column( $method, @_ );
 704             return $self;
 705         } else {
 706             my $value = $self->_result()->get_column( $method );
 707             return $value;
 708         }
 709     }
 710
 711     my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
 712
 713     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 714         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 715         show_trace => 1
 716     ) unless grep { $_ eq $method } @known_methods;
 717
 718
 719     my $r = eval { $self->_result->$method(@_) };
 720     if ( $@ ) {
 721         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 722     }
 723     return $r;
 724 }
 725
 726 =head3 _type
 727
 728 This method must be defined in the child class. The value is the name of the DBIC resultset.
 729 For example, for borrowers, the _type method will return "Borrower".
 730
 731 =cut
 732
 733 sub _type { }
 734
 735 =head3 _handle_to_api_child
 736
 737 =cut
 738
 739 sub _handle_to_api_child {
 740     my ($self, $args ) = @_;
 741
 742     my $child = $args->{child};
 743     my $next  = $args->{next};
 744     my $curr  = $args->{curr};
 745
 746     my $res;
 747
 748     if ( defined $child ) {
 749
 750         Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
 751             if defined $next and blessed $child and !$child->can('to_api');
 752
 753         if ( blessed $child ) {
 754             $res = $child->to_api({ embed => $next });
 755         }
 756         else {
 757             $res = $child;
 758         }
 759     }
 760
 761     return $res;
 762 }
 763
 764 sub DESTROY { }
 765
 766 =head1 AUTHOR
 767
 768 Kyle M Hall <kyle@bywatersolutions.com>
 769
 770 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 771
 772 =cut
 773
 774 1;