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             my $value = $self->_result()->get_column($col);
 132             if ( defined $value and not looks_like_number( $value ) ) {
 133                 if ( $columns_info->{$col}->{is_nullable} ) {
 134                     # If nullable, default to null
 135                     $self->_result()->set_column($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->_result()->set_column($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             my $value = $self->_result()->get_column($col);
 146             if ( defined $value and not $value ) {
 147                 if ( $columns_info->{$col}->{is_nullable} ) {
 148                     $self->_result()->set_column($col => undef);
 149                 } else {
 150                     $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
 151                 }
 152             }
 153         }
 154     }
 155
 156     try {
 157         return $self->_result()->update_or_insert() ? $self : undef;
 158     }
 159     catch {
 160         # Catch problems and raise relevant exceptions
 161         if (ref($_) eq 'DBIx::Class::Exception') {
 162             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 163                 # FK constraints
 164                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 165                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 166                     Koha::Exceptions::Object::FKConstraint->throw(
 167                         error     => 'Broken FK constraint',
 168                         broken_fk => $+{column}
 169                     );
 170                 }
 171             }
 172             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 173                 Koha::Exceptions::Object::DuplicateID->throw(
 174                     error => 'Duplicate ID',
 175                     duplicate_id => $+{key}
 176                 );
 177             }
 178             elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column '(?<property>\w+)'/ ) {
 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     return unless $stored_object;
 269     my $object_class  = Koha::Object::_get_object_class( $self->_result->result_class );
 270     return $object_class->_new_from_dbic($stored_object);
 271 }
 272
 273 =head3 $object->TO_JSON
 274
 275 Returns an unblessed representation of the object, suitable for JSON output.
 276
 277 =cut
 278
 279 sub TO_JSON {
 280
 281     my ($self) = @_;
 282
 283     my $unblessed    = $self->unblessed;
 284     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 285         ->result_source->{_columns};
 286
 287     foreach my $col ( keys %{$columns_info} ) {
 288
 289         if ( $columns_info->{$col}->{is_boolean} )
 290         {    # Handle booleans gracefully
 291             $unblessed->{$col}
 292                 = ( $unblessed->{$col} )
 293                 ? Mojo::JSON->true
 294                 : Mojo::JSON->false;
 295         }
 296         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
 297             and looks_like_number( $unblessed->{$col} )
 298         ) {
 299
 300             # TODO: Remove once the solution for
 301             # https://rt.cpan.org/Ticket/Display.html?id=119904
 302             # is ported to whatever distro we support by that time
 303             $unblessed->{$col} += 0;
 304         }
 305         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 306             eval {
 307                 return unless $unblessed->{$col};
 308                 $unblessed->{$col} = output_pref({
 309                     dateformat => 'rfc3339',
 310                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 311                 });
 312             };
 313         }
 314     }
 315     return $unblessed;
 316 }
 317
 318 sub _date_or_datetime_column_type {
 319     my ($column_type) = @_;
 320
 321     my @dt_types = (
 322         'timestamp',
 323         'date',
 324         'datetime'
 325     );
 326
 327     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 328 }
 329 sub _datetime_column_type {
 330     my ($column_type) = @_;
 331
 332     my @dt_types = (
 333         'timestamp',
 334         'datetime'
 335     );
 336
 337     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 338 }
 339
 340 sub _numeric_column_type {
 341     # TODO: Remove once the solution for
 342     # https://rt.cpan.org/Ticket/Display.html?id=119904
 343     # is ported to whatever distro we support by that time
 344     my ($column_type) = @_;
 345
 346     my @numeric_types = (
 347         'bigint',
 348         'integer',
 349         'int',
 350         'mediumint',
 351         'smallint',
 352         'tinyint',
 353         'decimal',
 354         'double precision',
 355         'float'
 356     );
 357
 358     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 359 }
 360
 361 =head3 $object->unblessed_all_relateds
 362
 363 my $everything_into_one_hashref = $object->unblessed_all_relateds
 364
 365 The unblessed method only retrieves column' values for the column of the object.
 366 In a *few* cases we want to retrieve the information of all the prefetched data.
 367
 368 =cut
 369
 370 sub unblessed_all_relateds {
 371     my ($self) = @_;
 372
 373     my %data;
 374     my $related_resultsets = $self->_result->{related_resultsets} || {};
 375     my $rs = $self->_result;
 376     while ( $related_resultsets and %$related_resultsets ) {
 377         my @relations = keys %{ $related_resultsets };
 378         if ( @relations ) {
 379             my $relation = $relations[0];
 380             $rs = $rs->related_resultset($relation)->get_cache;
 381             $rs = $rs->[0]; # Does it makes sense to have several values here?
 382             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 383             my $koha_object = $object_class->_new_from_dbic( $rs );
 384             $related_resultsets = $rs->{related_resultsets};
 385             %data = ( %data, %{ $koha_object->unblessed } );
 386         }
 387     }
 388     %data = ( %data, %{ $self->unblessed } );
 389     return \%data;
 390 }
 391
 392 =head3 $object->_result();
 393
 394 Returns the internal DBIC Row object
 395
 396 =cut
 397
 398 sub _result {
 399     my ($self) = @_;
 400
 401     # If we don't have a dbic row at this point, we need to create an empty one
 402     $self->{_result} ||=
 403       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 404
 405     return $self->{_result};
 406 }
 407
 408 =head3 $object->_columns();
 409
 410 Returns an arrayref of the table columns
 411
 412 =cut
 413
 414 sub _columns {
 415     my ($self) = @_;
 416
 417     # If we don't have a dbic row at this point, we need to create an empty one
 418     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 419
 420     return $self->{_columns};
 421 }
 422
 423 sub _get_object_class {
 424     my ( $type ) = @_;
 425     return unless $type;
 426
 427     if( $type->can('koha_object_class') ) {
 428         return $type->koha_object_class;
 429     }
 430     $type =~ s|Schema::Result::||;
 431     return ${type};
 432 }
 433
 434 =head3 AUTOLOAD
 435
 436 The autoload method is used only to get and set values for an objects properties.
 437
 438 =cut
 439
 440 sub AUTOLOAD {
 441     my $self = shift;
 442
 443     my $method = our $AUTOLOAD;
 444     $method =~ s/.*://;
 445
 446     my @columns = @{$self->_columns()};
 447     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 448     if ( grep {/^$method$/} @columns ) {
 449         if ( @_ ) {
 450             $self->_result()->set_column( $method, @_ );
 451             return $self;
 452         } else {
 453             my $value = $self->_result()->get_column( $method );
 454             return $value;
 455         }
 456     }
 457
 458     my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
 459
 460     Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
 461         error      => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
 462         show_trace => 1
 463     ) unless grep { /^$method$/ } @known_methods;
 464
 465
 466     my $r = eval { $self->_result->$method(@_) };
 467     if ( $@ ) {
 468         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 469     }
 470     return $r;
 471 }
 472
 473 =head3 _type
 474
 475 This method must be defined in the child class. The value is the name of the DBIC resultset.
 476 For example, for borrowers, the _type method will return "Borrower".
 477
 478 =cut
 479
 480 sub _type { }
 481
 482 sub DESTROY { }
 483
 484 =head1 AUTHOR
 485
 486 Kyle M Hall <kyle@bywatersolutions.com>
 487
 488 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 489
 490 =cut
 491
 492 1;