#
# This file is part of Koha.
#
-# Koha is free software; you can redistribute it and/or modify it under the
-# terms of the GNU General Public License as published by the Free Software
-# Foundation; either version 3 of the License, or (at your option) any later
-# version.
+# Koha is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
#
-# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
-# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
-# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+# Koha is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
#
-# You should have received a copy of the GNU General Public License along
-# with Koha; if not, write to the Free Software Foundation, Inc.,
-# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use Carp;
use Mojo::JSON;
-use Scalar::Util qw( looks_like_number );
+use Scalar::Util qw( blessed looks_like_number );
use Try::Tiny;
use Koha::Database;
# Handle not null and default values for integers and dates
foreach my $col ( keys %{$columns_info} ) {
# Integers
- if ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
+ if ( _numeric_column_type( $columns_info->{$col}->{data_type} )
+ or _decimal_column_type( $columns_info->{$col}->{data_type} )
+ ) {
# Has been passed but not a number, usually an empty string
- if ( defined $self->$col and not looks_like_number( $self->$col ) ) {
+ my $value = $self->_result()->get_column($col);
+ if ( defined $value and not looks_like_number( $value ) ) {
if ( $columns_info->{$col}->{is_nullable} ) {
# If nullable, default to null
- $self->$col(undef);
+ $self->_result()->set_column($col => undef);
} else {
# If cannot be null, get the default value
# What if cannot be null and does not have a default value? Possible?
- $self->$col($columns_info->{$col}->{default_value});
+ $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
}
}
}
elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
# Set to null if an empty string (or == 0 but should not happen)
- if ( defined $self->$col and not $self->$col ) {
+ my $value = $self->_result()->get_column($col);
+ if ( defined $value and not $value ) {
if ( $columns_info->{$col}->{is_nullable} ) {
- $self->$col(undef);
+ $self->_result()->set_column($col => undef);
} else {
- $self->$col($columns_info->{$col}->{default_value});
+ $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
}
}
+ elsif ( not defined $self->$col
+ && $columns_info->{$col}->{datetime_undef_if_invalid} )
+ {
+ # timestamp
+ $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
+ }
}
}
catch {
# Catch problems and raise relevant exceptions
if (ref($_) eq 'DBIx::Class::Exception') {
+ warn $_->{msg};
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
sub update {
my ($self, $values) = @_;
- return $self->set($values)->store();
+ Koha::Exceptions::Object::NotInStorage->throw unless $self->in_storage;
+ $self->set($values)->store();
}
=head3 $object->delete();
my @columns = @{$self->_columns()};
foreach my $p ( keys %$properties ) {
- unless ( grep {/^$p$/} @columns ) {
+ unless ( grep { $_ eq $p } @columns ) {
Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
}
}
return $self->_result()->set_columns($properties) ? $self : undef;
}
+=head3 $object->set_or_blank( $properties_hashref )
+
+$object->set_or_blank(
+ {
+ property1 => $property1,
+ property2 => $property2,
+ property3 => $propery3,
+ }
+);
+
+If not listed in $properties_hashref, the property will be set to the default
+value defined at DB level, or nulled.
+
+=cut
+
+
+sub set_or_blank {
+ my ( $self, $properties ) = @_;
+
+ my $columns_info = $self->_result->result_source->columns_info;
+
+ foreach my $col ( keys %{$columns_info} ) {
+
+ next if exists $properties->{$col};
+
+ if ( $columns_info->{$col}->{is_nullable} ) {
+ $properties->{$col} = undef;
+ } else {
+ $properties->{$col} = $columns_info->{$col}->{default_value};
+ }
+ }
+
+ return $self->set($properties);
+}
+
=head3 $object->unblessed();
Returns an unblessed representation of object.
sub get_from_storage {
my ( $self, $attrs ) = @_;
my $stored_object = $self->_result->get_from_storage($attrs);
+ return unless $stored_object;
my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
return $object_class->_new_from_dbic($stored_object);
}
) {
# TODO: Remove once the solution for
- # https://rt.cpan.org/Ticket/Display.html?id=119904
+ # https://github.com/perl5-dbi/DBD-mysql/issues/212
# is ported to whatever distro we support by that time
+ # or we move to DBD::MariaDB
$unblessed->{$col} += 0;
}
+ elsif ( _decimal_column_type( $columns_info->{$col}->{data_type} )
+ and looks_like_number( $unblessed->{$col} )
+ ) {
+
+ # TODO: Remove once the solution for
+ # https://github.com/perl5-dbi/DBD-mysql/issues/212
+ # is ported to whatever distro we support by that time
+ # or we move to DBD::MariaDB
+ $unblessed->{$col} += 0.00;
+ }
elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
eval {
return unless $unblessed->{$col};
sub _numeric_column_type {
# TODO: Remove once the solution for
- # https://rt.cpan.org/Ticket/Display.html?id=119904
+ # https://github.com/perl5-dbi/DBD-mysql/issues/212
# is ported to whatever distro we support by that time
+ # or we move to DBD::MariaDB
my ($column_type) = @_;
my @numeric_types = (
'mediumint',
'smallint',
'tinyint',
+ );
+
+ return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
+}
+
+sub _decimal_column_type {
+ # TODO: Remove once the solution for
+ # https://github.com/perl5-dbi/DBD-mysql/issues/212
+ # is ported to whatever distro we support by that time
+ # or we move to DBD::MariaDB
+ my ($column_type) = @_;
+
+ my @decimal_types = (
'decimal',
'double precision',
'float'
);
- return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
+ return ( grep { $column_type eq $_ } @decimal_types) ? 1 : 0;
+}
+
+=head3 prefetch_whitelist
+
+ my $whitelist = $object->prefetch_whitelist()
+
+Returns a hash of prefetchable subs and the type they return.
+
+=cut
+
+sub prefetch_whitelist {
+ my ( $self ) = @_;
+
+ my $whitelist = {};
+ my $relations = $self->_result->result_source->_relationships;
+
+ foreach my $key (keys %{$relations}) {
+ if($self->can($key)) {
+ my $result_class = $relations->{$key}->{class};
+ my $obj = $result_class->new;
+ try {
+ $whitelist->{$key} = Koha::Object::_get_object_class( $obj->result_class );
+ } catch {
+ $whitelist->{$key} = undef;
+ }
+ }
+ }
+
+ return $whitelist;
}
=head3 to_api
- my $object_for_api = $object->to_api;
+ my $object_for_api = $object->to_api(
+ {
+ [ embed => {
+ items => {
+ children => {
+ holds => {,
+ children => {
+ ...
+ }
+ }
+ }
+ },
+ library => {
+ ...
+ }
+ },
+ ...
+ ]
+ }
+ );
Returns a representation of the object, suitable for API output.
=cut
sub to_api {
- my ( $self ) = @_;
+ my ( $self, $params ) = @_;
my $json_object = $self->TO_JSON;
my $to_api_mapping = $self->to_api_mapping;
# Rename attributes if there's a mapping
- foreach my $column ( keys %{$to_api_mapping} ) {
- my $mapped_column = $to_api_mapping->{$column};
- if ( exists $json_object->{$column}
- && defined $mapped_column )
- {
- # key != undef
- $json_object->{$mapped_column} = delete $json_object->{$column};
+ if ( $self->can('to_api_mapping') ) {
+ foreach my $column ( keys %{ $self->to_api_mapping } ) {
+ my $mapped_column = $self->to_api_mapping->{$column};
+ if ( exists $json_object->{$column}
+ && defined $mapped_column )
+ {
+ # key != undef
+ $json_object->{$mapped_column} = delete $json_object->{$column};
+ }
+ elsif ( exists $json_object->{$column}
+ && !defined $mapped_column )
+ {
+ # key == undef
+ delete $json_object->{$column};
+ }
}
- elsif ( exists $json_object->{$column}
- && !defined $mapped_column )
- {
- # key == undef
- delete $json_object->{$column};
+ }
+
+ my $embeds = $params->{embed};
+
+ if ($embeds) {
+ foreach my $embed ( keys %{$embeds} ) {
+ if ( $embed =~ m/^(?<relation>.*)_count$/
+ and $embeds->{$embed}->{is_count} ) {
+
+ my $relation = $+{relation};
+ $json_object->{$embed} = $self->$relation->count;
+ }
+ else {
+ my $curr = $embed;
+ my $next = $embeds->{$curr}->{children};
+
+ my $children = $self->$curr;
+
+ if ( defined $children and ref($children) eq 'ARRAY' ) {
+ my @list = map {
+ $self->_handle_to_api_child(
+ { child => $_, next => $next, curr => $curr } )
+ } @{$children};
+ $json_object->{$curr} = \@list;
+ }
+ else {
+ $json_object->{$curr} = $self->_handle_to_api_child(
+ { child => $children, next => $next, curr => $curr } );
+ }
+ }
}
}
+
+
return $json_object;
}
my $from_api_mapping = $self->from_api_mapping;
my $params;
+ my $columns_info = $self->_result->result_source->columns_info;
while (my ($key, $value) = each %{ $from_api_params } ) {
- if ( exists $from_api_mapping->{$key} ) {
- $params->{$from_api_mapping->{$key}} = $value;
+ my $koha_field_name =
+ exists $from_api_mapping->{$key}
+ ? $from_api_mapping->{$key}
+ : $key;
+
+ if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
+ # TODO: Remove when D8 is formally deprecated
+ # Handle booleans gracefully
+ $value = ( $value ) ? 1 : 0;
}
- else {
- $params->{$key} = $value;
+ elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
+ try {
+ $value = dt_from_string($value, 'rfc3339');
+ }
+ catch {
+ Koha::Exceptions::BadParameter->throw( parameter => $key );
+ };
}
+
+ $params->{$koha_field_name} = $value;
}
return $params;
my @columns = @{$self->_columns()};
# Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
- if ( grep {/^$method$/} @columns ) {
+ if ( grep { $_ eq $method } @columns ) {
if ( @_ ) {
$self->_result()->set_column( $method, @_ );
return $self;
Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
show_trace => 1
- ) unless grep { /^$method$/ } @known_methods;
+ ) unless grep { $_ eq $method } @known_methods;
my $r = eval { $self->_result->$method(@_) };
sub _type { }
+=head3 _handle_to_api_child
+
+=cut
+
+sub _handle_to_api_child {
+ my ($self, $args ) = @_;
+
+ my $child = $args->{child};
+ my $next = $args->{next};
+ my $curr = $args->{curr};
+
+ my $res;
+
+ if ( defined $child ) {
+
+ Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
+ if defined $next and blessed $child and !$child->can('to_api');
+
+ if ( blessed $child ) {
+ $res = $child->to_api({ embed => $next });
+ }
+ else {
+ $res = $child;
+ }
+ }
+
+ return $res;
+}
+
sub DESTROY { }
=head1 AUTHOR