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} )
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} )
417 # TODO: Remove once the solution for
418 # https://github.com/perl5-dbi/DBD-mysql/issues/212
419 # is ported to whatever distro we support by that time
420 # or we move to DBD::MariaDB
421 $unblessed->{$col} += 0.00;
423 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
425 return unless $unblessed->{$col};
426 $unblessed->{$col} = output_pref({
427 dateformat => 'rfc3339',
428 dt => dt_from_string($unblessed->{$col}, 'sql'),
436 sub _date_or_datetime_column_type {
437 my ($column_type) = @_;
445 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
447 sub _datetime_column_type {
448 my ($column_type) = @_;
455 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
458 sub _numeric_column_type {
459 # TODO: Remove once the solution for
460 # https://github.com/perl5-dbi/DBD-mysql/issues/212
461 # is ported to whatever distro we support by that time
462 # or we move to DBD::MariaDB
463 my ($column_type) = @_;
465 my @numeric_types = (
474 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
477 sub _decimal_column_type {
478 # TODO: Remove once the solution for
479 # https://github.com/perl5-dbi/DBD-mysql/issues/212
480 # is ported to whatever distro we support by that time
481 # or we move to DBD::MariaDB
482 my ($column_type) = @_;
484 my @decimal_types = (
490 return ( grep { $column_type eq $_ } @decimal_types) ? 1 : 0;
493 =head3 prefetch_whitelist
495 my $whitelist = $object->prefetch_whitelist()
497 Returns a hash of prefetchable subs and the type they return.
501 sub prefetch_whitelist {
505 my $relations = $self->_result->result_source->_relationships;
507 foreach my $key (keys %{$relations}) {
508 if($self->can($key)) {
509 my $result_class = $relations->{$key}->{class};
510 my $obj = $result_class->new;
512 $whitelist->{$key} = Koha::Object::_get_object_class( $obj->result_class );
514 $whitelist->{$key} = undef;
524 my $object_for_api = $object->to_api(
546 Returns a representation of the object, suitable for API output.
551 my ( $self, $params ) = @_;
553 my $json_object = $self->TO_JSON;
555 # Make sure we duplicate the $params variable to avoid
556 # breaking calls in a loop (Koha::Objects->to_api)
557 $params = defined $params ? {%$params} : {};
559 # children should be able to handle without
560 my $embeds = delete $params->{embed};
561 my $strings = delete $params->{strings};
563 # coded values handling
565 if ( $strings and $self->can('strings_map') ) {
566 $string_map = $self->strings_map($params);
569 # Remove forbidden attributes if required (including their coded values)
570 if ( $params->{public} ) {
571 for my $field ( keys %{$json_object} ) {
572 delete $json_object->{$field}
573 unless any { $_ eq $field } @{ $self->public_read_list };
577 foreach my $field ( keys %{$string_map} ) {
578 delete $string_map->{$field}
579 unless any { $_ eq $field } @{ $self->public_read_list };
584 # Remove forbidden attributes if required (including their coded values)
585 if ( !$self->is_accessible($params) ) {
586 for my $field ( keys %{$json_object} ) {
587 unless ( any { $_ eq $field } @{ $self->unredact_list } ) {
588 $json_object->{$field} = undef;
593 foreach my $field ( keys %{$string_map} ) {
594 unless ( any { $_ eq $field } @{ $self->unredact_list } ) {
595 $string_map->{$field} = undef;
601 my $to_api_mapping = $self->to_api_mapping;
603 # Rename attributes and coded values if there's a mapping
604 if ( $self->can('to_api_mapping') ) {
605 foreach my $column ( keys %{ $self->to_api_mapping } ) {
606 my $mapped_column = $self->to_api_mapping->{$column};
607 if ( exists $json_object->{$column}
608 && defined $mapped_column )
612 $json_object->{$mapped_column} = delete $json_object->{$column};
613 $string_map->{$mapped_column} = delete $string_map->{$column}
614 if exists $string_map->{$column};
617 elsif ( exists $json_object->{$column}
618 && !defined $mapped_column )
622 delete $json_object->{$column};
623 delete $string_map->{$column};
628 $json_object->{_strings} = $string_map
632 foreach my $embed ( keys %{$embeds} ) {
633 if ( $embed =~ m/^(?<relation>.*)_count$/
634 and $embeds->{$embed}->{is_count} )
637 my $relation = $+{relation};
638 $json_object->{$embed} = $self->$relation->count;
642 my $next = $embeds->{$curr}->{children};
644 $params->{strings} = 1
645 if $embeds->{$embed}->{strings};
647 my $children = $self->$curr;
649 if ( defined $children and ref($children) eq 'ARRAY' ) {
651 $self->_handle_to_api_child(
660 $json_object->{$curr} = \@list;
663 $json_object->{$curr} = $self->_handle_to_api_child(
679 =head3 to_api_mapping
681 my $mapping = $object->to_api_mapping;
683 Generic method that returns the attribute name mappings required to
684 render the object on the API.
686 Note: this only returns an empty I<hashref>. Each class should have its
687 own mapping returned.
697 my $string_map = $object->strings_map($params);
699 Generic method that returns the string map for coded attributes.
701 Return should be a hashref keyed on database field name with the values
702 being hashrefs containing 'str', 'type' and optionally 'category'.
704 This is then used in to_api to render the _strings embed when requested.
706 Note: this only returns an empty I<hashref>. Each class should have its
707 own mapping returned.
715 =head3 public_read_list
718 my @public_read_list = @{$object->public_read_list};
720 Generic method that returns the list of database columns that are allowed to
721 be passed to render objects on the public API.
723 Note: this only returns an empty I<arrayref>. Each class should have its
735 my @unredact_list = @{$object->unredact_list};
737 Generic method that returns the list of database columns that are allowed to
738 be passed to render objects on the API when the user making the request should
739 not ordinarily have unrestricted access to the data (as returned by the is_accesible method).
741 Note: this only returns an empty I<arrayref>. Each class should have its
750 =head3 from_api_mapping
752 my $mapping = $object->from_api_mapping;
754 Generic method that returns the attribute name mappings so the data that
755 comes from the API is correctly renamed to match what is required for the DB.
759 sub from_api_mapping {
762 my $to_api_mapping = $self->to_api_mapping;
764 unless ( defined $self->{_from_api_mapping} ) {
765 $self->{_from_api_mapping} = {};
766 while (my ($key, $value) = each %{ $to_api_mapping } ) {
767 $self->{_from_api_mapping}->{$value} = $key
772 return $self->{_from_api_mapping};
777 my $object = Koha::Object->new_from_api;
778 my $object = Koha::Object->new_from_api( $attrs );
780 Creates a new object, mapping the API attribute names to the ones on the DB schema.
785 my ( $class, $params ) = @_;
787 my $self = $class->new;
788 return $self->set_from_api( $params );
793 my $object = Koha::Object->new(...);
794 $object->set_from_api( $attrs )
796 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
801 my ( $self, $from_api_params ) = @_;
803 return $self->set( $self->attributes_from_api( $from_api_params ) );
806 =head3 attributes_from_api
808 my $attributes = attributes_from_api( $params );
810 Returns the passed params, converted from API naming into the model.
814 sub attributes_from_api {
815 my ( $self, $from_api_params ) = @_;
817 my $from_api_mapping = $self->from_api_mapping;
820 my $columns_info = $self->_result->result_source->columns_info;
821 my $dtf = $self->_result->result_source->storage->datetime_parser;
823 while (my ($key, $value) = each %{ $from_api_params } ) {
824 my $koha_field_name =
825 exists $from_api_mapping->{$key}
826 ? $from_api_mapping->{$key}
829 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
830 # TODO: Remove when D8 is formally deprecated
831 # Handle booleans gracefully
832 $value = ( $value ) ? 1 : 0;
834 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
836 if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
837 $value = $dtf->format_date(dt_from_string($value, 'iso'))
841 $value = $dtf->format_datetime(dt_from_string($value, 'rfc3339'))
846 Koha::Exceptions::BadParameter->throw( parameter => $key );
850 $params->{$koha_field_name} = $value;
856 =head3 $object->unblessed_all_relateds
858 my $everything_into_one_hashref = $object->unblessed_all_relateds
860 The unblessed method only retrieves column' values for the column of the object.
861 In a *few* cases we want to retrieve the information of all the prefetched data.
865 sub unblessed_all_relateds {
869 my $related_resultsets = $self->_result->{related_resultsets} || {};
870 my $rs = $self->_result;
871 while ( $related_resultsets and %$related_resultsets ) {
872 my @relations = keys %{ $related_resultsets };
874 my $relation = $relations[0];
875 $rs = $rs->related_resultset($relation)->get_cache;
876 $rs = $rs->[0]; # Does it makes sense to have several values here?
877 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
878 my $koha_object = $object_class->_new_from_dbic( $rs );
879 $related_resultsets = $rs->{related_resultsets};
880 %data = ( %data, %{ $koha_object->unblessed } );
883 %data = ( %data, %{ $self->unblessed } );
887 =head3 $object->_result();
889 Returns the internal DBIC Row object
896 # If we don't have a dbic row at this point, we need to create an empty one
898 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
900 return $self->{_result};
903 =head3 $object->_columns();
905 Returns an arrayref of the table columns
912 # If we don't have a dbic row at this point, we need to create an empty one
913 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
915 return $self->{_columns};
918 sub _get_object_class {
922 if( $type->can('koha_object_class') ) {
923 return $type->koha_object_class;
925 $type =~ s|Schema::Result::||;
931 The autoload method is used only to get and set values for an objects properties.
938 my $method = our $AUTOLOAD;
941 my @columns = @{$self->_columns()};
942 if ( grep { $_ eq $method } @columns ) {
944 # Lazy definition of get/set accessors like $item->barcode; note that it contains $method
948 $self->_result()->set_column( $method, @_ );
951 return $self->_result()->get_column($method);
954 no strict 'refs'; ## no critic (strict)
955 *{$AUTOLOAD} = $accessor;
956 return $accessor->( $self, @_ );
959 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
961 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
962 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
964 ) unless grep { $_ eq $method } @known_methods;
966 my $r = eval { $self->_result->$method(@_) };
968 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
975 This method must be defined in the child class. The value is the name of the DBIC resultset.
976 For example, for borrowers, the _type method will return "Borrower".
982 =head3 _handle_to_api_child
986 sub _handle_to_api_child {
987 my ($self, $args ) = @_;
989 my $child = $args->{child};
990 my $next = $args->{next};
991 my $curr = $args->{curr};
992 my $params = $args->{params};
996 if ( defined $child ) {
998 Koha::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
999 if defined $next and blessed $child and !$child->can('to_api');
1001 if ( blessed $child ) {
1002 $params->{embed} = $next;
1003 $res = $child->to_api($params);
1013 =head3 is_accessible
1015 if ( $object->is_accessible ) { ... }
1017 Stub method that is expected to be overloaded (if required) by implementing classes.
1031 Kyle M Hall <kyle@bywatersolutions.com>
1033 Jonathan Druart <jonathan.druart@bugs.koha-community.org>