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( 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+)/ ) {
 178             # The optional \W in the regex might be a quote or backtick
 179                 Koha::Exceptions::Object::BadValue->throw(
 180                     type     => $+{type},
 181                     value    => $+{value},
 182                     property => $+{property},
 183                 );
 184             }
 185         }
 186         # Catch-all for foreign key breakages. It will help find other use cases
 187         $_->rethrow();
 188     }
 189 }
 190
 191 =head3 $object->delete();
 192
 193 Removes the object from storage.
 194
 195 Returns:
 196     1  if the deletion was a success
 197     0  if the deletion failed
 198     -1 if the object was never in storage
 199
 200 =cut
 201
 202 sub delete {
 203     my ($self) = @_;
 204
 205     # Deleting something not in storage throws an exception
 206     return -1 unless $self->_result()->in_storage();
 207
 208     # Return a boolean for succcess
 209     return $self->_result()->delete() ? 1 : 0;
 210 }
 211
 212 =head3 $object->set( $properties_hashref )
 213
 214 $object->set(
 215     {
 216         property1 => $property1,
 217         property2 => $property2,
 218         property3 => $propery3,
 219     }
 220 );
 221
 222 Enables multiple properties to be set at once
 223
 224 Returns:
 225     1      if all properties were set.
 226     0      if one or more properties do not exist.
 227     undef  if all properties exist but a different error
 228            prevents one or more properties from being set.
 229
 230 If one or more of the properties do not exist,
 231 no properties will be set.
 232
 233 =cut
 234
 235 sub set {
 236     my ( $self, $properties ) = @_;
 237
 238     my @columns = @{$self->_columns()};
 239
 240     foreach my $p ( keys %$properties ) {
 241         unless ( grep {/^$p$/} @columns ) {
 242             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 243         }
 244     }
 245
 246     return $self->_result()->set_columns($properties) ? $self : undef;
 247 }
 248
 249 =head3 $object->unblessed();
 250
 251 Returns an unblessed representation of object.
 252
 253 =cut
 254
 255 sub unblessed {
 256     my ($self) = @_;
 257
 258     return { $self->_result->get_columns };
 259 }
 260
 261 =head3 $object->get_from_storage;
 262
 263 =cut
 264
 265 sub get_from_storage {
 266     my ( $self, $attrs ) = @_;
 267     my $stored_object = $self->_result->get_from_storage($attrs);
 268     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 269     return $object_class->_new_from_dbic($stored_object);
 270 }
 271
 272 =head3 $object->TO_JSON
 273
 274 Returns an unblessed representation of the object, suitable for JSON output.
 275
 276 =cut
 277
 278 sub TO_JSON {
 279
 280     my ($self) = @_;
 281
 282     my $unblessed    = $self->unblessed;
 283     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 284         ->result_source->{_columns};
 285
 286     foreach my $col ( keys %{$columns_info} ) {
 287
 288         if ( $columns_info->{$col}->{is_boolean} )
 289         {    # Handle booleans gracefully
 290             $unblessed->{$col}
 291                 = ( $unblessed->{$col} )
 292                 ? Mojo::JSON->true
 293                 : Mojo::JSON->false;
 294         }
 295         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 296             and looks_like_number( $unblessed->{$col} )
 297         ) {
 298
 299             # TODO: Remove once the solution for
 300             # https://rt.cpan.org/Ticket/Display.html?id=119904
 301             # is ported to whatever distro we support by that time
 302             $unblessed->{$col} += 0;
 303         }
 304         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 305             eval {
 306                 return unless $unblessed->{$col};
 307                 $unblessed->{$col} = output_pref({
 308                     dateformat => 'rfc3339',
 309                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 310                 });
 311             };
 312         }
 313     }
 314     return $unblessed;
 315 }
 316
 317 sub _date_or_datetime_column_type {
 318     my ($column_type) = @_;
 319
 320     my @dt_types = (
 321         'timestamp',
 322         'date',
 323         'datetime'
 324     );
 325
 326     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 327 }
 328 sub _datetime_column_type {
 329     my ($column_type) = @_;
 330
 331     my @dt_types = (
 332         'timestamp',
 333         'datetime'
 334     );
 335
 336     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 337 }
 338
 339 sub _numeric_column_type {
 340     # TODO: Remove once the solution for
 341     # https://rt.cpan.org/Ticket/Display.html?id=119904
 342     # is ported to whatever distro we support by that time
 343     my ($column_type) = @_;
 344
 345     my @numeric_types = (
 346         'bigint',
 347         'integer',
 348         'int',
 349         'mediumint',
 350         'smallint',
 351         'tinyint',
 352         'decimal',
 353         'double precision',
 354         'float'
 355     );
 356
 357     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 358 }
 359
 360 =head3 to_api
 361
 362     my $object_for_api = $object->to_api;
 363
 364 Returns a representation of the object, suitable for API output.
 365
 366 =cut
 367
 368 sub to_api {
 369     my ( $self ) = @_;
 370     my $json_object = $self->TO_JSON;
 371
 372     # Rename attributes if there's a mapping
 373     if ( $self->can('to_api_mapping') ) {
 374         foreach my $column ( keys %{$self->to_api_mapping} ) {
 375             my $mapped_column = $self->to_api_mapping->{$column};
 376             if ( exists $json_object->{$column}
 377                 && defined $mapped_column )
 378             {
 379                 # key != undef
 380                 $json_object->{$mapped_column} = delete $json_object->{$column};
 381             }
 382             elsif ( exists $json_object->{$column}
 383                 && !defined $mapped_column )
 384             {
 385                 # key == undef
 386                 delete $json_object->{$column};
 387             }
 388         }
 389     }
 390
 391     return $json_object;
 392 }
 393
 394 =head3 $object->unblessed_all_relateds
 395
 396 my $everything_into_one_hashref = $object->unblessed_all_relateds
 397
 398 The unblessed method only retrieves column' values for the column of the object.
 399 In a *few* cases we want to retrieve the information of all the prefetched data.
 400
 401 =cut
 402
 403 sub unblessed_all_relateds {
 404     my ($self) = @_;
 405
 406     my %data;
 407     my $related_resultsets = $self->_result->{related_resultsets} || {};
 408     my $rs = $self->_result;
 409     while ( $related_resultsets and %$related_resultsets ) {
 410         my @relations = keys %{ $related_resultsets };
 411         if ( @relations ) {
 412             my $relation = $relations[0];
 413             $rs = $rs->related_resultset($relation)->get_cache;
 414             $rs = $rs->[0]; # Does it makes sense to have several values here?
 415             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 416             my $koha_object = $object_class->_new_from_dbic( $rs );
 417             $related_resultsets = $rs->{related_resultsets};
 418             %data = ( %data, %{ $koha_object->unblessed } );
 419         }
 420     }
 421     %data = ( %data, %{ $self->unblessed } );
 422     return \%data;
 423 }
 424
 425 =head3 $object->_result();
 426
 427 Returns the internal DBIC Row object
 428
 429 =cut
 430
 431 sub _result {
 432     my ($self) = @_;
 433
 434     # If we don't have a dbic row at this point, we need to create an empty one
 435     $self->{_result} ||=
 436       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 437
 438     return $self->{_result};
 439 }
 440
 441 =head3 $object->_columns();
 442
 443 Returns an arrayref of the table columns
 444
 445 =cut
 446
 447 sub _columns {
 448     my ($self) = @_;
 449
 450     # If we don't have a dbic row at this point, we need to create an empty one
 451     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 452
 453     return $self->{_columns};
 454 }
 455
 456 sub _get_object_class {
 457     my ( $type ) = @_;
 458     return unless $type;
 459
 460     if( $type->can('koha_object_class') ) {
 461         return $type->koha_object_class;
 462     }
 463     $type =~ s|Schema::Result::||;
 464     return ${type};
 465 }
 466
 467 =head3 AUTOLOAD
 468
 469 The autoload method is used only to get and set values for an objects properties.
 470
 471 =cut
 472
 473 sub AUTOLOAD {
 474     my $self = shift;
 475
 476     my $method = our $AUTOLOAD;
 477     $method =~ s/.*://;
 478
 479     my @columns = @{$self->_columns()};
 480     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 481     if ( grep {/^$method$/} @columns ) {
 482         if ( @_ ) {
 483             $self->_result()->set_column( $method, @_ );
 484             return $self;
 485         } else {
 486             my $value = $self->_result()->get_column( $method );
 487             return $value;
 488         }
 489     }
 490
 491     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 492
 493     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 494         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 495         show_trace => 1
 496     ) unless grep { /^$method$/ } @known_methods;
 497
 498
 499     my $r = eval { $self->_result->$method(@_) };
 500     if ( $@ ) {
 501         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 502     }
 503     return $r;
 504 }
 505
 506 =head3 _type
 507
 508 This method must be defined in the child class. The value is the name of the DBIC resultset.
 509 For example, for borrowers, the _type method will return "Borrower".
 510
 511 =cut
 512
 513 sub _type { }
 514
 515 sub DESTROY { }
 516
 517 =head1 AUTHOR
 518
 519 Kyle M Hall <kyle@bywatersolutions.com>
 520
 521 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 522
 523 =cut
 524
 525 1;