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;
34 Koha::Object - Koha Object base class
39 my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
43 This class must always be subclassed.
51 =head3 Koha::Object->new();
53 my $object = Koha::Object->new();
54 my $object = Koha::Object->new($attributes);
56 Note that this cannot be used to retrieve record from the DB.
61 my ( $class, $attributes ) = @_;
65 my $schema = Koha::Database->new->schema;
67 # Remove the arguments which exist, are not defined but NOT NULL to use the default value
68 my $columns_info = $schema->resultset( $class->_type )->result_source->columns_info;
69 for my $column_name ( keys %$attributes ) {
70 my $c_info = $columns_info->{$column_name};
71 next if $c_info->{is_nullable};
72 next if not exists $attributes->{$column_name} or defined $attributes->{$column_name};
73 delete $attributes->{$column_name};
77 $schema->resultset( $class->_type() )->new($attributes);
80 croak("No _type found! Koha::Object must be subclassed!")
81 unless $class->_type();
83 bless( $self, $class );
87 =head3 Koha::Object->_new_from_dbic();
89 my $object = Koha::Object->_new_from_dbic($dbic_row);
94 my ( $class, $dbic_row ) = @_;
98 $self->{_result} = $dbic_row;
100 croak("No _type found! Koha::Object must be subclassed!")
101 unless $class->_type();
103 croak( "DBIC result _type " . ref( $self->{_result} ) . " isn't of the _type " . $class->_type() )
104 unless ref( $self->{_result} ) eq "Koha::Schema::Result::" . $class->_type();
106 bless( $self, $class );
110 =head3 $object->store();
112 Saves the object in storage.
113 If the object is new, it will be created.
114 If the object previously existed, it will be updated.
117 $self if the store was a success
118 undef if the store failed
125 my $columns_info = $self->_result->result_source->columns_info;
127 # Handle not null and default values for integers and dates
128 foreach my $col ( keys %{$columns_info} ) {
130 if ( _numeric_column_type( $columns_info->{$col}->{data_type} ) ) {
131 # Has been passed but not a number, usually an empty string
132 if ( defined $self->$col and not looks_like_number( $self->$col ) ) {
133 if ( $columns_info->{$col}->{is_nullable} ) {
134 # If nullable, default to null
137 # If cannot be null, get the default value
138 # What if cannot be null and does not have a default value? Possible?
139 $self->$col($columns_info->{$col}->{default_value});
143 elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
144 # Set to null if an empty string (or == 0 but should not happen)
145 if ( defined $self->$col and not $self->$col ) {
146 if ( $columns_info->{$col}->{is_nullable} ) {
149 $self->$col($columns_info->{$col}->{default_value});
156 return $self->_result()->update_or_insert() ? $self : undef;
159 # Catch problems and raise relevant exceptions
160 if (ref($_) eq 'DBIx::Class::Exception') {
161 if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
163 # FIXME: MySQL error, if we support more DB engines we should implement this for each
164 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
165 Koha::Exceptions::Object::FKConstraint->throw(
166 error => 'Broken FK constraint',
167 broken_fk => $+{column}
171 elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
172 Koha::Exceptions::Object::DuplicateID->throw(
173 error => 'Duplicate ID',
174 duplicate_id => $+{key}
177 elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
179 my $value = $+{value};
180 my $property = $+{property};
181 $property =~ s/['`]//g;
182 Koha::Exceptions::Object::BadValue->throw(
185 property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
189 # Catch-all for foreign key breakages. It will help find other use cases
194 =head3 $object->update();
196 A shortcut for set + store in one call.
201 my ($self, $values) = @_;
202 return $self->set($values)->store();
205 =head3 $object->delete();
207 Removes the object from storage.
210 1 if the deletion was a success
211 0 if the deletion failed
212 -1 if the object was never in storage
219 my $deleted = $self->_result()->delete;
220 if ( ref $deleted ) {
221 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
222 $deleted = $object_class->_new_from_dbic($deleted);
227 =head3 $object->set( $properties_hashref )
231 property1 => $property1,
232 property2 => $property2,
233 property3 => $propery3,
237 Enables multiple properties to be set at once
240 1 if all properties were set.
241 0 if one or more properties do not exist.
242 undef if all properties exist but a different error
243 prevents one or more properties from being set.
245 If one or more of the properties do not exist,
246 no properties will be set.
251 my ( $self, $properties ) = @_;
253 my @columns = @{$self->_columns()};
255 foreach my $p ( keys %$properties ) {
256 unless ( grep { $_ eq $p } @columns ) {
257 Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
261 return $self->_result()->set_columns($properties) ? $self : undef;
264 =head3 $object->unblessed();
266 Returns an unblessed representation of object.
273 return { $self->_result->get_columns };
276 =head3 $object->get_from_storage;
280 sub get_from_storage {
281 my ( $self, $attrs ) = @_;
282 my $stored_object = $self->_result->get_from_storage($attrs);
283 return unless $stored_object;
284 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
285 return $object_class->_new_from_dbic($stored_object);
288 =head3 $object->TO_JSON
290 Returns an unblessed representation of the object, suitable for JSON output.
298 my $unblessed = $self->unblessed;
299 my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
300 ->result_source->{_columns};
302 foreach my $col ( keys %{$columns_info} ) {
304 if ( $columns_info->{$col}->{is_boolean} )
305 { # Handle booleans gracefully
307 = ( $unblessed->{$col} )
311 elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
312 and looks_like_number( $unblessed->{$col} )
315 # TODO: Remove once the solution for
316 # https://rt.cpan.org/Ticket/Display.html?id=119904
317 # is ported to whatever distro we support by that time
318 $unblessed->{$col} += 0;
320 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
322 return unless $unblessed->{$col};
323 $unblessed->{$col} = output_pref({
324 dateformat => 'rfc3339',
325 dt => dt_from_string($unblessed->{$col}, 'sql'),
333 sub _date_or_datetime_column_type {
334 my ($column_type) = @_;
342 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
344 sub _datetime_column_type {
345 my ($column_type) = @_;
352 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
355 sub _numeric_column_type {
356 # TODO: Remove once the solution for
357 # https://rt.cpan.org/Ticket/Display.html?id=119904
358 # is ported to whatever distro we support by that time
359 my ($column_type) = @_;
361 my @numeric_types = (
373 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
376 =head3 prefetch_whitelist
378 my $whitelist = $object->prefetch_whitelist()
380 Returns a hash of prefetchable subs and the type they return.
384 sub prefetch_whitelist {
388 my $relations = $self->_result->result_source->_relationships;
390 foreach my $key (keys %{$relations}) {
391 if($self->can($key)) {
392 my $result_class = $relations->{$key}->{class};
393 my $obj = $result_class->new;
395 $whitelist->{$key} = $obj->koha_object_class;
397 $whitelist->{$key} = undef;
407 my $object_for_api = $object->to_api(
428 Returns a representation of the object, suitable for API output.
433 my ( $self, $params ) = @_;
434 my $json_object = $self->TO_JSON;
436 my $to_api_mapping = $self->to_api_mapping;
438 # Rename attributes if there's a mapping
439 if ( $self->can('to_api_mapping') ) {
440 foreach my $column ( keys %{ $self->to_api_mapping } ) {
441 my $mapped_column = $self->to_api_mapping->{$column};
442 if ( exists $json_object->{$column}
443 && defined $mapped_column )
446 $json_object->{$mapped_column} = delete $json_object->{$column};
448 elsif ( exists $json_object->{$column}
449 && !defined $mapped_column )
452 delete $json_object->{$column};
457 my $embeds = $params->{embed};
460 foreach my $embed ( keys %{$embeds} ) {
461 if ( $embed =~ m/^(?<relation>.*)_count$/
462 and $embeds->{$embed}->{is_count} ) {
464 my $relation = $+{relation};
465 $json_object->{$embed} = $self->$relation->count;
469 my $next = $embeds->{$curr}->{children};
471 my $children = $self->$curr;
473 if ( defined $children and ref($children) eq 'ARRAY' ) {
475 $self->_handle_to_api_child(
476 { child => $_, next => $next, curr => $curr } )
478 $json_object->{$curr} = \@list;
481 $json_object->{$curr} = $self->_handle_to_api_child(
482 { child => $children, next => $next, curr => $curr } );
493 =head3 to_api_mapping
495 my $mapping = $object->to_api_mapping;
497 Generic method that returns the attribute name mappings required to
498 render the object on the API.
500 Note: this only returns an empty I<hashref>. Each class should have its
501 own mapping returned.
509 =head3 from_api_mapping
511 my $mapping = $object->from_api_mapping;
513 Generic method that returns the attribute name mappings so the data that
514 comes from the API is correctly renamed to match what is required for the DB.
518 sub from_api_mapping {
521 my $to_api_mapping = $self->to_api_mapping;
523 unless ( $self->{_from_api_mapping} ) {
524 while (my ($key, $value) = each %{ $to_api_mapping } ) {
525 $self->{_from_api_mapping}->{$value} = $key
530 return $self->{_from_api_mapping};
535 my $object = Koha::Object->new_from_api;
536 my $object = Koha::Object->new_from_api( $attrs );
538 Creates a new object, mapping the API attribute names to the ones on the DB schema.
543 my ( $class, $params ) = @_;
545 my $self = $class->new;
546 return $self->set_from_api( $params );
551 my $object = Koha::Object->new(...);
552 $object->set_from_api( $attrs )
554 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
559 my ( $self, $from_api_params ) = @_;
561 return $self->set( $self->attributes_from_api( $from_api_params ) );
564 =head3 attributes_from_api
566 my $attributes = attributes_from_api( $params );
568 Returns the passed params, converted from API naming into the model.
572 sub attributes_from_api {
573 my ( $self, $from_api_params ) = @_;
575 my $from_api_mapping = $self->from_api_mapping;
578 my $columns_info = $self->_result->result_source->columns_info;
580 while (my ($key, $value) = each %{ $from_api_params } ) {
581 my $koha_field_name =
582 exists $from_api_mapping->{$key}
583 ? $from_api_mapping->{$key}
586 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
587 # TODO: Remove when D8 is formally deprecated
588 # Handle booleans gracefully
589 $value = ( $value ) ? 1 : 0;
591 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
593 $value = dt_from_string($value, 'rfc3339');
596 Koha::Exceptions::BadParameter->throw( parameter => $key );
600 $params->{$koha_field_name} = $value;
606 =head3 $object->unblessed_all_relateds
608 my $everything_into_one_hashref = $object->unblessed_all_relateds
610 The unblessed method only retrieves column' values for the column of the object.
611 In a *few* cases we want to retrieve the information of all the prefetched data.
615 sub unblessed_all_relateds {
619 my $related_resultsets = $self->_result->{related_resultsets} || {};
620 my $rs = $self->_result;
621 while ( $related_resultsets and %$related_resultsets ) {
622 my @relations = keys %{ $related_resultsets };
624 my $relation = $relations[0];
625 $rs = $rs->related_resultset($relation)->get_cache;
626 $rs = $rs->[0]; # Does it makes sense to have several values here?
627 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
628 my $koha_object = $object_class->_new_from_dbic( $rs );
629 $related_resultsets = $rs->{related_resultsets};
630 %data = ( %data, %{ $koha_object->unblessed } );
633 %data = ( %data, %{ $self->unblessed } );
637 =head3 $object->_result();
639 Returns the internal DBIC Row object
646 # If we don't have a dbic row at this point, we need to create an empty one
648 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
650 return $self->{_result};
653 =head3 $object->_columns();
655 Returns an arrayref of the table columns
662 # If we don't have a dbic row at this point, we need to create an empty one
663 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
665 return $self->{_columns};
668 sub _get_object_class {
672 if( $type->can('koha_object_class') ) {
673 return $type->koha_object_class;
675 $type =~ s|Schema::Result::||;
681 The autoload method is used only to get and set values for an objects properties.
688 my $method = our $AUTOLOAD;
691 my @columns = @{$self->_columns()};
692 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
693 if ( grep { $_ eq $method } @columns ) {
695 $self->_result()->set_column( $method, @_ );
698 my $value = $self->_result()->get_column( $method );
703 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
705 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
706 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
708 ) unless grep { $_ eq $method } @known_methods;
711 my $r = eval { $self->_result->$method(@_) };
713 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
720 This method must be defined in the child class. The value is the name of the DBIC resultset.
721 For example, for borrowers, the _type method will return "Borrower".
727 =head3 _handle_to_api_child
731 sub _handle_to_api_child {
732 my ($self, $args ) = @_;
734 my $child = $args->{child};
735 my $next = $args->{next};
736 my $curr = $args->{curr};
740 if ( defined $child ) {
742 Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
743 if defined $next and blessed $child and !$child->can('to_api');
745 if ( blessed $child ) {
746 $res = $child->to_api({ embed => $next });
760 Kyle M Hall <kyle@bywatersolutions.com>
762 Jonathan Druart <jonathan.druart@bugs.koha-community.org>