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