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 my $value = $self->_result()->get_column($col);
133 if ( defined $value and not looks_like_number( $value ) ) {
134 if ( $columns_info->{$col}->{is_nullable} ) {
135 # If nullable, default to null
136 $self->_result()->set_column($col => undef);
138 # If cannot be null, get the default value
139 # What if cannot be null and does not have a default value? Possible?
140 $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
144 elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
145 # Set to null if an empty string (or == 0 but should not happen)
146 my $value = $self->_result()->get_column($col);
147 if ( defined $value and not $value ) {
148 if ( $columns_info->{$col}->{is_nullable} ) {
149 $self->_result()->set_column($col => undef);
151 $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
158 return $self->_result()->update_or_insert() ? $self : undef;
161 # Catch problems and raise relevant exceptions
162 if (ref($_) eq 'DBIx::Class::Exception') {
163 if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
165 # FIXME: MySQL error, if we support more DB engines we should implement this for each
166 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
167 Koha::Exceptions::Object::FKConstraint->throw(
168 error => 'Broken FK constraint',
169 broken_fk => $+{column}
173 elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
174 Koha::Exceptions::Object::DuplicateID->throw(
175 error => 'Duplicate ID',
176 duplicate_id => $+{key}
179 elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
181 my $value = $+{value};
182 my $property = $+{property};
183 $property =~ s/['`]//g;
184 Koha::Exceptions::Object::BadValue->throw(
187 property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
191 # Catch-all for foreign key breakages. It will help find other use cases
196 =head3 $object->update();
198 A shortcut for set + store in one call.
203 my ($self, $values) = @_;
204 return $self->set($values)->store();
207 =head3 $object->delete();
209 Removes the object from storage.
212 1 if the deletion was a success
213 0 if the deletion failed
214 -1 if the object was never in storage
221 my $deleted = $self->_result()->delete;
222 if ( ref $deleted ) {
223 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
224 $deleted = $object_class->_new_from_dbic($deleted);
229 =head3 $object->set( $properties_hashref )
233 property1 => $property1,
234 property2 => $property2,
235 property3 => $propery3,
239 Enables multiple properties to be set at once
242 1 if all properties were set.
243 0 if one or more properties do not exist.
244 undef if all properties exist but a different error
245 prevents one or more properties from being set.
247 If one or more of the properties do not exist,
248 no properties will be set.
253 my ( $self, $properties ) = @_;
255 my @columns = @{$self->_columns()};
257 foreach my $p ( keys %$properties ) {
258 unless ( grep { $_ eq $p } @columns ) {
259 Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
263 return $self->_result()->set_columns($properties) ? $self : undef;
266 =head3 $object->unblessed();
268 Returns an unblessed representation of object.
275 return { $self->_result->get_columns };
278 =head3 $object->get_from_storage;
282 sub get_from_storage {
283 my ( $self, $attrs ) = @_;
284 my $stored_object = $self->_result->get_from_storage($attrs);
285 return unless $stored_object;
286 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
287 return $object_class->_new_from_dbic($stored_object);
290 =head3 $object->TO_JSON
292 Returns an unblessed representation of the object, suitable for JSON output.
300 my $unblessed = $self->unblessed;
301 my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
302 ->result_source->{_columns};
304 foreach my $col ( keys %{$columns_info} ) {
306 if ( $columns_info->{$col}->{is_boolean} )
307 { # Handle booleans gracefully
309 = ( $unblessed->{$col} )
313 elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
314 and looks_like_number( $unblessed->{$col} )
317 # TODO: Remove once the solution for
318 # https://rt.cpan.org/Ticket/Display.html?id=119904
319 # is ported to whatever distro we support by that time
320 $unblessed->{$col} += 0;
322 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
324 return unless $unblessed->{$col};
325 $unblessed->{$col} = output_pref({
326 dateformat => 'rfc3339',
327 dt => dt_from_string($unblessed->{$col}, 'sql'),
335 sub _date_or_datetime_column_type {
336 my ($column_type) = @_;
344 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
346 sub _datetime_column_type {
347 my ($column_type) = @_;
354 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
357 sub _numeric_column_type {
358 # TODO: Remove once the solution for
359 # https://rt.cpan.org/Ticket/Display.html?id=119904
360 # is ported to whatever distro we support by that time
361 my ($column_type) = @_;
363 my @numeric_types = (
375 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
378 =head3 prefetch_whitelist
380 my $whitelist = $object->prefetch_whitelist()
382 Returns a hash of prefetchable subs and the type they return.
386 sub prefetch_whitelist {
390 my $relations = $self->_result->result_source->_relationships;
392 foreach my $key (keys %{$relations}) {
393 if($self->can($key)) {
394 my $result_class = $relations->{$key}->{class};
395 my $obj = $result_class->new;
397 $whitelist->{$key} = $obj->koha_object_class;
399 $whitelist->{$key} = undef;
409 my $object_for_api = $object->to_api(
430 Returns a representation of the object, suitable for API output.
435 my ( $self, $params ) = @_;
436 my $json_object = $self->TO_JSON;
438 my $to_api_mapping = $self->to_api_mapping;
440 # Rename attributes if there's a mapping
441 if ( $self->can('to_api_mapping') ) {
442 foreach my $column ( keys %{ $self->to_api_mapping } ) {
443 my $mapped_column = $self->to_api_mapping->{$column};
444 if ( exists $json_object->{$column}
445 && defined $mapped_column )
448 $json_object->{$mapped_column} = delete $json_object->{$column};
450 elsif ( exists $json_object->{$column}
451 && !defined $mapped_column )
454 delete $json_object->{$column};
459 my $embeds = $params->{embed};
462 foreach my $embed ( keys %{$embeds} ) {
463 if ( $embed =~ m/^(?<relation>.*)_count$/
464 and $embeds->{$embed}->{is_count} ) {
466 my $relation = $+{relation};
467 $json_object->{$embed} = $self->$relation->count;
471 my $next = $embeds->{$curr}->{children};
473 my $children = $self->$curr;
475 if ( defined $children and ref($children) eq 'ARRAY' ) {
477 $self->_handle_to_api_child(
478 { child => $_, next => $next, curr => $curr } )
480 $json_object->{$curr} = \@list;
483 $json_object->{$curr} = $self->_handle_to_api_child(
484 { child => $children, next => $next, curr => $curr } );
495 =head3 to_api_mapping
497 my $mapping = $object->to_api_mapping;
499 Generic method that returns the attribute name mappings required to
500 render the object on the API.
502 Note: this only returns an empty I<hashref>. Each class should have its
503 own mapping returned.
511 =head3 from_api_mapping
513 my $mapping = $object->from_api_mapping;
515 Generic method that returns the attribute name mappings so the data that
516 comes from the API is correctly renamed to match what is required for the DB.
520 sub from_api_mapping {
523 my $to_api_mapping = $self->to_api_mapping;
525 unless ( $self->{_from_api_mapping} ) {
526 while (my ($key, $value) = each %{ $to_api_mapping } ) {
527 $self->{_from_api_mapping}->{$value} = $key
532 return $self->{_from_api_mapping};
537 my $object = Koha::Object->new_from_api;
538 my $object = Koha::Object->new_from_api( $attrs );
540 Creates a new object, mapping the API attribute names to the ones on the DB schema.
545 my ( $class, $params ) = @_;
547 my $self = $class->new;
548 return $self->set_from_api( $params );
553 my $object = Koha::Object->new(...);
554 $object->set_from_api( $attrs )
556 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
561 my ( $self, $from_api_params ) = @_;
563 return $self->set( $self->attributes_from_api( $from_api_params ) );
566 =head3 attributes_from_api
568 my $attributes = attributes_from_api( $params );
570 Returns the passed params, converted from API naming into the model.
574 sub attributes_from_api {
575 my ( $self, $from_api_params ) = @_;
577 my $from_api_mapping = $self->from_api_mapping;
580 my $columns_info = $self->_result->result_source->columns_info;
582 while (my ($key, $value) = each %{ $from_api_params } ) {
583 my $koha_field_name =
584 exists $from_api_mapping->{$key}
585 ? $from_api_mapping->{$key}
588 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
589 # TODO: Remove when D8 is formally deprecated
590 # Handle booleans gracefully
591 $value = ( $value ) ? 1 : 0;
593 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
595 $value = dt_from_string($value, 'rfc3339');
598 Koha::Exceptions::BadParameter->throw( parameter => $key );
602 $params->{$koha_field_name} = $value;
608 =head3 $object->unblessed_all_relateds
610 my $everything_into_one_hashref = $object->unblessed_all_relateds
612 The unblessed method only retrieves column' values for the column of the object.
613 In a *few* cases we want to retrieve the information of all the prefetched data.
617 sub unblessed_all_relateds {
621 my $related_resultsets = $self->_result->{related_resultsets} || {};
622 my $rs = $self->_result;
623 while ( $related_resultsets and %$related_resultsets ) {
624 my @relations = keys %{ $related_resultsets };
626 my $relation = $relations[0];
627 $rs = $rs->related_resultset($relation)->get_cache;
628 $rs = $rs->[0]; # Does it makes sense to have several values here?
629 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
630 my $koha_object = $object_class->_new_from_dbic( $rs );
631 $related_resultsets = $rs->{related_resultsets};
632 %data = ( %data, %{ $koha_object->unblessed } );
635 %data = ( %data, %{ $self->unblessed } );
639 =head3 $object->_result();
641 Returns the internal DBIC Row object
648 # If we don't have a dbic row at this point, we need to create an empty one
650 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
652 return $self->{_result};
655 =head3 $object->_columns();
657 Returns an arrayref of the table columns
664 # If we don't have a dbic row at this point, we need to create an empty one
665 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
667 return $self->{_columns};
670 sub _get_object_class {
674 if( $type->can('koha_object_class') ) {
675 return $type->koha_object_class;
677 $type =~ s|Schema::Result::||;
683 The autoload method is used only to get and set values for an objects properties.
690 my $method = our $AUTOLOAD;
693 my @columns = @{$self->_columns()};
694 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
695 if ( grep { $_ eq $method } @columns ) {
697 $self->_result()->set_column( $method, @_ );
700 my $value = $self->_result()->get_column( $method );
705 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
707 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
708 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
710 ) unless grep { $_ eq $method } @known_methods;
713 my $r = eval { $self->_result->$method(@_) };
715 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
722 This method must be defined in the child class. The value is the name of the DBIC resultset.
723 For example, for borrowers, the _type method will return "Borrower".
729 =head3 _handle_to_api_child
733 sub _handle_to_api_child {
734 my ($self, $args ) = @_;
736 my $child = $args->{child};
737 my $next = $args->{next};
738 my $curr = $args->{curr};
742 if ( defined $child ) {
744 Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
745 if defined $next and blessed $child and !$child->can('to_api');
747 if ( blessed $child ) {
748 $res = $child->to_api({ embed => $next });
762 Kyle M Hall <kyle@bywatersolutions.com>
764 Jonathan Druart <jonathan.druart@bugs.koha-community.org>