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 );
27 use List::MoreUtils qw( any );
30 use Koha::Exceptions::Object;
31 use Koha::DateUtils qw( dt_from_string output_pref );
32 use Koha::Object::Message;
36 Koha::Object - Koha Object base class
41 my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
45 This class must always be subclassed.
53 =head3 Koha::Object->new();
55 my $object = Koha::Object->new();
56 my $object = Koha::Object->new($attributes);
58 Note that this cannot be used to retrieve record from the DB.
63 my ( $class, $attributes ) = @_;
67 my $schema = Koha::Database->new->schema;
69 # Remove the arguments which exist, are not defined but NOT NULL to use the default value
70 my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
71 for my $column_name ( keys %$attributes ) {
72 my $c_info = $columns_info->{$column_name};
73 next if $c_info->{is_nullable};
74 next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
75 delete $attributes->{$column_name};
79 $schema->resultset( $class->_type() )->new($attributes);
82 $self->{_messages} = [];
84 croak("No _type found! Koha::Object must be subclassed!")
85 unless $class->_type();
87 bless( $self, $class );
91 =head3 Koha::Object->_new_from_dbic();
93 my $object = Koha::Object->_new_from_dbic($dbic_row);
98 my ( $class, $dbic_row ) = @_;
102 $self->{_result} = $dbic_row;
104 croak("No _type found! Koha::Object must be subclassed!")
105 unless $class->_type();
107 croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
108 unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
110 bless( $self, $class );
114 =head3 $object->store();
116 Saves the object in storage.
117 If the object is new, it will be created.
118 If the object previously existed, it will be updated.
121 $self if the store was a success
122 undef if the store failed
129 my $columns_info = $self->_result->result_source->columns_info;
131 # Handle not null and default values for integers and dates
132 foreach my $col ( keys %{$columns_info} ) {
134 if ( _numeric_column_type( $columns_info->{$col}->{data_type} )
135 or _decimal_column_type( $columns_info->{$col}->{data_type} )
137 # Has been passed but not a number, usually an empty string
138 my $value = $self->_result()->get_column($col);
139 if ( defined $value and not looks_like_number( $value ) ) {
140 if ( $columns_info->{$col}->{is_nullable} ) {
141 # If nullable, default to null
142 $self->_result()->set_column($col => undef);
144 # If cannot be null, get the default value
145 # What if cannot be null and does not have a default value? Possible?
146 $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
150 elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
151 # Set to null if an empty string (or == 0 but should not happen)
152 my $value = $self->_result()->get_column($col);
153 if ( defined $value and not $value ) {
154 if ( $columns_info->{$col}->{is_nullable} ) {
155 $self->_result()->set_column($col => undef);
157 $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
160 elsif ( not defined $self->$col
161 && $columns_info->{$col}->{datetime_undef_if_invalid} )
164 $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
170 return $self->_result()->update_or_insert() ? $self : undef;
173 # Catch problems and raise relevant exceptions
174 if (ref($_) eq 'DBIx::Class::Exception') {
176 if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
178 # FIXME: MySQL error, if we support more DB engines we should implement this for each
179 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
180 Koha::Exceptions::Object::FKConstraint->throw(
181 error => 'Broken FK constraint',
182 broken_fk => $+{column}
186 elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
187 Koha::Exceptions::Object::DuplicateID->throw(
188 error => 'Duplicate ID',
189 duplicate_id => $+{key}
192 elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
194 my $value = $+{value};
195 my $property = $+{property};
196 $property =~ s/['`]//g;
197 Koha::Exceptions::Object::BadValue->throw(
200 property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
204 # Catch-all for foreign key breakages. It will help find other use cases
209 =head3 $object->update();
211 A shortcut for set + store in one call.
216 my ($self, $values) = @_;
217 Koha::Exceptions::Object::NotInStorage->throw unless $self->in_storage;
218 $self->set($values)->store();
221 =head3 $object->delete();
223 Removes the object from storage.
226 The item object if deletion was a success
227 The DBIX::Class error if deletion failed
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->object_messages
340 my @messages = @{ $object->object_messages };
342 Returns the (probably non-fatal) messages that were recorded on the object.
346 sub object_messages {
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(
548 Returns a representation of the object, suitable for API output.
553 my ( $self, $params ) = @_;
554 my $json_object = $self->TO_JSON;
556 # Make sure we duplicate the $params variable to avoid
557 # breaking calls in a loop (Koha::Objects->to_api)
558 $params = defined $params ? {%$params} : {};
560 # children should be able to handle without
561 my $embeds = delete $params->{embed};
562 my $strings = delete $params->{strings};
564 # coded values handling
566 if ( $strings and $self->can('strings_map') ) {
567 $string_map = $self->strings_map($params);
570 # Remove forbidden attributes if required (including their coded values)
571 if ( $params->{public} ) {
572 for my $field ( keys %{$json_object} ) {
573 delete $json_object->{$field}
574 unless any { $_ eq $field } @{ $self->public_read_list };
578 foreach my $field ( keys %{$string_map} ) {
579 delete $string_map->{$field}
580 unless any { $_ eq $field } @{ $self->public_read_list };
585 my $to_api_mapping = $self->to_api_mapping;
587 # Rename attributes and coded values if there's a mapping
588 if ( $self->can('to_api_mapping') ) {
589 foreach my $column ( keys %{ $self->to_api_mapping } ) {
590 my $mapped_column = $self->to_api_mapping->{$column};
591 if ( exists $json_object->{$column}
592 && defined $mapped_column )
596 $json_object->{$mapped_column} = delete $json_object->{$column};
597 $string_map->{$mapped_column} = delete $string_map->{$column}
598 if exists $string_map->{$column};
601 elsif ( exists $json_object->{$column}
602 && !defined $mapped_column )
606 delete $json_object->{$column};
607 delete $string_map->{$column};
612 $json_object->{_strings} = $string_map
616 foreach my $embed ( keys %{$embeds} ) {
617 if ( $embed =~ m/^(?<relation>.*)_count$/
618 and $embeds->{$embed}->{is_count} )
621 my $relation = $+{relation};
622 $json_object->{$embed} = $self->$relation->count;
626 my $next = $embeds->{$curr}->{children};
628 $params->{strings} = 1
629 if $embeds->{$embed}->{strings};
631 my $children = $self->$curr;
633 if ( defined $children and ref($children) eq 'ARRAY' ) {
635 $self->_handle_to_api_child(
644 $json_object->{$curr} = \@list;
647 $json_object->{$curr} = $self->_handle_to_api_child(
663 =head3 to_api_mapping
665 my $mapping = $object->to_api_mapping;
667 Generic method that returns the attribute name mappings required to
668 render the object on the API.
670 Note: this only returns an empty I<hashref>. Each class should have its
671 own mapping returned.
681 my $params = { is_public => 1 };
682 my $string_map = $object->strings_map($params);
684 Generic method that returns the string map for coded attributes.
686 Return should be a hashref keyed on database field name with the values
687 being hashrefs containing 'str', 'type' and optionally 'category'.
689 This is then use in to_api to render the _strings embed when requested.
691 Note: this only returns an empty I<hashref>. Each class should have its
692 own mapping returned.
700 =head3 public_read_list
703 my @public_read_list = @{$object->public_read_list};
705 Generic method that returns the list of database columns that are allowed to
706 be passed to render objects on the public API.
708 Note: this only returns an empty I<arrayref>. Each class should have its
718 =head3 from_api_mapping
720 my $mapping = $object->from_api_mapping;
722 Generic method that returns the attribute name mappings so the data that
723 comes from the API is correctly renamed to match what is required for the DB.
727 sub from_api_mapping {
730 my $to_api_mapping = $self->to_api_mapping;
732 unless ( defined $self->{_from_api_mapping} ) {
733 $self->{_from_api_mapping} = {};
734 while (my ($key, $value) = each %{ $to_api_mapping } ) {
735 $self->{_from_api_mapping}->{$value} = $key
740 return $self->{_from_api_mapping};
745 my $object = Koha::Object->new_from_api;
746 my $object = Koha::Object->new_from_api( $attrs );
748 Creates a new object, mapping the API attribute names to the ones on the DB schema.
753 my ( $class, $params ) = @_;
755 my $self = $class->new;
756 return $self->set_from_api( $params );
761 my $object = Koha::Object->new(...);
762 $object->set_from_api( $attrs )
764 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
769 my ( $self, $from_api_params ) = @_;
771 return $self->set( $self->attributes_from_api( $from_api_params ) );
774 =head3 attributes_from_api
776 my $attributes = attributes_from_api( $params );
778 Returns the passed params, converted from API naming into the model.
782 sub attributes_from_api {
783 my ( $self, $from_api_params ) = @_;
785 my $from_api_mapping = $self->from_api_mapping;
788 my $columns_info = $self->_result->result_source->columns_info;
789 my $dtf = $self->_result->result_source->storage->datetime_parser;
791 while (my ($key, $value) = each %{ $from_api_params } ) {
792 my $koha_field_name =
793 exists $from_api_mapping->{$key}
794 ? $from_api_mapping->{$key}
797 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
798 # TODO: Remove when D8 is formally deprecated
799 # Handle booleans gracefully
800 $value = ( $value ) ? 1 : 0;
802 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
804 if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
805 $value = $dtf->format_date(dt_from_string($value, 'iso'))
809 $value = $dtf->format_datetime(dt_from_string($value, 'rfc3339'))
814 Koha::Exceptions::BadParameter->throw( parameter => $key );
818 $params->{$koha_field_name} = $value;
824 =head3 $object->unblessed_all_relateds
826 my $everything_into_one_hashref = $object->unblessed_all_relateds
828 The unblessed method only retrieves column' values for the column of the object.
829 In a *few* cases we want to retrieve the information of all the prefetched data.
833 sub unblessed_all_relateds {
837 my $related_resultsets = $self->_result->{related_resultsets} || {};
838 my $rs = $self->_result;
839 while ( $related_resultsets and %$related_resultsets ) {
840 my @relations = keys %{ $related_resultsets };
842 my $relation = $relations[0];
843 $rs = $rs->related_resultset($relation)->get_cache;
844 $rs = $rs->[0]; # Does it makes sense to have several values here?
845 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
846 my $koha_object = $object_class->_new_from_dbic( $rs );
847 $related_resultsets = $rs->{related_resultsets};
848 %data = ( %data, %{ $koha_object->unblessed } );
851 %data = ( %data, %{ $self->unblessed } );
855 =head3 $object->_result();
857 Returns the internal DBIC Row object
864 # If we don't have a dbic row at this point, we need to create an empty one
866 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
868 return $self->{_result};
871 =head3 $object->_columns();
873 Returns an arrayref of the table columns
880 # If we don't have a dbic row at this point, we need to create an empty one
881 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
883 return $self->{_columns};
886 sub _get_object_class {
890 if( $type->can('koha_object_class') ) {
891 return $type->koha_object_class;
893 $type =~ s|Schema::Result::||;
899 The autoload method is used only to get and set values for an objects properties.
906 my $method = our $AUTOLOAD;
909 my @columns = @{$self->_columns()};
910 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
911 if ( grep { $_ eq $method } @columns ) {
913 $self->_result()->set_column( $method, @_ );
916 my $value = $self->_result()->get_column( $method );
921 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
923 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
924 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
926 ) unless grep { $_ eq $method } @known_methods;
929 my $r = eval { $self->_result->$method(@_) };
931 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
938 This method must be defined in the child class. The value is the name of the DBIC resultset.
939 For example, for borrowers, the _type method will return "Borrower".
945 =head3 _handle_to_api_child
949 sub _handle_to_api_child {
950 my ($self, $args ) = @_;
952 my $child = $args->{child};
953 my $next = $args->{next};
954 my $curr = $args->{curr};
955 my $params = $args->{params};
959 if ( defined $child ) {
961 Koha::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
962 if defined $next and blessed $child and !$child->can('to_api');
964 if ( blessed $child ) {
965 $params->{embed} = $next;
966 $res = $child->to_api($params);
980 Kyle M Hall <kyle@bywatersolutions.com>
982 Jonathan Druart <jonathan.druart@bugs.koha-community.org>