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 );
26 use Try::Tiny qw( catch try );
29 use Koha::Exceptions::Object;
30 use Koha::DateUtils qw( dt_from_string output_pref );
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 The item object if deletion was a success
226 The DBIX::Class error if deletion failed
233 my $deleted = $self->_result()->delete;
234 if ( ref $deleted ) {
235 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
236 $deleted = $object_class->_new_from_dbic($deleted);
241 =head3 $object->set( $properties_hashref )
245 property1 => $property1,
246 property2 => $property2,
247 property3 => $propery3,
251 Enables multiple properties to be set at once
254 1 if all properties were set.
255 0 if one or more properties do not exist.
256 undef if all properties exist but a different error
257 prevents one or more properties from being set.
259 If one or more of the properties do not exist,
260 no properties will be set.
265 my ( $self, $properties ) = @_;
267 my @columns = @{$self->_columns()};
269 foreach my $p ( keys %$properties ) {
270 unless ( grep { $_ eq $p } @columns ) {
271 Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
275 return $self->_result()->set_columns($properties) ? $self : undef;
278 =head3 $object->set_or_blank( $properties_hashref )
280 $object->set_or_blank(
282 property1 => $property1,
283 property2 => $property2,
284 property3 => $propery3,
288 If not listed in $properties_hashref, the property will be set to the default
289 value defined at DB level, or nulled.
295 my ( $self, $properties ) = @_;
297 my $columns_info = $self->_result->result_source->columns_info;
299 foreach my $col ( keys %{$columns_info} ) {
301 next if exists $properties->{$col};
303 if ( $columns_info->{$col}->{is_nullable} ) {
304 $properties->{$col} = undef;
306 $properties->{$col} = $columns_info->{$col}->{default_value};
310 return $self->set($properties);
313 =head3 $object->unblessed();
315 Returns an unblessed representation of object.
322 return { $self->_result->get_columns };
325 =head3 $object->get_from_storage;
329 sub get_from_storage {
330 my ( $self, $attrs ) = @_;
331 my $stored_object = $self->_result->get_from_storage($attrs);
332 return unless $stored_object;
333 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
334 return $object_class->_new_from_dbic($stored_object);
337 =head3 $object->messages
339 my @messages = @{ $object->messages };
341 Returns the (probably non-fatal) messages that were recorded on the object.
348 $self->{_messages} = []
349 unless defined $self->{_messages};
351 return $self->{_messages};
354 =head3 $object->add_message
357 <some action that might fail>
360 if ( <fatal condition> ) {
361 Koha::Exception->throw...
364 # This is a non fatal error, notify the caller
365 $self->add_message({ message => $error, type => 'error' });
374 my ( $self, $params ) = @_;
376 push @{ $self->{_messages} }, Koha::Object::Message->new($params);
381 =head3 $object->TO_JSON
383 Returns an unblessed representation of the object, suitable for JSON output.
391 my $unblessed = $self->unblessed;
392 my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
393 ->result_source->{_columns};
395 foreach my $col ( keys %{$columns_info} ) {
397 if ( $columns_info->{$col}->{is_boolean} )
398 { # Handle booleans gracefully
400 = ( $unblessed->{$col} )
404 elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
405 and looks_like_number( $unblessed->{$col} )
408 # TODO: Remove once the solution for
409 # https://github.com/perl5-dbi/DBD-mysql/issues/212
410 # is ported to whatever distro we support by that time
411 # or we move to DBD::MariaDB
412 $unblessed->{$col} += 0;
414 elsif ( _decimal_column_type( $columns_info->{$col}->{data_type} )
415 and looks_like_number( $unblessed->{$col} )
418 # TODO: Remove once the solution for
419 # https://github.com/perl5-dbi/DBD-mysql/issues/212
420 # is ported to whatever distro we support by that time
421 # or we move to DBD::MariaDB
422 $unblessed->{$col} += 0.00;
424 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
426 return unless $unblessed->{$col};
427 $unblessed->{$col} = output_pref({
428 dateformat => 'rfc3339',
429 dt => dt_from_string($unblessed->{$col}, 'sql'),
437 sub _date_or_datetime_column_type {
438 my ($column_type) = @_;
446 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
448 sub _datetime_column_type {
449 my ($column_type) = @_;
456 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
459 sub _numeric_column_type {
460 # TODO: Remove once the solution for
461 # https://github.com/perl5-dbi/DBD-mysql/issues/212
462 # is ported to whatever distro we support by that time
463 # or we move to DBD::MariaDB
464 my ($column_type) = @_;
466 my @numeric_types = (
475 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
478 sub _decimal_column_type {
479 # TODO: Remove once the solution for
480 # https://github.com/perl5-dbi/DBD-mysql/issues/212
481 # is ported to whatever distro we support by that time
482 # or we move to DBD::MariaDB
483 my ($column_type) = @_;
485 my @decimal_types = (
491 return ( grep { $column_type eq $_ } @decimal_types) ? 1 : 0;
494 =head3 prefetch_whitelist
496 my $whitelist = $object->prefetch_whitelist()
498 Returns a hash of prefetchable subs and the type they return.
502 sub prefetch_whitelist {
506 my $relations = $self->_result->result_source->_relationships;
508 foreach my $key (keys %{$relations}) {
509 if($self->can($key)) {
510 my $result_class = $relations->{$key}->{class};
511 my $obj = $result_class->new;
513 $whitelist->{$key} = Koha::Object::_get_object_class( $obj->result_class );
515 $whitelist->{$key} = undef;
525 my $object_for_api = $object->to_api(
546 Returns a representation of the object, suitable for API output.
551 my ( $self, $params ) = @_;
552 my $json_object = $self->TO_JSON;
554 my $to_api_mapping = $self->to_api_mapping;
556 # Rename attributes if there's a mapping
557 if ( $self->can('to_api_mapping') ) {
558 foreach my $column ( keys %{ $self->to_api_mapping } ) {
559 my $mapped_column = $self->to_api_mapping->{$column};
560 if ( exists $json_object->{$column}
561 && defined $mapped_column )
564 $json_object->{$mapped_column} = delete $json_object->{$column};
566 elsif ( exists $json_object->{$column}
567 && !defined $mapped_column )
570 delete $json_object->{$column};
575 my $embeds = $params->{embed};
578 foreach my $embed ( keys %{$embeds} ) {
579 if ( $embed =~ m/^(?<relation>.*)_count$/
580 and $embeds->{$embed}->{is_count} ) {
582 my $relation = $+{relation};
583 $json_object->{$embed} = $self->$relation->count;
587 my $next = $embeds->{$curr}->{children};
589 my $children = $self->$curr;
591 if ( defined $children and ref($children) eq 'ARRAY' ) {
593 $self->_handle_to_api_child(
594 { child => $_, next => $next, curr => $curr } )
596 $json_object->{$curr} = \@list;
599 $json_object->{$curr} = $self->_handle_to_api_child(
600 { child => $children, next => $next, curr => $curr } );
611 =head3 to_api_mapping
613 my $mapping = $object->to_api_mapping;
615 Generic method that returns the attribute name mappings required to
616 render the object on the API.
618 Note: this only returns an empty I<hashref>. Each class should have its
619 own mapping returned.
627 =head3 from_api_mapping
629 my $mapping = $object->from_api_mapping;
631 Generic method that returns the attribute name mappings so the data that
632 comes from the API is correctly renamed to match what is required for the DB.
636 sub from_api_mapping {
639 my $to_api_mapping = $self->to_api_mapping;
641 unless ( defined $self->{_from_api_mapping} ) {
642 $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;
698 my $dtf = $self->_result->result_source->storage->datetime_parser;
700 while (my ($key, $value) = each %{ $from_api_params } ) {
701 my $koha_field_name =
702 exists $from_api_mapping->{$key}
703 ? $from_api_mapping->{$key}
706 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
707 # TODO: Remove when D8 is formally deprecated
708 # Handle booleans gracefully
709 $value = ( $value ) ? 1 : 0;
711 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
713 if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
714 $value = $dtf->format_date(dt_from_string($value, 'rfc3339'))
718 $value = $dtf->format_datetime(dt_from_string($value, 'rfc3339'))
723 Koha::Exceptions::BadParameter->throw( parameter => $key );
727 $params->{$koha_field_name} = $value;
733 =head3 $object->unblessed_all_relateds
735 my $everything_into_one_hashref = $object->unblessed_all_relateds
737 The unblessed method only retrieves column' values for the column of the object.
738 In a *few* cases we want to retrieve the information of all the prefetched data.
742 sub unblessed_all_relateds {
746 my $related_resultsets = $self->_result->{related_resultsets} || {};
747 my $rs = $self->_result;
748 while ( $related_resultsets and %$related_resultsets ) {
749 my @relations = keys %{ $related_resultsets };
751 my $relation = $relations[0];
752 $rs = $rs->related_resultset($relation)->get_cache;
753 $rs = $rs->[0]; # Does it makes sense to have several values here?
754 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
755 my $koha_object = $object_class->_new_from_dbic( $rs );
756 $related_resultsets = $rs->{related_resultsets};
757 %data = ( %data, %{ $koha_object->unblessed } );
760 %data = ( %data, %{ $self->unblessed } );
764 =head3 $object->_result();
766 Returns the internal DBIC Row object
773 # If we don't have a dbic row at this point, we need to create an empty one
775 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
777 return $self->{_result};
780 =head3 $object->_columns();
782 Returns an arrayref of the table columns
789 # If we don't have a dbic row at this point, we need to create an empty one
790 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
792 return $self->{_columns};
795 sub _get_object_class {
799 if( $type->can('koha_object_class') ) {
800 return $type->koha_object_class;
802 $type =~ s|Schema::Result::||;
808 The autoload method is used only to get and set values for an objects properties.
815 my $method = our $AUTOLOAD;
818 my @columns = @{$self->_columns()};
819 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
820 if ( grep { $_ eq $method } @columns ) {
822 $self->_result()->set_column( $method, @_ );
825 my $value = $self->_result()->get_column( $method );
830 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
832 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
833 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
835 ) unless grep { $_ eq $method } @known_methods;
838 my $r = eval { $self->_result->$method(@_) };
840 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
847 This method must be defined in the child class. The value is the name of the DBIC resultset.
848 For example, for borrowers, the _type method will return "Borrower".
854 =head3 _handle_to_api_child
858 sub _handle_to_api_child {
859 my ($self, $args ) = @_;
861 my $child = $args->{child};
862 my $next = $args->{next};
863 my $curr = $args->{curr};
867 if ( defined $child ) {
869 Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
870 if defined $next and blessed $child and !$child->can('to_api');
872 if ( blessed $child ) {
873 $res = $child->to_api({ embed => $next });
887 Kyle M Hall <kyle@bywatersolutions.com>
889 Jonathan Druart <jonathan.druart@bugs.koha-community.org>