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 ) = @_;
555 return unless $self->accessible;
557 my $json_object = $self->TO_JSON;
559 # Make sure we duplicate the $params variable to avoid
560 # breaking calls in a loop (Koha::Objects->to_api)
561 $params = defined $params ? {%$params} : {};
563 # children should be able to handle without
564 my $embeds = delete $params->{embed};
565 my $strings = delete $params->{strings};
567 # coded values handling
569 if ( $strings and $self->can('strings_map') ) {
570 $string_map = $self->strings_map($params);
573 # Remove forbidden attributes if required (including their coded values)
574 if ( $params->{public} ) {
575 for my $field ( keys %{$json_object} ) {
576 delete $json_object->{$field}
577 unless any { $_ eq $field } @{ $self->public_read_list };
581 foreach my $field ( keys %{$string_map} ) {
582 delete $string_map->{$field}
583 unless any { $_ eq $field } @{ $self->public_read_list };
588 my $to_api_mapping = $self->to_api_mapping;
590 # Rename attributes and coded values if there's a mapping
591 if ( $self->can('to_api_mapping') ) {
592 foreach my $column ( keys %{ $self->to_api_mapping } ) {
593 my $mapped_column = $self->to_api_mapping->{$column};
594 if ( exists $json_object->{$column}
595 && defined $mapped_column )
599 $json_object->{$mapped_column} = delete $json_object->{$column};
600 $string_map->{$mapped_column} = delete $string_map->{$column}
601 if exists $string_map->{$column};
604 elsif ( exists $json_object->{$column}
605 && !defined $mapped_column )
609 delete $json_object->{$column};
610 delete $string_map->{$column};
615 $json_object->{_strings} = $string_map
619 foreach my $embed ( keys %{$embeds} ) {
620 if ( $embed =~ m/^(?<relation>.*)_count$/
621 and $embeds->{$embed}->{is_count} )
624 my $relation = $+{relation};
625 $json_object->{$embed} = $self->$relation->count;
629 my $next = $embeds->{$curr}->{children};
631 $params->{strings} = 1
632 if $embeds->{$embed}->{strings};
634 my $children = $self->$curr;
636 if ( defined $children and ref($children) eq 'ARRAY' ) {
638 $self->_handle_to_api_child(
647 $json_object->{$curr} = \@list;
650 $json_object->{$curr} = $self->_handle_to_api_child(
666 =head3 to_api_mapping
668 my $mapping = $object->to_api_mapping;
670 Generic method that returns the attribute name mappings required to
671 render the object on the API.
673 Note: this only returns an empty I<hashref>. Each class should have its
674 own mapping returned.
684 my $string_map = $object->strings_map($params);
686 Generic method that returns the string map for coded attributes.
688 Return should be a hashref keyed on database field name with the values
689 being hashrefs containing 'str', 'type' and optionally 'category'.
691 This is then used in to_api to render the _strings embed when requested.
693 Note: this only returns an empty I<hashref>. Each class should have its
694 own mapping returned.
702 =head3 public_read_list
705 my @public_read_list = @{$object->public_read_list};
707 Generic method that returns the list of database columns that are allowed to
708 be passed to render objects on the public API.
710 Note: this only returns an empty I<arrayref>. Each class should have its
720 =head3 from_api_mapping
722 my $mapping = $object->from_api_mapping;
724 Generic method that returns the attribute name mappings so the data that
725 comes from the API is correctly renamed to match what is required for the DB.
729 sub from_api_mapping {
732 my $to_api_mapping = $self->to_api_mapping;
734 unless ( defined $self->{_from_api_mapping} ) {
735 $self->{_from_api_mapping} = {};
736 while (my ($key, $value) = each %{ $to_api_mapping } ) {
737 $self->{_from_api_mapping}->{$value} = $key
742 return $self->{_from_api_mapping};
747 my $object = Koha::Object->new_from_api;
748 my $object = Koha::Object->new_from_api( $attrs );
750 Creates a new object, mapping the API attribute names to the ones on the DB schema.
755 my ( $class, $params ) = @_;
757 my $self = $class->new;
758 return $self->set_from_api( $params );
763 my $object = Koha::Object->new(...);
764 $object->set_from_api( $attrs )
766 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
771 my ( $self, $from_api_params ) = @_;
773 return $self->set( $self->attributes_from_api( $from_api_params ) );
776 =head3 attributes_from_api
778 my $attributes = attributes_from_api( $params );
780 Returns the passed params, converted from API naming into the model.
784 sub attributes_from_api {
785 my ( $self, $from_api_params ) = @_;
787 my $from_api_mapping = $self->from_api_mapping;
790 my $columns_info = $self->_result->result_source->columns_info;
791 my $dtf = $self->_result->result_source->storage->datetime_parser;
793 while (my ($key, $value) = each %{ $from_api_params } ) {
794 my $koha_field_name =
795 exists $from_api_mapping->{$key}
796 ? $from_api_mapping->{$key}
799 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
800 # TODO: Remove when D8 is formally deprecated
801 # Handle booleans gracefully
802 $value = ( $value ) ? 1 : 0;
804 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
806 if ( $columns_info->{$koha_field_name}->{data_type} eq 'date' ) {
807 $value = $dtf->format_date(dt_from_string($value, 'iso'))
811 $value = $dtf->format_datetime(dt_from_string($value, 'rfc3339'))
816 Koha::Exceptions::BadParameter->throw( parameter => $key );
820 $params->{$koha_field_name} = $value;
826 =head3 $object->unblessed_all_relateds
828 my $everything_into_one_hashref = $object->unblessed_all_relateds
830 The unblessed method only retrieves column' values for the column of the object.
831 In a *few* cases we want to retrieve the information of all the prefetched data.
835 sub unblessed_all_relateds {
839 my $related_resultsets = $self->_result->{related_resultsets} || {};
840 my $rs = $self->_result;
841 while ( $related_resultsets and %$related_resultsets ) {
842 my @relations = keys %{ $related_resultsets };
844 my $relation = $relations[0];
845 $rs = $rs->related_resultset($relation)->get_cache;
846 $rs = $rs->[0]; # Does it makes sense to have several values here?
847 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
848 my $koha_object = $object_class->_new_from_dbic( $rs );
849 $related_resultsets = $rs->{related_resultsets};
850 %data = ( %data, %{ $koha_object->unblessed } );
853 %data = ( %data, %{ $self->unblessed } );
857 =head3 $object->_result();
859 Returns the internal DBIC Row object
866 # If we don't have a dbic row at this point, we need to create an empty one
868 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
870 return $self->{_result};
873 =head3 $object->_columns();
875 Returns an arrayref of the table columns
882 # If we don't have a dbic row at this point, we need to create an empty one
883 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
885 return $self->{_columns};
888 sub _get_object_class {
892 if( $type->can('koha_object_class') ) {
893 return $type->koha_object_class;
895 $type =~ s|Schema::Result::||;
899 sub _get_objects_class {
903 if ( $self->_result->can('koha_objects_class') ) {
904 return $self->_result->koha_objects_class;
906 my $type = ref($self);
908 $type =~ s|Schema::Result::||;
914 The autoload method is used only to get and set values for an objects properties.
921 my $method = our $AUTOLOAD;
924 my @columns = @{$self->_columns()};
925 if ( grep { $_ eq $method } @columns ) {
927 # Lazy definition of get/set accessors like $item->barcode; note that it contains $method
931 $self->_result()->set_column( $method, @_ );
934 return $self->_result()->get_column($method);
937 no strict 'refs'; ## no critic (strict)
938 *{$AUTOLOAD} = $accessor;
939 return $accessor->( $self, @_ );
942 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
944 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
945 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
947 ) unless grep { $_ eq $method } @known_methods;
949 my $r = eval { $self->_result->$method(@_) };
951 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
958 This method must be defined in the child class. The value is the name of the DBIC resultset.
959 For example, for borrowers, the _type method will return "Borrower".
965 =head3 _handle_to_api_child
969 sub _handle_to_api_child {
970 my ($self, $args ) = @_;
972 my $child = $args->{child};
973 my $next = $args->{next};
974 my $curr = $args->{curr};
975 my $params = $args->{params};
979 if ( defined $child ) {
981 Koha::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
982 if defined $next and blessed $child and !$child->can('to_api');
984 if ( blessed $child ) {
985 $params->{embed} = $next;
986 $res = $child->to_api($params);
998 if ( $object->accessible ) { ... }
1000 Whether the object should be accessible in the current context (requesting user).
1001 It relies on the plural class properly implementing the I<search_limited> method.
1008 return $self->_get_objects_class->search_limited(
1010 map { $_ => $self->$_ }
1011 $self->_result->result_source->primary_columns
1022 Kyle M Hall <kyle@bywatersolutions.com>
1024 Jonathan Druart <jonathan.druart@bugs.koha-community.org>