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