Bug 19828: Make Koha::Object->store translate DBIC exceptions into Koha exceptions

[koha_ffzg] / Koha / Object.pm

diff --git a/Koha/Object.pm b/Koha/Object.pm
index cf55089..17609f2 100644 (file)
--- a/Koha/Object.pm
+++ b/Koha/Object.pm
@@ -21,8 +21,12 @@ package Koha::Object;
 use Modern::Perl;
 
 use Carp;
+use Mojo::JSON;
+use Try::Tiny;
 
 use Koha::Database;
+use Koha::Exceptions::Object;
+use Koha::DateUtils;
 
 =head1 NAME
 
@@ -57,8 +61,17 @@ sub new {
     my $self = {};
 
     if ($attributes) {
-        $self->{_result} =
-          Koha::Database->new()->schema()->resultset( $class->_type() )
+        my $schema = Koha::Database->new->schema;
+
+        # Remove the arguments which exist, are not defined but NOT NULL to use the default value
+        my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
+        for my $column_name ( keys %$attributes ) {
+            my $c_info = $columns_info->{$column_name};
+            next if $c_info->{is_nullable};
+            next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
+            delete $attributes->{$column_name};
+        }
+        $self->{_result} = $schema->resultset( $class->_type() )
           ->new($attributes);
     }
 
@@ -107,7 +120,32 @@ Returns:
 sub store {
     my ($self) = @_;
 
-    return $self->_result()->update_or_insert() ? $self : undef;
+    try {
+        return $self->_result()->update_or_insert() ? $self : undef;
+    }
+    catch {
+        # Catch problems and raise relevant exceptions
+        if (ref($_) eq 'DBIx::Class::Exception') {
+            if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
+                # FK constraints
+                # FIXME: MySQL error, if we support more DB engines we should implement this for each
+                if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
+                    Koha::Exceptions::Object::FKConstraint->throw(
+                        error     => 'Broken FK constraint',
+                        broken_fk => $+{column}
+                    );
+                }
+            }
+            elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
+                Koha::Exceptions::Object::DuplicateID->throw(
+                    error => 'Duplicate ID',
+                    duplicate_id => $+{key}
+                );
+            }
+            # Catch-all for foreign key breakages. It will help find other use cases
+            $->rethrow();
+        }
+    }
 }
 
 =head3 $object->delete();
@@ -124,7 +162,7 @@ Returns:
 sub delete {
     my ($self) = @_;
 
-    # Deleting something not in storage thows an exception
+    # Deleting something not in storage throws an exception
     return -1 unless $self->_result()->in_storage();
 
     # Return a boolean for succcess
@@ -161,8 +199,7 @@ sub set {
 
     foreach my $p ( keys %$properties ) {
         unless ( grep {/^$p$/} @columns ) {
-            carp("No property $p!");
-            return 0;
+            Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
         }
     }
 
@@ -181,6 +218,81 @@ sub unblessed {
     return { $self->_result->get_columns };
 }
 
+=head3 $object->TO_JSON
+
+Returns an unblessed representation of the object, suitable for JSON output.
+
+=cut
+
+sub TO_JSON {
+
+    my ($self) = @_;
+
+    my $unblessed    = $self->unblessed;
+    my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
+        ->result_source->{_columns};
+
+    foreach my $col ( keys %{$columns_info} ) {
+
+        if ( $columns_info->{$col}->{is_boolean} )
+        {    # Handle booleans gracefully
+            $unblessed->{$col}
+                = ( $unblessed->{$col} )
+                ? Mojo::JSON->true
+                : Mojo::JSON->false;
+        }
+        elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
+
+            # TODO: Remove once the solution for
+            # https://rt.cpan.org/Ticket/Display.html?id=119904
+            # is ported to whatever distro we support by that time
+            $unblessed->{$col} += 0;
+        }
+        elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
+            eval {
+                return unless $unblessed->{$col};
+                $unblessed->{$col} = output_pref({
+                    dateformat => 'rfc3339',
+                    dt         => dt_from_string($unblessed->{$col}, 'sql'),
+                });
+            };
+        }
+    }
+    return $unblessed;
+}
+
+sub _datetime_column_type {
+    my ($column_type) = @_;
+
+    my @dt_types = (
+        'timestamp',
+        'datetime'
+    );
+
+    return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
+}
+
+sub _numeric_column_type {
+    # TODO: Remove once the solution for
+    # https://rt.cpan.org/Ticket/Display.html?id=119904
+    # is ported to whatever distro we support by that time
+    my ($column_type) = @_;
+
+    my @numeric_types = (
+        'bigint',
+        'integer',
+        'int',
+        'mediumint',
+        'smallint',
+        'tinyint',
+        'decimal',
+        'double precision',
+        'float'
+    );
+
+    return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
+}
+
 =head3 $object->_result();
 
 Returns the internal DBIC Row object
@@ -212,7 +324,6 @@ sub _columns {
     return $self->{_columns};
 }
 
-
 =head3 AUTOLOAD
 
 The autoload method is used only to get and set values for an objects properties.
@@ -237,14 +348,12 @@ sub AUTOLOAD {
         }
     }
 
-    my @known_methods = qw( is_changed id in_storage get_column );
-
-    carp "The method $method is not covered by tests or does not exist!" and return unless grep {/^$method$/} @known_methods;
+    my @known_methods = qw( is_changed id in_storage get_column discard_changes update );
+    Koha::Exceptions::Object::MethodNotCoveredByTests->throw( "The method $method is not covered by tests!" ) unless grep {/^$method$/} @known_methods;
 
     my $r = eval { $self->_result->$method(@_) };
     if ( $@ ) {
-        carp "No method $method found for " . ref($self) . " " . $@;
-        return
+        Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
     }
     return $r;
 }