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