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