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