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