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->_result();
 297
 298 Returns the internal DBIC Row object
 299
 300 =cut
 301
 302 sub _result {
 303     my ($self) = @_;
 304
 305     # If we don't have a dbic row at this point, we need to create an empty one
 306     $self->{_result} ||=
 307       Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
 308
 309     return $self->{_result};
 310 }
 311
 312 =head3 $object->_columns();
 313
 314 Returns an arrayref of the table columns
 315
 316 =cut
 317
 318 sub _columns {
 319     my ($self) = @_;
 320
 321     # If we don't have a dbic row at this point, we need to create an empty one
 322     $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
 323
 324     return $self->{_columns};
 325 }
 326
 327 =head3 AUTOLOAD
 328
 329 The autoload method is used only to get and set values for an objects properties.
 330
 331 =cut
 332
 333 sub AUTOLOAD {
 334     my $self = shift;
 335
 336     my $method = our $AUTOLOAD;
 337     $method =~ s/.*://;
 338
 339     my @columns = @{$self->_columns()};
 340     # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
 341     if ( grep {/^$method$/} @columns ) {
 342         if ( @_ ) {
 343             $self->_result()->set_column( $method, @_ );
 344             return $self;
 345         } else {
 346             my $value = $self->_result()->get_column( $method );
 347             return $value;
 348         }
 349     }
 350
 351     my @known_methods = qw( is_changed id in_storage get_column discard_changes update );
 352     Koha::Exceptions::Object::MethodNotCoveredByTests->throw( "The method $method is not covered by tests!" ) unless grep {/^$method$/} @known_methods;
 353
 354     my $r = eval { $self->_result->$method(@_) };
 355     if ( $@ ) {
 356         Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
 357     }
 358     return $r;
 359 }
 360
 361 =head3 _type
 362
 363 This method must be defined in the child class. The value is the name of the DBIC resultset.
 364 For example, for borrowers, the _type method will return "Borrower".
 365
 366 =cut
 367
 368 sub _type { }
 369
 370 sub DESTROY { }
 371
 372 =head1 AUTHOR
 373
 374 Kyle M Hall <kyle@bywatersolutions.com>
 375
 376 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
 377
 378 =cut
 379
 380 1;