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