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         $self->{_result} = $schema->resultset( $class->_type() )
  76           ->new($attributes);
  77     }
  78
  79     croak("No _type found! Koha::Object must be subclassed!")
  80       unless $class->_type();
  81
  82     bless( $self, $class );
  83
  84 }
  85
  86 =head3 Koha::Object->_new_from_dbic();
  87
  88 my $object = Koha::Object->_new_from_dbic($dbic_row);
  89
  90 =cut
  91
  92 sub _new_from_dbic {
  93     my ( $class, $dbic_row ) = @_;
  94     my $self = {};
  95
  96     # DBIC result row
  97     $self->{_result} = $dbic_row;
  98
  99     croak("No _type found! Koha::Object must be subclassed!")
 100       unless $class->_type();
 101
 102     croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
 103       unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
 104
 105     bless( $self, $class );
 106
 107 }
 108
 109 =head3 $object->store();
 110
 111 Saves the object in storage.
 112 If the object is new, it will be created.
 113 If the object previously existed, it will be updated.
 114
 115 Returns:
 116     $self  if the store was a success
 117     undef  if the store failed
 118
 119 =cut
 120
 121 sub store {
 122     my ($self) = @_;
 123
 124     my $columns_info = $self->_result->result_source->columns_info;
 125
 126     # Handle not null and default values for integers and dates
 127     foreach my $col ( keys %{$columns_info} ) {
 128         # Integers
 129         if ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
 130             # Has been passed but not a number, usually an empty string
 131             if ( defined $self->$col and not looks_like_number( $self->$col ) ) {
 132                 if ( $columns_info->{$col}->{is_nullable} ) {
 133                     # If nullable, default to null
 134                     $self->$col(undef);
 135                 } else {
 136                     # If cannot be null, get the default value
 137                     # What if cannot be null and does not have a default value? Possible?
 138                     $self->$col($columns_info->{$col}->{default_value});
 139                 }
 140             }
 141         }
 142         elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 143             # Set to null if an empty string (or == 0 but should not happen)
 144             $self->$col(undef) unless $self->$col;
 145         }
 146     }
 147
 148     try {
 149         return $self->_result()->update_or_insert() ? $self : undef;
 150     }
 151     catch {
 152         # Catch problems and raise relevant exceptions
 153         if (ref($_) eq 'DBIx::Class::Exception') {
 154             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 155                 # FK constraints
 156                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 157                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 158                     Koha::Exceptions::Object::FKConstraint->throw(
 159                         error     => 'Broken FK constraint',
 160                         broken_fk => $+{column}
 161                     );
 162                 }
 163             }
 164             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 165                 Koha::Exceptions::Object::DuplicateID->throw(
 166                     error => 'Duplicate ID',
 167                     duplicate_id => $+{key}
 168                 );
 169             }
 170             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column '(?<property>\w+)'/ ) {
 171                 Koha::Exceptions::Object::BadValue->throw(
 172                     type     => $+{type},
 173                     value    => $+{value},
 174                     property => $+{property}
 175                 );
 176             }
 177         }
 178         # Catch-all for foreign key breakages. It will help find other use cases
 179         $_->rethrow();
 180     }
 181 }
 182
 183 =head3 $object->delete();
 184
 185 Removes the object from storage.
 186
 187 Returns:
 188     1  if the deletion was a success
 189     0  if the deletion failed
 190     -1 if the object was never in storage
 191
 192 =cut
 193
 194 sub delete {
 195     my ($self) = @_;
 196
 197     # Deleting something not in storage throws an exception
 198     return -1 unless $self->_result()->in_storage();
 199
 200     # Return a boolean for succcess
 201     return $self->_result()->delete() ? 1 : 0;
 202 }
 203
 204 =head3 $object->set( $properties_hashref )
 205
 206 $object->set(
 207     {
 208         property1 => $property1,
 209         property2 => $property2,
 210         property3 => $propery3,
 211     }
 212 );
 213
 214 Enables multiple properties to be set at once
 215
 216 Returns:
 217     1      if all properties were set.
 218     0      if one or more properties do not exist.
 219     undef  if all properties exist but a different error
 220            prevents one or more properties from being set.
 221
 222 If one or more of the properties do not exist,
 223 no properties will be set.
 224
 225 =cut
 226
 227 sub set {
 228     my ( $self, $properties ) = @_;
 229
 230     my @columns = @{$self->_columns()};
 231
 232     foreach my $p ( keys %$properties ) {
 233         unless ( grep {/^$p$/} @columns ) {
 234             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 235         }
 236     }
 237
 238     return $self->_result()->set_columns($properties) ? $self : undef;
 239 }
 240
 241 =head3 $object->unblessed();
 242
 243 Returns an unblessed representation of object.
 244
 245 =cut
 246
 247 sub unblessed {
 248     my ($self) = @_;
 249
 250     return { $self->_result->get_columns };
 251 }
 252
 253 =head3 $object->get_from_storage;
 254
 255 =cut
 256
 257 sub get_from_storage {
 258     my ( $self, $attrs ) = @_;
 259     my $stored_object = $self->_result->get_from_storage($attrs);
 260     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 261     return $object_class->_new_from_dbic($stored_object);
 262 }
 263
 264 =head3 $object->TO_JSON
 265
 266 Returns an unblessed representation of the object, suitable for JSON output.
 267
 268 =cut
 269
 270 sub TO_JSON {
 271
 272     my ($self) = @_;
 273
 274     my $unblessed    = $self->unblessed;
 275     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 276         ->result_source->{_columns};
 277
 278     foreach my $col ( keys %{$columns_info} ) {
 279
 280         if ( $columns_info->{$col}->{is_boolean} )
 281         {    # Handle booleans gracefully
 282             $unblessed->{$col}
 283                 = ( $unblessed->{$col} )
 284                 ? Mojo::JSON->true
 285                 : Mojo::JSON->false;
 286         }
 287         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 288             and looks_like_number( $unblessed->{$col} )
 289         ) {
 290
 291             # TODO: Remove once the solution for
 292             # https://rt.cpan.org/Ticket/Display.html?id=119904
 293             # is ported to whatever distro we support by that time
 294             $unblessed->{$col} += 0;
 295         }
 296         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 297             eval {
 298                 return unless $unblessed->{$col};
 299                 $unblessed->{$col} = output_pref({
 300                     dateformat => 'rfc3339',
 301                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 302                 });
 303             };
 304         }
 305     }
 306     return $unblessed;
 307 }
 308
 309 sub _date_or_datetime_column_type {
 310     my ($column_type) = @_;
 311
 312     my @dt_types = (
 313         'timestamp',
 314         'date',
 315         'datetime'
 316     );
 317
 318     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 319 }
 320 sub _datetime_column_type {
 321     my ($column_type) = @_;
 322
 323     my @dt_types = (
 324         'timestamp',
 325         'datetime'
 326     );
 327
 328     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 329 }
 330
 331 sub _numeric_column_type {
 332     # TODO: Remove once the solution for
 333     # https://rt.cpan.org/Ticket/Display.html?id=119904
 334     # is ported to whatever distro we support by that time
 335     my ($column_type) = @_;
 336
 337     my @numeric_types = (
 338         'bigint',
 339         'integer',
 340         'int',
 341         'mediumint',
 342         'smallint',
 343         'tinyint',
 344         'decimal',
 345         'double precision',
 346         'float'
 347     );
 348
 349     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 350 }
 351
 352 =head3 $object->unblessed_all_relateds
 353
 354 my $everything_into_one_hashref = $object->unblessed_all_relateds
 355
 356 The unblessed method only retrieves column' values for the column of the object.
 357 In a *few* cases we want to retrieve the information of all the prefetched data.
 358
 359 =cut
 360
 361 sub unblessed_all_relateds {
 362     my ($self) = @_;
 363
 364     my %data;
 365     my $related_resultsets = $self->_result->{related_resultsets} || {};
 366     my $rs = $self->_result;
 367     while ( $related_resultsets and %$related_resultsets ) {
 368         my @relations = keys %{ $related_resultsets };
 369         if ( @relations ) {
 370             my $relation = $relations[0];
 371             $rs = $rs->related_resultset($relation)->get_cache;
 372             $rs = $rs->[0]; # Does it makes sense to have several values here?
 373             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 374             my $koha_object = $object_class->_new_from_dbic( $rs );
 375             $related_resultsets = $rs->{related_resultsets};
 376             %data = ( %data, %{ $koha_object->unblessed } );
 377         }
 378     }
 379     %data = ( %data, %{ $self->unblessed } );
 380     return \%data;
 381 }
 382
 383 =head3 $object->_result();
 384
 385 Returns the internal DBIC Row object
 386
 387 =cut
 388
 389 sub _result {
 390     my ($self) = @_;
 391
 392     # If we don't have a dbic row at this point, we need to create an empty one
 393     $self->{_result} ||=
 394       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 395
 396     return $self->{_result};
 397 }
 398
 399 =head3 $object->_columns();
 400
 401 Returns an arrayref of the table columns
 402
 403 =cut
 404
 405 sub _columns {
 406     my ($self) = @_;
 407
 408     # If we don't have a dbic row at this point, we need to create an empty one
 409     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 410
 411     return $self->{_columns};
 412 }
 413
 414 sub _get_object_class {
 415     my ( $type ) = @_;
 416     return unless $type;
 417
 418     if( $type->can('koha_object_class') ) {
 419         return $type->koha_object_class;
 420     }
 421     $type =~ s|Schema::Result::||;
 422     return ${type};
 423 }
 424
 425 =head3 AUTOLOAD
 426
 427 The autoload method is used only to get and set values for an objects properties.
 428
 429 =cut
 430
 431 sub AUTOLOAD {
 432     my $self = shift;
 433
 434     my $method = our $AUTOLOAD;
 435     $method =~ s/.*://;
 436
 437     my @columns = @{$self->_columns()};
 438     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 439     if ( grep {/^$method$/} @columns ) {
 440         if ( @_ ) {
 441             $self->_result()->set_column( $method, @_ );
 442             return $self;
 443         } else {
 444             my $value = $self->_result()->get_column( $method );
 445             return $value;
 446         }
 447     }
 448
 449     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 450
 451     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 452         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 453         show_trace => 1
 454     ) unless grep { /^$method$/ } @known_methods;
 455
 456
 457     my $r = eval { $self->_result->$method(@_) };
 458     if ( $@ ) {
 459         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 460     }
 461     return $r;
 462 }
 463
 464 =head3 _type
 465
 466 This method must be defined in the child class. The value is the name of the DBIC resultset.
 467 For example, for borrowers, the _type method will return "Borrower".
 468
 469 =cut
 470
 471 sub _type { }
 472
 473 sub DESTROY { }
 474
 475 =head1 AUTHOR
 476
 477 Kyle M Hall <kyle@bywatersolutions.com>
 478
 479 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 480
 481 =cut
 482
 483 1;