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 under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 3 of the License, or (at your option) any later
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
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->delete();
198 Removes the object from storage.
201 1 if the deletion was a success
202 0 if the deletion failed
203 -1 if the object was never in storage
210 # Deleting something not in storage throws an exception
211 return -1 unless $self->_result()->in_storage();
213 # Return a boolean for succcess
214 return $self->_result()->delete() ? 1 : 0;
217 =head3 $object->set( $properties_hashref )
221 property1 => $property1,
222 property2 => $property2,
223 property3 => $propery3,
227 Enables multiple properties to be set at once
230 1 if all properties were set.
231 0 if one or more properties do not exist.
232 undef if all properties exist but a different error
233 prevents one or more properties from being set.
235 If one or more of the properties do not exist,
236 no properties will be set.
241 my ( $self, $properties ) = @_;
243 my @columns = @{$self->_columns()};
245 foreach my $p ( keys %$properties ) {
246 unless ( grep {/^$p$/} @columns ) {
247 Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
251 return $self->_result()->set_columns($properties) ? $self : undef;
254 =head3 $object->unblessed();
256 Returns an unblessed representation of object.
263 return { $self->_result->get_columns };
266 =head3 $object->get_from_storage;
270 sub get_from_storage {
271 my ( $self, $attrs ) = @_;
272 my $stored_object = $self->_result->get_from_storage($attrs);
273 return unless $stored_object;
274 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
275 return $object_class->_new_from_dbic($stored_object);
278 =head3 $object->TO_JSON
280 Returns an unblessed representation of the object, suitable for JSON output.
288 my $unblessed = $self->unblessed;
289 my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
290 ->result_source->{_columns};
292 foreach my $col ( keys %{$columns_info} ) {
294 if ( $columns_info->{$col}->{is_boolean} )
295 { # Handle booleans gracefully
297 = ( $unblessed->{$col} )
301 elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
302 and looks_like_number( $unblessed->{$col} )
305 # TODO: Remove once the solution for
306 # https://rt.cpan.org/Ticket/Display.html?id=119904
307 # is ported to whatever distro we support by that time
308 $unblessed->{$col} += 0;
310 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
312 return unless $unblessed->{$col};
313 $unblessed->{$col} = output_pref({
314 dateformat => 'rfc3339',
315 dt => dt_from_string($unblessed->{$col}, 'sql'),
323 sub _date_or_datetime_column_type {
324 my ($column_type) = @_;
332 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
334 sub _datetime_column_type {
335 my ($column_type) = @_;
342 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
345 sub _numeric_column_type {
346 # TODO: Remove once the solution for
347 # https://rt.cpan.org/Ticket/Display.html?id=119904
348 # is ported to whatever distro we support by that time
349 my ($column_type) = @_;
351 my @numeric_types = (
363 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
368 my $object_for_api = $object->to_api(
389 Returns a representation of the object, suitable for API output.
394 my ( $self, $params ) = @_;
395 my $json_object = $self->TO_JSON;
397 my $to_api_mapping = $self->to_api_mapping;
399 # Rename attributes if there's a mapping
400 if ( $self->can('to_api_mapping') ) {
401 foreach my $column ( keys %{ $self->to_api_mapping } ) {
402 my $mapped_column = $self->to_api_mapping->{$column};
403 if ( exists $json_object->{$column}
404 && defined $mapped_column )
407 $json_object->{$mapped_column} = delete $json_object->{$column};
409 elsif ( exists $json_object->{$column}
410 && !defined $mapped_column )
413 delete $json_object->{$column};
418 my $embeds = $params->{embed};
421 foreach my $embed ( keys %{$embeds} ) {
423 my $next = $embeds->{$curr}->{children};
425 my $children = $self->$curr;
427 if ( defined $children and ref($children) eq 'ARRAY' ) {
429 $self->_handle_to_api_child(
430 { child => $_, next => $next, curr => $curr } )
432 $json_object->{$curr} = \@list;
435 $json_object->{$curr} = $self->_handle_to_api_child(
436 { child => $children, next => $next, curr => $curr } );
446 =head3 to_api_mapping
448 my $mapping = $object->to_api_mapping;
450 Generic method that returns the attribute name mappings required to
451 render the object on the API.
453 Note: this only returns an empty I<hashref>. Each class should have its
454 own mapping returned.
462 =head3 from_api_mapping
464 my $mapping = $object->from_api_mapping;
466 Generic method that returns the attribute name mappings so the data that
467 comes from the API is correctly renamed to match what is required for the DB.
471 sub from_api_mapping {
474 my $to_api_mapping = $self->to_api_mapping;
476 unless ( $self->{_from_api_mapping} ) {
477 while (my ($key, $value) = each %{ $to_api_mapping } ) {
478 $self->{_from_api_mapping}->{$value} = $key
483 return $self->{_from_api_mapping};
488 my $object = Koha::Object->new_from_api;
489 my $object = Koha::Object->new_from_api( $attrs );
491 Creates a new object, mapping the API attribute names to the ones on the DB schema.
496 my ( $class, $params ) = @_;
498 my $self = $class->new;
499 return $self->set_from_api( $params );
504 my $object = Koha::Object->new(...);
505 $object->set_from_api( $attrs )
507 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
512 my ( $self, $from_api_params ) = @_;
514 return $self->set( $self->attributes_from_api( $from_api_params ) );
517 =head3 attributes_from_api
519 my $attributes = attributes_from_api( $params );
521 Returns the passed params, converted from API naming into the model.
525 sub attributes_from_api {
526 my ( $self, $from_api_params ) = @_;
528 my $from_api_mapping = $self->from_api_mapping;
531 my $columns_info = $self->_result->result_source->columns_info;
533 while (my ($key, $value) = each %{ $from_api_params } ) {
534 my $koha_field_name =
535 exists $from_api_mapping->{$key}
536 ? $from_api_mapping->{$key}
539 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
540 # TODO: Remove when D8 is formally deprecated
541 # Handle booleans gracefully
542 $value = ( $value ) ? 1 : 0;
544 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
546 $value = dt_from_string($value, 'rfc3339');
549 Koha::Exceptions::BadParameter->throw( parameter => $key );
553 $params->{$koha_field_name} = $value;
559 =head3 $object->unblessed_all_relateds
561 my $everything_into_one_hashref = $object->unblessed_all_relateds
563 The unblessed method only retrieves column' values for the column of the object.
564 In a *few* cases we want to retrieve the information of all the prefetched data.
568 sub unblessed_all_relateds {
572 my $related_resultsets = $self->_result->{related_resultsets} || {};
573 my $rs = $self->_result;
574 while ( $related_resultsets and %$related_resultsets ) {
575 my @relations = keys %{ $related_resultsets };
577 my $relation = $relations[0];
578 $rs = $rs->related_resultset($relation)->get_cache;
579 $rs = $rs->[0]; # Does it makes sense to have several values here?
580 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
581 my $koha_object = $object_class->_new_from_dbic( $rs );
582 $related_resultsets = $rs->{related_resultsets};
583 %data = ( %data, %{ $koha_object->unblessed } );
586 %data = ( %data, %{ $self->unblessed } );
590 =head3 $object->_result();
592 Returns the internal DBIC Row object
599 # If we don't have a dbic row at this point, we need to create an empty one
601 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
603 return $self->{_result};
606 =head3 $object->_columns();
608 Returns an arrayref of the table columns
615 # If we don't have a dbic row at this point, we need to create an empty one
616 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
618 return $self->{_columns};
621 sub _get_object_class {
625 if( $type->can('koha_object_class') ) {
626 return $type->koha_object_class;
628 $type =~ s|Schema::Result::||;
634 The autoload method is used only to get and set values for an objects properties.
641 my $method = our $AUTOLOAD;
644 my @columns = @{$self->_columns()};
645 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
646 if ( grep {/^$method$/} @columns ) {
648 $self->_result()->set_column( $method, @_ );
651 my $value = $self->_result()->get_column( $method );
656 my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
658 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
659 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
661 ) unless grep { /^$method$/ } @known_methods;
664 my $r = eval { $self->_result->$method(@_) };
666 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
673 This method must be defined in the child class. The value is the name of the DBIC resultset.
674 For example, for borrowers, the _type method will return "Borrower".
680 =head3 _handle_to_api_child
684 sub _handle_to_api_child {
685 my ($self, $args ) = @_;
687 my $child = $args->{child};
688 my $next = $args->{next};
689 my $curr = $args->{curr};
693 if ( defined $child ) {
695 Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
696 if defined $next and blessed $child and !$child->can('to_api');
698 if ( blessed $child ) {
699 $res = $child->to_api({ embed => $next });
713 Kyle M Hall <kyle@bywatersolutions.com>
715 Jonathan Druart <jonathan.druart@bugs.koha-community.org>