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