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