Bug 23584: Add the controller method and tests
[koha.git] / Koha / Object.pm
blob04d34c49e305137a18b9e5bf23d1e1b564b65900
1 package Koha::Object;
3 # Copyright ByWater Solutions 2014
4 # Copyright 2016 Koha Development Team
6 # This file is part of Koha.
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.
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.
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.
21 use Modern::Perl;
23 use Carp;
24 use Mojo::JSON;
25 use Scalar::Util qw( looks_like_number );
26 use Try::Tiny;
28 use Koha::Database;
29 use Koha::Exceptions::Object;
30 use Koha::DateUtils;
32 =head1 NAME
34 Koha::Object - Koha Object base class
36 =head1 SYNOPSIS
38 use Koha::Object;
39 my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
41 =head1 DESCRIPTION
43 This class must always be subclassed.
45 =head1 API
47 =head2 Class Methods
49 =cut
51 =head3 Koha::Object->new();
53 my $object = Koha::Object->new();
54 my $object = Koha::Object->new($attributes);
56 Note that this cannot be used to retrieve record from the DB.
58 =cut
60 sub new {
61 my ( $class, $attributes ) = @_;
62 my $self = {};
64 if ($attributes) {
65 my $schema = Koha::Database->new->schema;
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};
76 $self->{_result} =
77 $schema->resultset( $class->_type() )->new($attributes);
80 croak("No _type found! Koha::Object must be subclassed!")
81 unless $class->_type();
83 bless( $self, $class );
87 =head3 Koha::Object->_new_from_dbic();
89 my $object = Koha::Object->_new_from_dbic($dbic_row);
91 =cut
93 sub _new_from_dbic {
94 my ( $class, $dbic_row ) = @_;
95 my $self = {};
97 # DBIC result row
98 $self->{_result} = $dbic_row;
100 croak("No _type found! Koha::Object must be subclassed!")
101 unless $class->_type();
103 croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
104 unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
106 bless( $self, $class );
110 =head3 $object->store();
112 Saves the object in storage.
113 If the object is new, it will be created.
114 If the object previously existed, it will be updated.
116 Returns:
117 $self if the store was a success
118 undef if the store failed
120 =cut
122 sub store {
123 my ($self) = @_;
125 my $columns_info = $self->_result->result_source->columns_info;
127 # Handle not null and default values for integers and dates
128 foreach my $col ( keys %{$columns_info} ) {
129 # Integers
130 if ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
131 # Has been passed but not a number, usually an empty string
132 if ( defined $self->$col and not looks_like_number( $self->$col ) ) {
133 if ( $columns_info->{$col}->{is_nullable} ) {
134 # If nullable, default to null
135 $self->$col(undef);
136 } else {
137 # If cannot be null, get the default value
138 # What if cannot be null and does not have a default value? Possible?
139 $self->$col($columns_info->{$col}->{default_value});
143 elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
144 # Set to null if an empty string (or == 0 but should not happen)
145 if ( defined $self->$col and not $self->$col ) {
146 if ( $columns_info->{$col}->{is_nullable} ) {
147 $self->$col(undef);
148 } else {
149 $self->$col($columns_info->{$col}->{default_value});
155 try {
156 return $self->_result()->update_or_insert() ? $self : undef;
158 catch {
159 # Catch problems and raise relevant exceptions
160 if (ref($_) eq 'DBIx::Class::Exception') {
161 if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
162 # FK constraints
163 # FIXME: MySQL error, if we support more DB engines we should implement this for each
164 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
165 Koha::Exceptions::Object::FKConstraint->throw(
166 error => 'Broken FK constraint',
167 broken_fk => $+{column}
171 elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
172 Koha::Exceptions::Object::DuplicateID->throw(
173 error => 'Duplicate ID',
174 duplicate_id => $+{key}
177 elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column '(?<property>\w+)'/ ) {
178 Koha::Exceptions::Object::BadValue->throw(
179 type => $+{type},
180 value => $+{value},
181 property => $+{property}
185 # Catch-all for foreign key breakages. It will help find other use cases
186 $_->rethrow();
190 =head3 $object->delete();
192 Removes the object from storage.
194 Returns:
195 1 if the deletion was a success
196 0 if the deletion failed
197 -1 if the object was never in storage
199 =cut
201 sub delete {
202 my ($self) = @_;
204 # Deleting something not in storage throws an exception
205 return -1 unless $self->_result()->in_storage();
207 # Return a boolean for succcess
208 return $self->_result()->delete() ? 1 : 0;
211 =head3 $object->set( $properties_hashref )
213 $object->set(
215 property1 => $property1,
216 property2 => $property2,
217 property3 => $propery3,
221 Enables multiple properties to be set at once
223 Returns:
224 1 if all properties were set.
225 0 if one or more properties do not exist.
226 undef if all properties exist but a different error
227 prevents one or more properties from being set.
229 If one or more of the properties do not exist,
230 no properties will be set.
232 =cut
234 sub set {
235 my ( $self, $properties ) = @_;
237 my @columns = @{$self->_columns()};
239 foreach my $p ( keys %$properties ) {
240 unless ( grep {/^$p$/} @columns ) {
241 Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
245 return $self->_result()->set_columns($properties) ? $self : undef;
248 =head3 $object->unblessed();
250 Returns an unblessed representation of object.
252 =cut
254 sub unblessed {
255 my ($self) = @_;
257 return { $self->_result->get_columns };
260 =head3 $object->get_from_storage;
262 =cut
264 sub get_from_storage {
265 my ( $self, $attrs ) = @_;
266 my $stored_object = $self->_result->get_from_storage($attrs);
267 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
268 return $object_class->_new_from_dbic($stored_object);
271 =head3 $object->TO_JSON
273 Returns an unblessed representation of the object, suitable for JSON output.
275 =cut
277 sub TO_JSON {
279 my ($self) = @_;
281 my $unblessed = $self->unblessed;
282 my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
283 ->result_source->{_columns};
285 foreach my $col ( keys %{$columns_info} ) {
287 if ( $columns_info->{$col}->{is_boolean} )
288 { # Handle booleans gracefully
289 $unblessed->{$col}
290 = ( $unblessed->{$col} )
291 ? Mojo::JSON->true
292 : Mojo::JSON->false;
294 elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
295 and looks_like_number( $unblessed->{$col} )
298 # TODO: Remove once the solution for
299 # https://rt.cpan.org/Ticket/Display.html?id=119904
300 # is ported to whatever distro we support by that time
301 $unblessed->{$col} += 0;
303 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
304 eval {
305 return unless $unblessed->{$col};
306 $unblessed->{$col} = output_pref({
307 dateformat => 'rfc3339',
308 dt => dt_from_string($unblessed->{$col}, 'sql'),
313 return $unblessed;
316 sub _date_or_datetime_column_type {
317 my ($column_type) = @_;
319 my @dt_types = (
320 'timestamp',
321 'date',
322 'datetime'
325 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
327 sub _datetime_column_type {
328 my ($column_type) = @_;
330 my @dt_types = (
331 'timestamp',
332 'datetime'
335 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
338 sub _numeric_column_type {
339 # TODO: Remove once the solution for
340 # https://rt.cpan.org/Ticket/Display.html?id=119904
341 # is ported to whatever distro we support by that time
342 my ($column_type) = @_;
344 my @numeric_types = (
345 'bigint',
346 'integer',
347 'int',
348 'mediumint',
349 'smallint',
350 'tinyint',
351 'decimal',
352 'double precision',
353 'float'
356 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
359 =head3 $object->unblessed_all_relateds
361 my $everything_into_one_hashref = $object->unblessed_all_relateds
363 The unblessed method only retrieves column' values for the column of the object.
364 In a *few* cases we want to retrieve the information of all the prefetched data.
366 =cut
368 sub unblessed_all_relateds {
369 my ($self) = @_;
371 my %data;
372 my $related_resultsets = $self->_result->{related_resultsets} || {};
373 my $rs = $self->_result;
374 while ( $related_resultsets and %$related_resultsets ) {
375 my @relations = keys %{ $related_resultsets };
376 if ( @relations ) {
377 my $relation = $relations[0];
378 $rs = $rs->related_resultset($relation)->get_cache;
379 $rs = $rs->[0]; # Does it makes sense to have several values here?
380 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
381 my $koha_object = $object_class->_new_from_dbic( $rs );
382 $related_resultsets = $rs->{related_resultsets};
383 %data = ( %data, %{ $koha_object->unblessed } );
386 %data = ( %data, %{ $self->unblessed } );
387 return \%data;
390 =head3 $object->_result();
392 Returns the internal DBIC Row object
394 =cut
396 sub _result {
397 my ($self) = @_;
399 # If we don't have a dbic row at this point, we need to create an empty one
400 $self->{_result} ||=
401 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
403 return $self->{_result};
406 =head3 $object->_columns();
408 Returns an arrayref of the table columns
410 =cut
412 sub _columns {
413 my ($self) = @_;
415 # If we don't have a dbic row at this point, we need to create an empty one
416 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
418 return $self->{_columns};
421 sub _get_object_class {
422 my ( $type ) = @_;
423 return unless $type;
425 if( $type->can('koha_object_class') ) {
426 return $type->koha_object_class;
428 $type =~ s|Schema::Result::||;
429 return ${type};
432 =head3 AUTOLOAD
434 The autoload method is used only to get and set values for an objects properties.
436 =cut
438 sub AUTOLOAD {
439 my $self = shift;
441 my $method = our $AUTOLOAD;
442 $method =~ s/.*://;
444 my @columns = @{$self->_columns()};
445 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
446 if ( grep {/^$method$/} @columns ) {
447 if ( @_ ) {
448 $self->_result()->set_column( $method, @_ );
449 return $self;
450 } else {
451 my $value = $self->_result()->get_column( $method );
452 return $value;
456 my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
458 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
459 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
460 show_trace => 1
461 ) unless grep { /^$method$/ } @known_methods;
464 my $r = eval { $self->_result->$method(@_) };
465 if ( $@ ) {
466 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
468 return $r;
471 =head3 _type
473 This method must be defined in the child class. The value is the name of the DBIC resultset.
474 For example, for borrowers, the _type method will return "Borrower".
476 =cut
478 sub _type { }
480 sub DESTROY { }
482 =head1 AUTHOR
484 Kyle M Hall <kyle@bywatersolutions.com>
486 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
488 =cut