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 Try::Tiny;
  26
  27 use Koha::Database;
  28 use Koha::Exceptions::Object;
  29 use Koha::DateUtils;
  30
  31 =head1 NAME
  32
  33 Koha::Object - Koha Object base class
  34
  35 =head1 SYNOPSIS
  36
  37     use Koha::Object;
  38     my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
  39
  40 =head1 DESCRIPTION
  41
  42 This class must always be subclassed.
  43
  44 =head1 API
  45
  46 =head2 Class Methods
  47
  48 =cut
  49
  50 =head3 Koha::Object->new();
  51
  52 my $object = Koha::Object->new();
  53 my $object = Koha::Object->new($attributes);
  54
  55 Note that this cannot be used to retrieve record from the DB.
  56
  57 =cut
  58
  59 sub new {
  60     my ( $class, $attributes ) = @_;
  61     my $self = {};
  62
  63     if ($attributes) {
  64         my $schema = Koha::Database->new->schema;
  65
  66         # Remove the arguments which exist, are not defined but NOT NULL to use the default value
  67         my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
  68         for my $column_name ( keys %$attributes ) {
  69             my $c_info = $columns_info->{$column_name};
  70             next if $c_info->{is_nullable};
  71             next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
  72             delete $attributes->{$column_name};
  73         }
  74         $self->{_result} = $schema->resultset( $class->_type() )
  75           ->new($attributes);
  76     }
  77
  78     croak("No _type found! Koha::Object must be subclassed!")
  79       unless $class->_type();
  80
  81     bless( $self, $class );
  82
  83 }
  84
  85 =head3 Koha::Object->_new_from_dbic();
  86
  87 my $object = Koha::Object->_new_from_dbic($dbic_row);
  88
  89 =cut
  90
  91 sub _new_from_dbic {
  92     my ( $class, $dbic_row ) = @_;
  93     my $self = {};
  94
  95     # DBIC result row
  96     $self->{_result} = $dbic_row;
  97
  98     croak("No _type found! Koha::Object must be subclassed!")
  99       unless $class->_type();
 100
 101     croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
 102       unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
 103
 104     bless( $self, $class );
 105
 106 }
 107
 108 =head3 $object->store();
 109
 110 Saves the object in storage.
 111 If the object is new, it will be created.
 112 If the object previously existed, it will be updated.
 113
 114 Returns:
 115     $self  if the store was a success
 116     undef  if the store failed
 117
 118 =cut
 119
 120 sub store {
 121     my ($self) = @_;
 122
 123     try {
 124         return $self->_result()->update_or_insert() ? $self : undef;
 125     }
 126     catch {
 127         # Catch problems and raise relevant exceptions
 128         if (ref($_) eq 'DBIx::Class::Exception') {
 129             if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
 130                 # FK constraints
 131                 # FIXME: MySQL error, if we support more DB engines we should implement this for each
 132                 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
 133                     Koha::Exceptions::Object::FKConstraint->throw(
 134                         error     => 'Broken FK constraint',
 135                         broken_fk => $+{column}
 136                     );
 137                 }
 138             }
 139             elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
 140                 Koha::Exceptions::Object::DuplicateID->throw(
 141                     error => 'Duplicate ID',
 142                     duplicate_id => $+{key}
 143                 );
 144             }
 145         }
 146         # Catch-all for foreign key breakages. It will help find other use cases
 147         $_->rethrow();
 148     }
 149 }
 150
 151 =head3 $object->delete();
 152
 153 Removes the object from storage.
 154
 155 Returns:
 156     1  if the deletion was a success
 157     0  if the deletion failed
 158     -1 if the object was never in storage
 159
 160 =cut
 161
 162 sub delete {
 163     my ($self) = @_;
 164
 165     # Deleting something not in storage throws an exception
 166     return -1 unless $self->_result()->in_storage();
 167
 168     # Return a boolean for succcess
 169     return $self->_result()->delete() ? 1 : 0;
 170 }
 171
 172 =head3 $object->set( $properties_hashref )
 173
 174 $object->set(
 175     {
 176         property1 => $property1,
 177         property2 => $property2,
 178         property3 => $propery3,
 179     }
 180 );
 181
 182 Enables multiple properties to be set at once
 183
 184 Returns:
 185     1      if all properties were set.
 186     0      if one or more properties do not exist.
 187     undef  if all properties exist but a different error
 188            prevents one or more properties from being set.
 189
 190 If one or more of the properties do not exist,
 191 no properties will be set.
 192
 193 =cut
 194
 195 sub set {
 196     my ( $self, $properties ) = @_;
 197
 198     my @columns = @{$self->_columns()};
 199
 200     foreach my $p ( keys %$properties ) {
 201         unless ( grep {/^$p$/} @columns ) {
 202             Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
 203         }
 204     }
 205
 206     return $self->_result()->set_columns($properties) ? $self : undef;
 207 }
 208
 209 =head3 $object->unblessed();
 210
 211 Returns an unblessed representation of object.
 212
 213 =cut
 214
 215 sub unblessed {
 216     my ($self) = @_;
 217
 218     return { $self->_result->get_columns };
 219 }
 220
 221 =head3 $object->TO_JSON
 222
 223 Returns an unblessed representation of the object, suitable for JSON output.
 224
 225 =cut
 226
 227 sub TO_JSON {
 228
 229     my ($self) = @_;
 230
 231     my $unblessed    = $self->unblessed;
 232     my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
 233         ->result_source->{_columns};
 234
 235     foreach my $col ( keys %{$columns_info} ) {
 236
 237         if ( $columns_info->{$col}->{is_boolean} )
 238         {    # Handle booleans gracefully
 239             $unblessed->{$col}
 240                 = ( $unblessed->{$col} )
 241                 ? Mojo::JSON->true
 242                 : Mojo::JSON->false;
 243         }
 244         elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
 245
 246             # TODO: Remove once the solution for
 247             # https://rt.cpan.org/Ticket/Display.html?id=119904
 248             # is ported to whatever distro we support by that time
 249             $unblessed->{$col} += 0;
 250         }
 251         elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
 252             eval {
 253                 return unless $unblessed->{$col};
 254                 $unblessed->{$col} = output_pref({
 255                     dateformat => 'rfc3339',
 256                     dt         => dt_from_string($unblessed->{$col}, 'sql'),
 257                 });
 258             };
 259         }
 260     }
 261     return $unblessed;
 262 }
 263
 264 sub _datetime_column_type {
 265     my ($column_type) = @_;
 266
 267     my @dt_types = (
 268         'timestamp',
 269         'datetime'
 270     );
 271
 272     return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
 273 }
 274
 275 sub _numeric_column_type {
 276     # TODO: Remove once the solution for
 277     # https://rt.cpan.org/Ticket/Display.html?id=119904
 278     # is ported to whatever distro we support by that time
 279     my ($column_type) = @_;
 280
 281     my @numeric_types = (
 282         'bigint',
 283         'integer',
 284         'int',
 285         'mediumint',
 286         'smallint',
 287         'tinyint',
 288         'decimal',
 289         'double precision',
 290         'float'
 291     );
 292
 293     return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
 294 }
 295
 296 =head3 $object->unblessed_all_relateds
 297
 298 my $everything_into_one_hashref = $object->unblessed_all_relateds
 299
 300 The unblessed method only retrieves column' values for the column of the object.
 301 In a *few* cases we want to retrieve the information of all the prefetched data.
 302
 303 =cut
 304
 305 sub unblessed_all_relateds {
 306     my ($self) = @_;
 307
 308     my %data;
 309     my $related_resultsets = $self->_result->{related_resultsets} || {};
 310     my $rs = $self;
 311     while ( $related_resultsets and %$related_resultsets ) {
 312         my @relations = keys %{ $related_resultsets };
 313         if ( @relations ) {
 314             my $relation = $relations[0];
 315             $rs = $rs->related_resultset($relation)->get_cache;
 316             $rs = $rs->[0]; # Does it makes sense to have several values here?
 317             my $object_class = Koha::Object::_get_object_class( $rs->result_class );
 318             my $koha_object = $object_class->_new_from_dbic( $rs );
 319             $related_resultsets = $rs->{related_resultsets};
 320             %data = ( %data, %{ $koha_object->unblessed } );
 321         }
 322     }
 323     %data = ( %data, %{ $self->unblessed } );
 324     return \%data;
 325 }
 326
 327 =head3 $object->_result();
 328
 329 Returns the internal DBIC Row object
 330
 331 =cut
 332
 333 sub _result {
 334     my ($self) = @_;
 335
 336     # If we don't have a dbic row at this point, we need to create an empty one
 337     $self->{_result} ||=
 338       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 339
 340     return $self->{_result};
 341 }
 342
 343 =head3 $object->_columns();
 344
 345 Returns an arrayref of the table columns
 346
 347 =cut
 348
 349 sub _columns {
 350     my ($self) = @_;
 351
 352     # If we don't have a dbic row at this point, we need to create an empty one
 353     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 354
 355     return $self->{_columns};
 356 }
 357
 358 sub _get_object_class {
 359     my ( $type ) = @_;
 360     return unless $type;
 361
 362     if( $type->can('koha_object_class') ) {
 363         return $type->koha_object_class;
 364     }
 365     $type =~ s|Schema::Result::||;
 366     return ${type};
 367 }
 368
 369 =head3 AUTOLOAD
 370
 371 The autoload method is used only to get and set values for an objects properties.
 372
 373 =cut
 374
 375 sub AUTOLOAD {
 376     my $self = shift;
 377
 378     my $method = our $AUTOLOAD;
 379     $method =~ s/.*://;
 380
 381     my @columns = @{$self->_columns()};
 382     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 383     if ( grep {/^$method$/} @columns ) {
 384         if ( @_ ) {
 385             $self->_result()->set_column( $method, @_ );
 386             return $self;
 387         } else {
 388             my $value = $self->_result()->get_column( $method );
 389             return $value;
 390         }
 391     }
 392
 393     my @known_methods = qw( is_changed id in_storage get_column discard_changes update related_resultset );
 394
 395     Koha::Exceptions::Object::MethodNotCoveredByTests->throw( "The method $method is not covered by tests!" ) unless grep {/^$method$/} @known_methods;
 396
 397     my $r = eval { $self->_result->$method(@_) };
 398     if ( $@ ) {
 399         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 400     }
 401     return $r;
 402 }
 403
 404 =head3 _type
 405
 406 This method must be defined in the child class. The value is the name of the DBIC resultset.
 407 For example, for borrowers, the _type method will return "Borrower".
 408
 409 =cut
 410
 411 sub _type { }
 412
 413 sub DESTROY { }
 414
 415 =head1 AUTHOR
 416
 417 Kyle M Hall <kyle@bywatersolutions.com>
 418
 419 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 420
 421 =cut
 422
 423 1;