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