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