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
9 # under the terms of the GNU General Public License as published by
10 # the Free Software Foundation; either version 3 of the License, or
11 # (at your option) any later version.
13 # Koha is distributed in the hope that it will be useful, but
14 # WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
25 use Scalar
::Util
qw( blessed looks_like_number );
29 use Koha
::Exceptions
::Object
;
31 use Koha
::Object
::Message
;
35 Koha::Object - Koha Object base class
40 my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
44 This class must always be subclassed.
52 =head3 Koha::Object->new();
54 my $object = Koha::Object->new();
55 my $object = Koha::Object->new($attributes);
57 Note that this cannot be used to retrieve record from the DB.
62 my ( $class, $attributes ) = @_;
66 my $schema = Koha
::Database
->new->schema;
68 # Remove the arguments which exist, are not defined but NOT NULL to use the default value
69 my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
70 for my $column_name ( keys %$attributes ) {
71 my $c_info = $columns_info->{$column_name};
72 next if $c_info->{is_nullable
};
73 next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
74 delete $attributes->{$column_name};
78 $schema->resultset( $class->_type() )->new($attributes);
81 $self->{_messages
} = [];
83 croak
("No _type found! Koha::Object must be subclassed!")
84 unless $class->_type();
86 bless( $self, $class );
90 =head3 Koha::Object->_new_from_dbic();
92 my $object = Koha::Object->_new_from_dbic($dbic_row);
97 my ( $class, $dbic_row ) = @_;
101 $self->{_result
} = $dbic_row;
103 croak
("No _type found! Koha::Object must be subclassed!")
104 unless $class->_type();
106 croak
( "DBIC result _type " . ref( $self->{_result
} ) . " isn't of the _type " . $class->_type() )
107 unless ref( $self->{_result
} ) eq "Koha::Schema::Result::" . $class->_type();
109 bless( $self, $class );
113 =head3 $object->store();
115 Saves the object in storage.
116 If the object is new, it will be created.
117 If the object previously existed, it will be updated.
120 $self if the store was a success
121 undef if the store failed
128 my $columns_info = $self->_result->result_source->columns_info;
130 # Handle not null and default values for integers and dates
131 foreach my $col ( keys %{$columns_info} ) {
133 if ( _numeric_column_type
( $columns_info->{$col}->{data_type
} )
134 or _decimal_column_type
( $columns_info->{$col}->{data_type
} )
136 # Has been passed but not a number, usually an empty string
137 my $value = $self->_result()->get_column($col);
138 if ( defined $value and not looks_like_number
( $value ) ) {
139 if ( $columns_info->{$col}->{is_nullable
} ) {
140 # If nullable, default to null
141 $self->_result()->set_column($col => undef);
143 # If cannot be null, get the default value
144 # What if cannot be null and does not have a default value? Possible?
145 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
149 elsif ( _date_or_datetime_column_type
( $columns_info->{$col}->{data_type
} ) ) {
150 # Set to null if an empty string (or == 0 but should not happen)
151 my $value = $self->_result()->get_column($col);
152 if ( defined $value and not $value ) {
153 if ( $columns_info->{$col}->{is_nullable
} ) {
154 $self->_result()->set_column($col => undef);
156 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
159 elsif ( not defined $self->$col
160 && $columns_info->{$col}->{datetime_undef_if_invalid
} )
163 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
169 return $self->_result()->update_or_insert() ?
$self : undef;
172 # Catch problems and raise relevant exceptions
173 if (ref($_) eq 'DBIx::Class::Exception') {
175 if ( $_->{msg
} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
177 # FIXME: MySQL error, if we support more DB engines we should implement this for each
178 if ( $_->{msg
} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
179 Koha
::Exceptions
::Object
::FKConstraint
->throw(
180 error
=> 'Broken FK constraint',
181 broken_fk
=> $+{column
}
185 elsif( $_->{msg
} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
186 Koha
::Exceptions
::Object
::DuplicateID
->throw(
187 error
=> 'Duplicate ID',
188 duplicate_id
=> $+{key
}
191 elsif( $_->{msg
} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
193 my $value = $+{value
};
194 my $property = $+{property
};
195 $property =~ s/['`]//g;
196 Koha
::Exceptions
::Object
::BadValue
->throw(
199 property
=> $property =~ /(\w+\.\w+)$/ ?
$1 : $property, # results in table.column without quotes or backtics
203 # Catch-all for foreign key breakages. It will help find other use cases
208 =head3 $object->update();
210 A shortcut for set + store in one call.
215 my ($self, $values) = @_;
216 Koha
::Exceptions
::Object
::NotInStorage
->throw unless $self->in_storage;
217 $self->set($values)->store();
220 =head3 $object->delete();
222 Removes the object from storage.
225 1 if the deletion was a success
226 0 if the deletion failed
227 -1 if the object was never in storage
234 my $deleted = $self->_result()->delete;
235 if ( ref $deleted ) {
236 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
237 $deleted = $object_class->_new_from_dbic($deleted);
242 =head3 $object->set( $properties_hashref )
246 property1 => $property1,
247 property2 => $property2,
248 property3 => $propery3,
252 Enables multiple properties to be set at once
255 1 if all properties were set.
256 0 if one or more properties do not exist.
257 undef if all properties exist but a different error
258 prevents one or more properties from being set.
260 If one or more of the properties do not exist,
261 no properties will be set.
266 my ( $self, $properties ) = @_;
268 my @columns = @
{$self->_columns()};
270 foreach my $p ( keys %$properties ) {
271 unless ( grep { $_ eq $p } @columns ) {
272 Koha
::Exceptions
::Object
::PropertyNotFound
->throw( "No property $p for " . ref($self) );
276 return $self->_result()->set_columns($properties) ?
$self : undef;
279 =head3 $object->set_or_blank( $properties_hashref )
281 $object->set_or_blank(
283 property1 => $property1,
284 property2 => $property2,
285 property3 => $propery3,
289 If not listed in $properties_hashref, the property will be set to the default
290 value defined at DB level, or nulled.
296 my ( $self, $properties ) = @_;
298 my $columns_info = $self->_result->result_source->columns_info;
300 foreach my $col ( keys %{$columns_info} ) {
302 next if exists $properties->{$col};
304 if ( $columns_info->{$col}->{is_nullable
} ) {
305 $properties->{$col} = undef;
307 $properties->{$col} = $columns_info->{$col}->{default_value
};
311 return $self->set($properties);
314 =head3 $object->unblessed();
316 Returns an unblessed representation of object.
323 return { $self->_result->get_columns };
326 =head3 $object->get_from_storage;
330 sub get_from_storage
{
331 my ( $self, $attrs ) = @_;
332 my $stored_object = $self->_result->get_from_storage($attrs);
333 return unless $stored_object;
334 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
335 return $object_class->_new_from_dbic($stored_object);
338 =head3 $object->messages
340 my @messages = @{ $object->messages };
342 Returns the (probably non-fatal) messages that were recorded on the object.
349 $self->{_messages
} = []
350 unless defined $self->{_messages
};
352 return $self->{_messages
};
355 =head3 $object->add_message
358 <some action that might fail>
361 if ( <fatal condition> ) {
362 Koha::Exception->throw...
365 # This is a non fatal error, notify the caller
366 $self->add_message({ message => $error, type => 'error' });
375 my ( $self, $params ) = @_;
377 push @
{ $self->{_messages
} }, Koha
::Object
::Message
->new($params);
382 =head3 $object->TO_JSON
384 Returns an unblessed representation of the object, suitable for JSON output.
392 my $unblessed = $self->unblessed;
393 my $columns_info = Koha
::Database
->new->schema->resultset( $self->_type )
394 ->result_source->{_columns
};
396 foreach my $col ( keys %{$columns_info} ) {
398 if ( $columns_info->{$col}->{is_boolean
} )
399 { # Handle booleans gracefully
401 = ( $unblessed->{$col} )
405 elsif ( _numeric_column_type
( $columns_info->{$col}->{data_type
} )
406 and looks_like_number
( $unblessed->{$col} )
409 # TODO: Remove once the solution for
410 # https://github.com/perl5-dbi/DBD-mysql/issues/212
411 # is ported to whatever distro we support by that time
412 # or we move to DBD::MariaDB
413 $unblessed->{$col} += 0;
415 elsif ( _decimal_column_type
( $columns_info->{$col}->{data_type
} )
416 and looks_like_number
( $unblessed->{$col} )
419 # TODO: Remove once the solution for
420 # https://github.com/perl5-dbi/DBD-mysql/issues/212
421 # is ported to whatever distro we support by that time
422 # or we move to DBD::MariaDB
423 $unblessed->{$col} += 0.00;
425 elsif ( _datetime_column_type
( $columns_info->{$col}->{data_type
} ) ) {
427 return unless $unblessed->{$col};
428 $unblessed->{$col} = output_pref
({
429 dateformat
=> 'rfc3339',
430 dt
=> dt_from_string
($unblessed->{$col}, 'sql'),
438 sub _date_or_datetime_column_type
{
439 my ($column_type) = @_;
447 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
449 sub _datetime_column_type
{
450 my ($column_type) = @_;
457 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
460 sub _numeric_column_type
{
461 # TODO: Remove once the solution for
462 # https://github.com/perl5-dbi/DBD-mysql/issues/212
463 # is ported to whatever distro we support by that time
464 # or we move to DBD::MariaDB
465 my ($column_type) = @_;
467 my @numeric_types = (
476 return ( grep { $column_type eq $_ } @numeric_types) ?
1 : 0;
479 sub _decimal_column_type
{
480 # TODO: Remove once the solution for
481 # https://github.com/perl5-dbi/DBD-mysql/issues/212
482 # is ported to whatever distro we support by that time
483 # or we move to DBD::MariaDB
484 my ($column_type) = @_;
486 my @decimal_types = (
492 return ( grep { $column_type eq $_ } @decimal_types) ?
1 : 0;
495 =head3 prefetch_whitelist
497 my $whitelist = $object->prefetch_whitelist()
499 Returns a hash of prefetchable subs and the type they return.
503 sub prefetch_whitelist
{
507 my $relations = $self->_result->result_source->_relationships;
509 foreach my $key (keys %{$relations}) {
510 if($self->can($key)) {
511 my $result_class = $relations->{$key}->{class};
512 my $obj = $result_class->new;
514 $whitelist->{$key} = Koha
::Object
::_get_object_class
( $obj->result_class );
516 $whitelist->{$key} = undef;
526 my $object_for_api = $object->to_api(
547 Returns a representation of the object, suitable for API output.
552 my ( $self, $params ) = @_;
553 my $json_object = $self->TO_JSON;
555 my $to_api_mapping = $self->to_api_mapping;
557 # Rename attributes if there's a mapping
558 if ( $self->can('to_api_mapping') ) {
559 foreach my $column ( keys %{ $self->to_api_mapping } ) {
560 my $mapped_column = $self->to_api_mapping->{$column};
561 if ( exists $json_object->{$column}
562 && defined $mapped_column )
565 $json_object->{$mapped_column} = delete $json_object->{$column};
567 elsif ( exists $json_object->{$column}
568 && !defined $mapped_column )
571 delete $json_object->{$column};
576 my $embeds = $params->{embed
};
579 foreach my $embed ( keys %{$embeds} ) {
580 if ( $embed =~ m/^(?<relation>.*)_count$/
581 and $embeds->{$embed}->{is_count
} ) {
583 my $relation = $+{relation
};
584 $json_object->{$embed} = $self->$relation->count;
588 my $next = $embeds->{$curr}->{children
};
590 my $children = $self->$curr;
592 if ( defined $children and ref($children) eq 'ARRAY' ) {
594 $self->_handle_to_api_child(
595 { child
=> $_, next => $next, curr
=> $curr } )
597 $json_object->{$curr} = \
@list;
600 $json_object->{$curr} = $self->_handle_to_api_child(
601 { child
=> $children, next => $next, curr
=> $curr } );
612 =head3 to_api_mapping
614 my $mapping = $object->to_api_mapping;
616 Generic method that returns the attribute name mappings required to
617 render the object on the API.
619 Note: this only returns an empty I<hashref>. Each class should have its
620 own mapping returned.
628 =head3 from_api_mapping
630 my $mapping = $object->from_api_mapping;
632 Generic method that returns the attribute name mappings so the data that
633 comes from the API is correctly renamed to match what is required for the DB.
637 sub from_api_mapping
{
640 my $to_api_mapping = $self->to_api_mapping;
642 unless ( $self->{_from_api_mapping
} ) {
643 while (my ($key, $value) = each %{ $to_api_mapping } ) {
644 $self->{_from_api_mapping
}->{$value} = $key
649 return $self->{_from_api_mapping
};
654 my $object = Koha::Object->new_from_api;
655 my $object = Koha::Object->new_from_api( $attrs );
657 Creates a new object, mapping the API attribute names to the ones on the DB schema.
662 my ( $class, $params ) = @_;
664 my $self = $class->new;
665 return $self->set_from_api( $params );
670 my $object = Koha::Object->new(...);
671 $object->set_from_api( $attrs )
673 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
678 my ( $self, $from_api_params ) = @_;
680 return $self->set( $self->attributes_from_api( $from_api_params ) );
683 =head3 attributes_from_api
685 my $attributes = attributes_from_api( $params );
687 Returns the passed params, converted from API naming into the model.
691 sub attributes_from_api
{
692 my ( $self, $from_api_params ) = @_;
694 my $from_api_mapping = $self->from_api_mapping;
697 my $columns_info = $self->_result->result_source->columns_info;
699 while (my ($key, $value) = each %{ $from_api_params } ) {
700 my $koha_field_name =
701 exists $from_api_mapping->{$key}
702 ?
$from_api_mapping->{$key}
705 if ( $columns_info->{$koha_field_name}->{is_boolean
} ) {
706 # TODO: Remove when D8 is formally deprecated
707 # Handle booleans gracefully
708 $value = ( $value ) ?
1 : 0;
710 elsif ( _date_or_datetime_column_type
( $columns_info->{$koha_field_name}->{data_type
} ) ) {
712 $value = dt_from_string
($value, 'rfc3339');
715 Koha
::Exceptions
::BadParameter
->throw( parameter
=> $key );
719 $params->{$koha_field_name} = $value;
725 =head3 $object->unblessed_all_relateds
727 my $everything_into_one_hashref = $object->unblessed_all_relateds
729 The unblessed method only retrieves column' values for the column of the object.
730 In a *few* cases we want to retrieve the information of all the prefetched data.
734 sub unblessed_all_relateds
{
738 my $related_resultsets = $self->_result->{related_resultsets
} || {};
739 my $rs = $self->_result;
740 while ( $related_resultsets and %$related_resultsets ) {
741 my @relations = keys %{ $related_resultsets };
743 my $relation = $relations[0];
744 $rs = $rs->related_resultset($relation)->get_cache;
745 $rs = $rs->[0]; # Does it makes sense to have several values here?
746 my $object_class = Koha
::Object
::_get_object_class
( $rs->result_class );
747 my $koha_object = $object_class->_new_from_dbic( $rs );
748 $related_resultsets = $rs->{related_resultsets
};
749 %data = ( %data, %{ $koha_object->unblessed } );
752 %data = ( %data, %{ $self->unblessed } );
756 =head3 $object->_result();
758 Returns the internal DBIC Row object
765 # If we don't have a dbic row at this point, we need to create an empty one
767 Koha
::Database
->new()->schema()->resultset( $self->_type() )->new({});
769 return $self->{_result
};
772 =head3 $object->_columns();
774 Returns an arrayref of the table columns
781 # If we don't have a dbic row at this point, we need to create an empty one
782 $self->{_columns
} ||= [ $self->_result()->result_source()->columns() ];
784 return $self->{_columns
};
787 sub _get_object_class
{
791 if( $type->can('koha_object_class') ) {
792 return $type->koha_object_class;
794 $type =~ s
|Schema
::Result
::||;
800 The autoload method is used only to get and set values for an objects properties.
807 my $method = our $AUTOLOAD;
810 my @columns = @
{$self->_columns()};
811 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
812 if ( grep { $_ eq $method } @columns ) {
814 $self->_result()->set_column( $method, @_ );
817 my $value = $self->_result()->get_column( $method );
822 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
824 Koha
::Exceptions
::Object
::MethodNotCoveredByTests
->throw(
825 error
=> sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
827 ) unless grep { $_ eq $method } @known_methods;
830 my $r = eval { $self->_result->$method(@_) };
832 Koha
::Exceptions
::Object
->throw( ref($self) . "::$method generated this error: " . $@
);
839 This method must be defined in the child class. The value is the name of the DBIC resultset.
840 For example, for borrowers, the _type method will return "Borrower".
846 =head3 _handle_to_api_child
850 sub _handle_to_api_child
{
851 my ($self, $args ) = @_;
853 my $child = $args->{child
};
854 my $next = $args->{next};
855 my $curr = $args->{curr
};
859 if ( defined $child ) {
861 Koha
::Exceptions
::Exception
->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
862 if defined $next and blessed
$child and !$child->can('to_api');
864 if ( blessed
$child ) {
865 $res = $child->to_api({ embed
=> $next });
879 Kyle M Hall <kyle@bywatersolutions.com>
881 Jonathan Druart <jonathan.druart@bugs.koha-community.org>