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